Dogcows Code - chaz/p5-File-KDBX/blob - lib/File/KDBX/Iterator.pm

   1 package File::KDBX::Iterator;
   2 # ABSTRACT: KDBX database iterator
   3
   4 use warnings;
   5 use strict;
   6
   7 use File::KDBX::Error;
   8 use File::KDBX::Util qw(:class :load :search);
   9 use Iterator::Simple;
  10 use Module::Loaded;
  11 use Ref::Util qw(is_arrayref is_coderef is_ref is_scalarref);
  12 use namespace::clean;
  13
  14 BEGIN { mark_as_loaded('Iterator::Simple::Iterator') }
  15 extends 'Iterator::Simple::Iterator';
  16
  17 our $VERSION = '0.901'; # VERSION
  18
  19
  20 sub new {
  21     my $class = shift;
  22     my $code  = is_coderef($_[0]) ? shift : sub { undef };
  23
  24     my $items = @_ == 1 && is_arrayref($_[0]) ? $_[0] : \@_;
  25     return $class->SUPER::new(sub {
  26         if (@_) {   # put back
  27             if (@_ == 1 && is_arrayref($_[0])) {
  28                 $items = $_[0];
  29             }
  30             else {
  31                 unshift @$items, @_;
  32             }
  33             return;
  34         }
  35         else {
  36             my $next = shift @$items;
  37             return $next if defined $next;
  38             return $code->();
  39         }
  40     });
  41 }
  42
  43
  44 sub next {
  45     my $self = shift;
  46     my $code = shift or return $self->();
  47
  48     $code = query_any($code, @_);
  49
  50     while (defined (local $_ = $self->())) {
  51         return $_ if $code->($_);
  52     }
  53     return;
  54 }
  55
  56
  57 sub peek {
  58     my $self = shift;
  59
  60     my $next = $self->();
  61     $self->($next) if defined $next;
  62     return $next;
  63 }
  64
  65
  66 sub unget {
  67     my $self = shift;   # Must shift in a statement before calling.
  68     $self->(@_);
  69 }
  70
  71
  72 sub each {
  73     my $self = shift;
  74     my $cb = shift or return @{$self->to_array};
  75
  76     if (is_coderef($cb)) {
  77         my $count = 0;
  78         $cb->($_, $count++, @_) while defined (local $_ = $self->());
  79     }
  80     elsif (!is_ref($cb)) {
  81         $_->$cb(@_) while defined (local $_ = $self->());
  82     }
  83     return $self;
  84 }
  85
  86
  87 sub where { shift->grep(@_) }
  88
  89 sub grep {
  90     my $self = shift;
  91     my $code = query_any(@_);
  92
  93     ref($self)->new(sub {
  94         while (defined (local $_ = $self->())) {
  95             return $_ if $code->($_);
  96         }
  97         return;
  98     });
  99 }
 100
 101
 102 sub map {
 103     my $self = shift;
 104     my $code = shift;
 105
 106     ref($self)->new(sub {
 107         local $_ = $self->();
 108         return if !defined $_;
 109         return $code->();
 110     });
 111 }
 112
 113
 114 sub order_by {
 115     my $self    = shift;
 116     my $field   = shift;
 117     my %args    = @_;
 118
 119     my $ascending = delete $args{ascending} // !delete $args{descending} // 1;
 120     my $case = delete $args{case} // !delete $args{no_case} // 1;
 121     my $collate = (delete $args{collate} // !delete $args{no_collate} // 1)
 122         && try_load_optional('Unicode::Collate');
 123
 124     if ($collate && !$case) {
 125         $case = 1;
 126         # use a proper Unicode::Collate level to ignore case
 127         $args{level} //= 2;
 128     }
 129     $args{upper_before_lower} //= 1;
 130
 131     my $value = $field;
 132     $value = $case ? sub { $_[0]->$field // '' } : sub { uc($_[0]->$field) // '' } if !is_coderef($value);
 133     my @all = CORE::map { [$_, $value->($_)] } @{$self->to_array};
 134
 135     if ($collate) {
 136         my $c = Unicode::Collate->new(%args);
 137         if ($ascending) {
 138             @all = CORE::map { $_->[0] } CORE::sort { $c->cmp($a->[1], $b->[1]) } @all;
 139         } else {
 140             @all = CORE::map { $_->[0] } CORE::sort { $c->cmp($b->[1], $a->[1]) } @all;
 141         }
 142     } else {
 143         if ($ascending) {
 144             @all = CORE::map { $_->[0] } CORE::sort { $a->[1] cmp $b->[1] } @all;
 145         } else {
 146             @all = CORE::map { $_->[0] } CORE::sort { $b->[1] cmp $a->[1] } @all;
 147         }
 148     }
 149
 150     $self->(\@all);
 151     return $self;
 152 }
 153
 154
 155 sub sort_by { shift->order_by(@_)  }
 156
 157
 158 sub norder_by {
 159     my $self    = shift;
 160     my $field   = shift;
 161     my %args    = @_;
 162
 163     my $ascending = $args{ascending} // !$args{descending} // 1;
 164
 165     my $value = $field;
 166     $value = sub { $_[0]->$field // 0 } if !is_coderef($value);
 167     my @all = CORE::map { [$_, $value->($_)] } @{$self->to_array};
 168
 169     if ($ascending) {
 170         @all = CORE::map { $_->[0] } CORE::sort { $a->[1] <=> $b->[1] } @all;
 171     } else {
 172         @all = CORE::map { $_->[0] } CORE::sort { $b->[1] <=> $a->[1] } @all;
 173     }
 174
 175     $self->(\@all);
 176     return $self;
 177 }
 178
 179
 180 sub nsort_by { shift->norder_by(@_) }
 181
 182
 183 sub limit { shift->head(@_) }
 184
 185
 186 sub to_array {
 187     my $self = shift;
 188
 189     my @all;
 190     push @all, $_ while defined (local $_ = $self->());
 191     return \@all;
 192 }
 193
 194
 195 sub count {
 196     my $self = shift;
 197
 198     my $items = $self->to_array;
 199     $self->($items);
 200     return scalar @$items;
 201 }
 202
 203
 204 sub size { shift->count }
 205
 206 ##############################################################################
 207
 208 sub TO_JSON { $_[0]->to_array }
 209
 210 1;
 211
 212 __END__
 213
 214 =pod
 215
 216 =encoding UTF-8
 217
 218 =head1 NAME
 219
 220 File::KDBX::Iterator - KDBX database iterator
 221
 222 =head1 VERSION
 223
 224 version 0.901
 225
 226 =head1 SYNOPSIS
 227
 228     my $kdbx = File::KDBX->load('database.kdbx', 'masterpw');
 229
 230     $kdbx->entries
 231         ->where(sub { $_->title =~ /bank/i })
 232         ->order_by('title')
 233         ->limit(5)
 234         ->each(sub {
 235             say $_->title;
 236         });
 237
 238 =head1 DESCRIPTION
 239
 240 A buffered iterator compatible with and expanding upon L<Iterator::Simple>, this provides an easy way to
 241 navigate a L<File::KDBX> database. The documentation for B<Iterator::Simple> documents functions and methods
 242 supported but this iterator that are not documented here, so consider that additional reading.
 243
 244 =head2 Buffer
 245
 246 This iterator is buffered, meaning it can drain from an iterator subroutine under the hood, storing items
 247 temporarily to be accessed later. This allows features like L</peek> and L</order_by> which might be useful in
 248 the context of KDBX databases which are normally pretty small so draining an iterator completely isn't
 249 cost-prohibitive in terms of memory usage.
 250
 251 The way this works is that if you call an iterator without arguments, it acts like a normal iterator. If you
 252 call it with arguments, however, the arguments are added to the buffer. When called without arguments, the
 253 buffer is drained before the iterator function is. Using L</unget> is equivalent to calling the iterator with
 254 arguments, and L</next> is equivalent to calling the iterator without arguments.
 255
 256 =head1 METHODS
 257
 258 =head2 new
 259
 260     \&iterator = File::KDBX::Iterator->new(\&iterator);
 261
 262 Bless an iterator to augment it with buffering plus some useful utility methods.
 263
 264 =head2 next
 265
 266     $item = $iterator->next;
 267     # OR equivalently
 268     $item = $iterator->();
 269
 270     $item = $iterator->next(\&query);
 271
 272 Get the next item or C<undef> if there are no more items. If a query is passed, get the next matching item,
 273 discarding any unmatching items before the matching item. Example:
 274
 275     my $item = $iterator->next(sub { $_->label =~ /Gym/ });
 276
 277 =head2 peek
 278
 279     $item = $iterator->peek;
 280
 281 Peek at the next item. Returns C<undef> if the iterator is empty. This allows you to access the next item
 282 without draining it from the iterator. The same item will be returned the next time L</next> is called.
 283
 284 =head2 unget
 285
 286     # Replace buffer:
 287     $iterator->unget(\@items);
 288     # OR equivalently
 289     $iterator->(\@items);
 290
 291     # Unshift onto buffer:
 292     $iterator->unget(@items);
 293     # OR equivalently
 294     $iterator->(@items);
 295
 296 Replace the buffer (first form) or unshift one or more items to the current buffer (second form).
 297
 298 See L</Buffer>.
 299
 300 =head2 each
 301
 302     @items = $iterator->each;
 303
 304     $iterator->each(sub($item, $num, @args) { ... }, @args);
 305
 306     $iterator->each($method_name, ...);
 307
 308 Get or act on the rest of the items. This method has three forms:
 309
 310 =over 4
 311
 312 =item 1
 313
 314 Without arguments, C<each> returns a list of the rest of the items.
 315
 316 =item 2
 317
 318 Pass a coderef to be called once per item, in order. Arguments to the coderef are the item itself (also available as C<$_>), its index number and then any extra arguments that were passed to C<each> after the coderef.
 319
 320 =item 3
 321
 322 Pass a string that is the name of a method to be called on each object, in order. Any extra arguments passed to C<each> after the method name are passed through to each method call. This form requires each item be an object that C<can> the given method.
 323
 324 =back
 325
 326 B<NOTE:> This method drains the iterator completely, leaving it empty. See L</CAVEATS>.
 327
 328 =head2 grep
 329
 330 =head2 where
 331
 332     \&iterator = $iterator->grep(\&query);
 333
 334 Get a new iterator draining from an existing iterator but providing only items that pass a test or are matched
 335 by a query. In its basic form this method is very much like perl's built-in grep function, except for
 336 iterators.
 337
 338 There are many examples of the various forms of this method at L<File::KDBX/QUERY>.
 339
 340 =head2 map
 341
 342     \&iterator = $iterator->map(\&code);
 343
 344 Get a new iterator draining from an existing iterator but providing modified items. In its basic form this
 345 method is very much like perl's built-in map function, except for iterators.
 346
 347 =head2 order_by
 348
 349     \&iterator = $iterator->sort_by($field, %options);
 350     \&iterator = $iterator->sort_by(\&get_value, %options);
 351
 352 Get a new iterator draining from an existing iterator but providing items sorted by an object field. Sorting
 353 is done using L<Unicode::Collate> (if available) or C<cmp> to sort alphanumerically. The C<\&get_value>
 354 subroutine is called once for each item and should return a string value. Options:
 355
 356 =over 4
 357
 358 =item *
 359
 360 C<ascending> - Order ascending if true, descending otherwise (default: true)
 361
 362 =item *
 363
 364 C<case> - If true, take case into account, otherwise ignore case (default: true)
 365
 366 =item *
 367
 368 C<collate> - If true, use B<Unicode::Collate> (if available), otherwise use perl built-ins (default: true)
 369
 370 =item *
 371
 372 Any B<Unicode::Collate> option is also supported.
 373
 374 =back
 375
 376 B<NOTE:> This method drains the iterator completely and places the sorted items onto the buffer. See
 377 L</CAVEATS>.
 378
 379 =head2 sort_by
 380
 381 Alias for L</order_by>.
 382
 383 =head2 norder_by
 384
 385     \&iterator = $iterator->nsort_by($field, %options);
 386     \&iterator = $iterator->nsort_by(\&get_value, %options);
 387
 388 Get a new iterator draining from an existing iterator but providing items sorted by an object field. Sorting
 389 is done numerically using C<< <=> >>. The C<\&get_value> subroutine or C<$field> accessor is called once for
 390 each item and should return a numerical value. Options:
 391
 392 =over 4
 393
 394 =item *
 395
 396 C<ascending> - Order ascending if true, descending otherwise (default: true)
 397
 398 =back
 399
 400 B<NOTE:> This method drains the iterator completely and places the sorted items onto the buffer. See
 401 L</CAVEATS>.
 402
 403 =head2 nsort_by
 404
 405 Alias for L</norder_by>.
 406
 407 =head2 limit
 408
 409     \&iterator = $iterator->limit($count);
 410
 411 Get a new iterator draining from an existing iterator but providing only a limited number of items.
 412
 413 C<limit> as an alias for L<< Iterator::Simple/"$iterator->head($count)" >>.
 414
 415 =head2 to_array
 416
 417     \@array = $iterator->to_array;
 418
 419 Get the rest of the items from an iterator as an arrayref.
 420
 421 B<NOTE:> This method drains the iterator completely, leaving it empty. See L</CAVEATS>.
 422
 423 =head2 count
 424
 425     $size = $iterator->count;
 426
 427 Count the rest of the items from an iterator.
 428
 429 B<NOTE:> This method drains the iterator completely but restores it to its pre-drained state. See L</CAVEATS>.
 430
 431 =head2 size
 432
 433 Alias for L</count>.
 434
 435 =for Pod::Coverage TO_JSON
 436
 437 =head1 CAVEATS
 438
 439 Some methods attempt to drain the iterator completely before returning. For obvious reasons, this won't work
 440 for infinite iterators because your computer doesn't have infinite memory. This isn't a practical issue with
 441 B<File::KDBX> lists which are always finite -- unless you do something weird like force a child group to be
 442 its own ancestor -- but I'm noting it here as a potential issue if you use this iterator class for other
 443 things (which you probably shouldn't do).
 444
 445 =head1 BUGS
 446
 447 Please report any bugs or feature requests on the bugtracker website
 448 L<https://github.com/chazmcgarvey/File-KDBX/issues>
 449
 450 When submitting a bug or request, please include a test-file or a
 451 patch to an existing test-file that illustrates the bug or desired
 452 feature.
 453
 454 =head1 AUTHOR
 455
 456 Charles McGarvey <ccm@cpan.org>
 457
 458 =head1 COPYRIGHT AND LICENSE
 459
 460 This software is copyright (c) 2022 by Charles McGarvey.
 461
 462 This is free software; you can redistribute it and/or modify it under
 463 the same terms as the Perl 5 programming language system itself.
 464
 465 =cut