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.903'; # 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.903
 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 by 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     \&iterator = $iterator->grep(sub($item) { ... });
 334
 335 Get a new iterator draining from an existing iterator but providing only items that pass a test or are matched
 336 by a query. In its basic form this method is very much like perl's built-in grep function, except for
 337 iterators.
 338
 339 There are many examples of the various forms of this method at L<File::KDBX/QUERY>.
 340
 341 =head2 map
 342
 343     \&iterator = $iterator->map(\&code);
 344
 345 Get a new iterator draining from an existing iterator but providing modified items. In its basic form this
 346 method is very much like perl's built-in map function, except for iterators.
 347
 348 =head2 order_by
 349
 350     \&iterator = $iterator->sort_by($field, %options);
 351     \&iterator = $iterator->sort_by(\&get_value, %options);
 352
 353 Get a new iterator draining from an existing iterator but providing items sorted by an object field. Sorting
 354 is done using L<Unicode::Collate> (if available) or C<cmp> to sort alphanumerically. The C<\&get_value>
 355 subroutine is called once for each item and should return a string value. Options:
 356
 357 =over 4
 358
 359 =item *
 360
 361 C<ascending> - Order ascending if true, descending otherwise (default: true)
 362
 363 =item *
 364
 365 C<case> - If true, take case into account, otherwise ignore case (default: true)
 366
 367 =item *
 368
 369 C<collate> - If true, use B<Unicode::Collate> (if available), otherwise use perl built-ins (default: true)
 370
 371 =item *
 372
 373 Any B<Unicode::Collate> option is also supported.
 374
 375 =back
 376
 377 B<NOTE:> This method drains the iterator completely and places the sorted items onto the buffer. See
 378 L</CAVEATS>.
 379
 380 =head2 sort_by
 381
 382 Alias for L</order_by>.
 383
 384 =head2 norder_by
 385
 386     \&iterator = $iterator->nsort_by($field, %options);
 387     \&iterator = $iterator->nsort_by(\&get_value, %options);
 388
 389 Get a new iterator draining from an existing iterator but providing items sorted by an object field. Sorting
 390 is done numerically using C<< <=> >>. The C<\&get_value> subroutine or C<$field> accessor is called once for
 391 each item and should return a numerical value. Options:
 392
 393 =over 4
 394
 395 =item *
 396
 397 C<ascending> - Order ascending if true, descending otherwise (default: true)
 398
 399 =back
 400
 401 B<NOTE:> This method drains the iterator completely and places the sorted items onto the buffer. See
 402 L</CAVEATS>.
 403
 404 =head2 nsort_by
 405
 406 Alias for L</norder_by>.
 407
 408 =head2 limit
 409
 410     \&iterator = $iterator->limit($count);
 411
 412 Get a new iterator draining from an existing iterator but providing only a limited number of items.
 413
 414 C<limit> is an alias for L<< Iterator::Simple/"$iterator->head($count)" >>.
 415
 416 =head2 to_array
 417
 418     \@array = $iterator->to_array;
 419
 420 Get the rest of the items from an iterator as an arrayref.
 421
 422 B<NOTE:> This method drains the iterator completely, leaving it empty. See L</CAVEATS>.
 423
 424 =head2 count
 425
 426     $size = $iterator->count;
 427
 428 Count the rest of the items from an iterator.
 429
 430 B<NOTE:> This method drains the iterator completely but restores it to its pre-drained state. See L</CAVEATS>.
 431
 432 =head2 size
 433
 434 Alias for L</count>.
 435
 436 =for Pod::Coverage TO_JSON
 437
 438 =head1 CAVEATS
 439
 440 Some methods attempt to drain the iterator completely before returning. For obvious reasons, this won't work
 441 for infinite iterators because your computer doesn't have infinite memory. This isn't a practical issue with
 442 B<File::KDBX> lists which are always finite -- unless you do something weird like force a child group to be
 443 its own ancestor -- but I'm noting it here as a potential issue if you use this iterator class for other
 444 things (which you probably shouldn't do).
 445
 446 KDBX databases are always fully-loaded into memory anyway, so there's not a significant memory cost to
 447 draining an iterator completely.
 448
 449 =head1 BUGS
 450
 451 Please report any bugs or feature requests on the bugtracker website
 452 L<https://github.com/chazmcgarvey/File-KDBX/issues>
 453
 454 When submitting a bug or request, please include a test-file or a
 455 patch to an existing test-file that illustrates the bug or desired
 456 feature.
 457
 458 =head1 AUTHOR
 459
 460 Charles McGarvey <ccm@cpan.org>
 461
 462 =head1 COPYRIGHT AND LICENSE
 463
 464 This software is copyright (c) 2022 by Charles McGarvey.
 465
 466 This is free software; you can redistribute it and/or modify it under
 467 the same terms as the Perl 5 programming language system itself.
 468
 469 =cut