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