File Coverage

blib/lib/List/Gen.pm
Criterion Covered Total %
statement 609 2142 28.4
branch 203 1154 17.5
condition 81 395 20.5
subroutine 167 539 30.9
pod 57 80 71.2
total 1117 4310 25.9


line stmt bran cond sub pod time code
1             package List::Gen;
2 10     10   235800 use warnings;
  10         26  
  10         492  
3 10     10   54 use strict;
  10         21  
  10         314  
4 10     10   51 use Carp;
  10         23  
  10         936  
5 10     10   8555 use Symbol qw/delete_package/;
  10         10132  
  10         818  
6 10     10   64 use Scalar::Util qw/reftype weaken openhandle blessed/;
  10         16  
  10         1445  
7             our @list_util;
8             use List::Util
9 10     10   74 @list_util = qw/first max maxstr min minstr reduce shuffle sum/;
  10         21  
  10         3740  
10             our @EXPORT = qw/mapn by every range gen cap filter cache apply
11             zip min max reduce glob iterate list/;
12             our %EXPORT_TAGS = (
13             base => \@EXPORT,
14             'List::Util' => \@list_util,
15             map {s/==//g; s/#.*//g;
16             /:(\w+)\s+(.+)/s ? ($1 => [split /\s+/ => $2]) : ()
17             } split /\n{2,}/ => q(
18            
19             :utility mapn by every apply min max reduce mapab
20             mapkey d deref slide curse remove
21            
22             :source range glob makegen list array vecgen repeat file
23            
24             :modify gen cache expand contract collect slice flip overlay
25             test recursive sequence scan scan_stream == scanS
26             cartesian transpose stream strict
27            
28             :zip zip zipgen tuples zipwith zipwithab unzip unzipn
29             zipmax zipgenmax zipwithmax
30            
31             :iterate iterate
32             iterate_multi == iterateM
33             iterate_stream == iterateS
34             iterate_multi_stream == iterateMS
35            
36             :gather gather
37             gather_stream == gatherS
38             gather_multi == gatherM
39             gather_multi_stream == gatherMS
40            
41             :mutable mutable done done_if done_unless
42            
43             :filter filter
44             filter_stream == filterS
45             filter_ # non-lookahead version
46            
47             :while take_while == While
48             take_until == Until
49             while_ until_ # non-lookahead versions
50             drop_while drop_until
51            
52             :numeric primes
53            
54             :deprecated genzip
55             ));
56            
57             our @EXPORT_OK = keys %{{map {$_ => 1} map @$_, values %EXPORT_TAGS}};
58             $EXPORT_TAGS{all} = \@EXPORT_OK;
59             BEGIN {
60 10     10   52 require Exporter;
61 10         22359 require overload;
62 10         11981 require B;
63 10         5536 *List::Generator:: = *List::Gen::;
64             }
65             sub import {
66 12 50 66 12   2230 if (@_ == 2 and !$_[1] || $_[1] eq '*') {
      66        
67 6         28 splice @_, 1, 1, ':all', '\\'
68             }
69 12 100       54 push @_, '\\' if @_ == 1;
70 12 100       33 @_ = grep {/^&?\\$/ ? do {*\ = \∩ 0} : 1} @_;
  30         144  
  12         46  
  12         48  
71 12 50       30 @_ = map {/^<.*>$/ ? 'glob' : $_} @_;
  18         85  
72 12         27 goto &{Exporter->can('import')}
  12         14465  
73             }
74             sub VERSION {
75 3 100 66 3 0 34 goto &{@_ > 1 && $_[1] == 0 ? *import : *UNIVERSAL::VERSION}
  3         71  
76             }
77            
78 973     973 0 2414 sub DEBUG () {}
79             DEBUG or $Carp::Internal{(__PACKAGE__)}++;
80            
81             our $LIST = 0; # deprecated
82             our $LOOKAHEAD = 1;
83             our $DWIM_CODE_STRINGS = 0;
84             our $SAY_EVAL = 0;
85             our $STREAM = 0;
86             our $STRICT = 0;
87            
88             my $MAX_IDX = eval {require POSIX; POSIX::DBL_MAX()} || 2**53 - 1;
89            
90             our $VERSION = '0.974';
91            
92             =head1 NAME
93            
94             List::Gen - provides functions for generating lists
95            
96             =head1 VERSION
97            
98             version 0.974
99            
100             =head1 SYNOPSIS
101            
102             this module provides higher order functions, list comprehensions, generators,
103             iterators, and other utility functions for working with lists. walk lists
104             with any step size you want, create lazy ranges and arrays with a map like
105             syntax that generate values on demand. there are several other hopefully useful
106             functions, and all functions from List::Util are available.
107            
108             use List::Gen;
109            
110             print "@$_\n" for every 5 => 1 .. 15;
111             # 1 2 3 4 5
112             # 6 7 8 9 10
113             # 11 12 13 14 15
114            
115             print mapn {"$_[0]: $_[1]\n"} 2 => %myhash;
116            
117             my $ints = <0..>;
118             my $squares = gen {$_**2} $ints;
119            
120             say "@$squares[2 .. 6]"; # 4 9 16 25 36
121            
122             $ints->zip('.', -$squares)->say(6); # 0-0 1-1 2-4 3-9 4-16 5-25
123            
124             list(1, 2, 3)->gen('**2')->say; # 1 4 9
125            
126             my $fib = ([0, 1] + iterate {fib($_, $_ + 1)->sum})->rec('fib');
127             my $fac = iterate {$_ < 2 or $_ * self($_ - 1)}->rec;
128            
129             say "@$fib[0 .. 15]"; # 0 1 1 2 3 5 8 13 21 34 55 89 144 233 377 610
130             say "@$fac[0 .. 10]"; # 1 1 2 6 24 120 720 5040 40320 362880 3628800
131            
132             say <0, 1, * + * ...>->take(10)->str; # 0 1 1 2 3 5 8 13 21 34
133             say <[..*] 1, 1..>->str(8); # 1 1 2 6 24 120 720 5040
134            
135             <**2 for 1..10 if even>->say; # 4 16 36 64 100
136            
137             <1..>->map('**2')->grep(qr/1/)->say(5); # 1 16 81 100 121
138            
139             =head1 EXPORT
140            
141             use List::Gen; # is the same as
142             use List::Gen qw/mapn by every range gen cap \ filter cache apply zip
143             min max reduce glob iterate list/;
144            
145             the following export tags are available:
146            
147             :utility mapn by every apply min max reduce mapab
148             mapkey d deref slide curse remove
149            
150             :source range glob makegen list array vecgen repeat file
151            
152             :modify gen cache expand contract collect slice flip overlay
153             test recursive sequence scan scan_stream == scanS
154             cartesian transpose stream strict
155            
156             :zip zip zipgen tuples zipwith zipwithab unzip unzipn
157             zipmax zipgenmax zipwithmax
158            
159             :iterate iterate
160             iterate_multi == iterateM
161             iterate_stream == iterateS
162             iterate_multi_stream == iterateMS
163            
164             :gather gather
165             gather_stream == gatherS
166             gather_multi == gatherM
167             gather_multi_stream == gatherMS
168            
169             :mutable mutable done done_if done_unless
170            
171             :filter filter
172             filter_stream == filterS
173             filter_ # non-lookahead version
174            
175             :while take_while == While
176             take_until == Until
177             while_ until_ # non-lookahead versions
178             drop_while drop_until
179            
180             :numeric primes
181            
182             :deprecated genzip
183            
184             :List::Util first max maxstr min minstr reduce shuffle sum
185            
186             use List::Gen '*'; # everything
187             use List::Gen 0; # everything
188             use List::Gen ':all'; # everything
189             use List::Gen ':base'; # same as 'use List::Gen;'
190             use List::Gen (); # no exports
191            
192             =cut
193            
194             sub mapn (&$@);
195             #my @packages; END {print "package $_;\n" for sort @packages}
196             sub packager {
197 280     280 0 759 unshift @_, split /\s+/ => shift;
198 280         425 my $pkg = shift;
199 280         571 my @isa = deref(shift);
200            
201 280 50       521 for ($pkg, @isa) {/:/ or s/^/List::Gen::/}
  560         2782  
202             #push @packages, $pkg;
203 10     10   71 no strict 'refs';
  10         35  
  10         2603  
204 280         390 *{$pkg.'::ISA'} = \@isa;
  280         5315  
205 280     560   1753 mapn {*{$pkg.'::'.$_} = pop} 2 => @_;
  560         575  
  560         4064  
206 280         1085 1
207             }
208             sub generator {
209 220 50   220 0 1034 splice @_, 1, 0, 'Base', @_ > 1 ? 'TIEARRAY' : ();
210 220         597 goto &packager
211             }
212             sub mutable_gen {
213 60 50   60 0 249 splice @_, 1, 0, 'Mutable', @_ > 1 ? 'TIEARRAY' : ();
214 60         143 goto &packager
215             }
216            
217             require Sub::Name if DEBUG;
218             {my %id;
219             sub curse {
220 197     197 1 311 my ($obj, $class) = @_;
221 197   33     430 my $pkg = $class || caller;
222 197         539 $pkg .= '::_'.++$id{$pkg};
223            
224 10     10   55 no strict 'refs';
  10         29  
  10         4133  
225 197 50       205 croak "package $pkg not empty" if %{$pkg.'::'};
  197         2138  
226            
227 197         814 my $destroy = delete $$obj{DESTROY};
228 197         919 *{$pkg.'::DESTROY'} = sub {
229 187 50   187   18399 {&{ $destroy or next}}
  187         204  
  187         445  
230 187 100 50     189 {&{($class or next)->can('DESTROY') or next}}
  187         202  
  187         1575  
231 187         537 delete_package $pkg
232 197         608 };
233 197 50       473 @{$pkg.'::ISA'} = $class if $class;
  197         3290  
234            
235 197 100       648 for my $name (grep {not /^-/ and ref $$obj{$_} eq 'CODE'} keys %$obj) {
  856         3891  
236 804 50 33     1321 DEBUG and B::svref_2object($$obj{$name})->GV->NAME =~ /__ANON__/
237             and Sub::Name::subname("$class\::$name", $$obj{$name});
238 804         962 *{$pkg.'::'.$name} = $$obj{$name}
  804         3611  
239             }
240 197 50       627 if ($$obj{-overload}) {
241 0         0 eval 'package '.$pkg.'; use overload @{$$obj{-overload}}'
242             }
243 197   66     2511 bless $$obj{-bless} || $obj => $pkg
244             }}
245            
246             sub looks_like_number ($) {
247 10         2929 Scalar::Util::looks_like_number($_[0])
248 10     10   61 or do {no warnings 'numeric'; $_[0] >= 9**9**9}
  10         16  
  16         176  
249 104 50 66 104 0 577 or do {
250 16 50 0     462 ref $_[0]
      0        
      33        
251             and blessed $_[0]
252             and $_[0]->isa('Math::BigInt')
253             || $_[0]->isa('Math::BigRat')
254             || $_[0]->isa('Math::BigFloat')
255             }
256             }
257            
258             our $sv2cv;
259            
260             my $cv_caller = sub {
261             reftype($_[0]) eq 'CODE' or croak "not code: $_[0]";
262             B::svref_2object($_[0])->STASH->NAME
263             };
264            
265             my $cv_local = sub {
266             my $caller = shift->$cv_caller;
267 10     10   54 no strict 'refs';
  10         20  
  10         10211  
268             my @ret = map \*{$caller.'::'.$_} => @_;
269             wantarray ? @ret : pop @ret
270             };
271            
272             my $cv_ab_ref = sub {
273             $_[0]->$cv_local(qw(a b))
274             };
275            
276             my $cv_wants_2_args = sub {
277             (prototype $_[0] or '') eq '$$'
278             };
279            
280             my $any_mutable = sub {
281             for (@_) {return 1 if ref and isagen($_) and $_->is_mutable}
282             ''
283             };
284            
285             my $external_package = sub {
286             my $up = @_ ? $_[0] : 1;
287             $up++ while (substr caller $up, 0 => 9) eq 'List::Gen';
288             scalar caller $up
289             };
290            
291             my $isagen = \&isagen;
292            
293             my $is_array_or_gen = sub {ref $_[0] eq 'ARRAY' or &isagen};
294            
295             my $say_eval = sub {Carp::cluck "eval ($_[0]): '$_[1]'"};
296            
297             my $eval = sub {
298             my $pkg = $external_package->(2);
299             my ($msg, $code) = @_;
300             &$say_eval if $SAY_EVAL or DEBUG;
301            
302             my $say = $code =~ /(?:\b|^)say(?:\b|$)/
303             ? "use feature 'say';"
304             : '';
305             $code = "[do {$code}]" if wantarray;
306             local @$;
307             my $ret = eval "package $pkg; $say \\do {$code}"
308             or croak "$msg code error: $@\n$say $code\n";
309             wantarray ? @$$ret : $$ret
310             };
311            
312            
313             =head1 FUNCTIONS
314            
315             =over 4
316            
317             =item mapn C< {CODE} NUM LIST >
318            
319             this function works like the builtin C< map > but takes C< NUM > sized steps
320             over the list, rather than one element at a time. inside the C< CODE > block,
321             the current slice is in C< @_ > and C< $_ > is set to C< $_[0] >. slice elements
322             are aliases to the original list. if C< mapn > is called in void context, the
323             C< CODE > block will be executed in void context for efficiency.
324            
325             print mapn {$_ % 2 ? "@_" : " [@_] "} 3 => 1..20;
326             # 1 2 3 [4 5 6] 7 8 9 [10 11 12] 13 14 15 [16 17 18] 19 20
327            
328             print "student grades: \n";
329             mapn {
330             print shift, ": ", &sum / @_, "\n";
331             } 5 => qw {
332             bob 90 80 65 85
333             alice 75 95 70 100
334             eve 80 90 80 75
335             };
336            
337             =cut
338            
339             sub mapn (&$@) {
340 285     285 1 608 my ($sub, $n, @ret) = splice @_, 0, 2;
341 285 50       605 croak '$_[1] must be >= 1' unless $n >= 1;
342            
343 285 50       527 return map $sub->($_) => @_ if $n == 1;
344            
345 285         392 my $want = defined wantarray;
346 285         630 while (@_) {
347 570         963 local *_ = \$_[0];
348 570 50       954 if ($want) {push @ret =>
  0         0  
  570         1181  
349             $sub->(splice @_, 0, $n)}
350             else {$sub->(splice @_, 0, $n)}
351             }
352             @ret
353 285         464 }
354            
355            
356             =item by C< NUM LIST >
357            
358             =item every C< NUM LIST >
359            
360             C< by > and C< every > are exactly the same, and allow you to add variable step
361             size to any other list control structure with whichever reads better to you.
362            
363             for (every 2 => @_) {do something with pairs in @$_}
364            
365             grep {do something with triples in @$_} by 3 => @list;
366            
367             the functions generate an array of array references to C< NUM > sized slices of
368             C< LIST >. the elements in each slice are aliases to the original list.
369            
370             in list context, returns a real array.
371             in scalar context, returns a generator.
372            
373             my @slices = every 2 => 1 .. 10; # real array
374             my $slices = every 2 => 1 .. 10; # generator
375             for (every 2 => 1 .. 10) { ... } # real array
376             for (@{every 2 => 1 .. 10}) { ... } # generator
377            
378             if you plan to use all the slices, the real array is probably better. if you
379             only need a few, the generator won't need to compute all of the other slices.
380            
381             print "@$_\n" for every 3 => 1..9;
382             # 1 2 3
383             # 4 5 6
384             # 7 8 9
385            
386             my @a = 1 .. 10;
387             for (every 2 => @a) {
388             @$_[0, 1] = @$_[1, 0] # flip each pair
389             }
390             print "@a";
391             # 2 1 4 3 6 5 8 7 10 9
392            
393             print "@$_\n" for grep {$$_[0] % 2} by 3 => 1 .. 9;
394             # 1 2 3
395             # 7 8 9
396            
397             =cut
398            
399             sub by ($@) {
400 0 0   0 1 0 croak '$_[0] must be >= 1' unless $_[0] >= 1;
401 0 0       0 if (wantarray) {
402 0 0 0     0 if (@_ == 2 and ref $_[1] and isagen($_[1])) {
      0        
403 0         0 return &mapn(\&cap, $_[0], $_[1]->all)
404             } else {
405 0         0 unshift @_, \∩
406 0         0 goto &mapn
407             }
408             }
409 0         0 tie my @ret => 'List::Gen::By', shift, \@_;
410 0         0 List::Gen::erator->new(\@ret)
411             }
412 10     10   15665 BEGIN {*every = \&by}
413             generator By => sub {
414 10     10   27 my ($class, $n, $source) = @_;
415 10 0 33     65 if (@$source == 1 and ref $$source[0] and isagen($$source[0])) {
      33        
416 0         0 $source = $$source[0];
417             }
418 10         64 my $size = @$source / $n;
419 10         31 my $last = $#$source;
420            
421 10 50       60 $size ++ if $size > int $size;
422 10         22 $size = int $size;
423 10         26 my %cache;
424             curse {
425             FETCH => isagen($source)
426             ? do {
427 0         0 my $fetch = tied(@$source)->can('FETCH');
428 0         0 my $src_size = $source->size;
429 0 0       0 $source->tail_size($src_size) if $source->is_mutable;
430             sub {
431 0     0   0 my $i = $n * $_[1];
432 0 0 0     0 $cache{$i} ||= $i < $src_size
433             ? cap (map $fetch->(undef, $_) => $i .. min($last, $i + $n - 1))
434 0         0 : croak "index $_[1] out of bounds [0 .. @{[int( $#$source / $n )]}]"
435             }
436 0         0 } : sub {
437 0     0   0 my $i = $n * $_[1];
438 0 0 0     0 $cache{$i} ||= $i < @$source
439             ? cap (@$source[$i .. min($last, $i + $n - 1)])
440 0         0 : croak "index $_[1] out of bounds [0 .. @{[int( $#$source / $n )]}]"
441             },
442 10     10   28 fsize => sub {$size}
443 10 50       60 } => $class
444             };
445            
446            
447             =item apply C< {CODE} LIST >
448            
449             apply a function that modifies C< $_ > to a shallow copy of C< LIST > and
450             returns the copy
451            
452             print join ", " => apply {s/$/ one/} "this", "and that";
453             > this one, and that one
454            
455             =cut
456            
457             sub apply (&@) {
458 0     0 1 0 my ($sub, @ret) = splice @_;
459 0         0 &$sub for @ret;
460 0 0       0 wantarray ? @ret : pop @ret
461             }
462            
463            
464             =item zip C< LIST >
465            
466             C< zip > takes a list of array references and generators. it interleaves the
467             elements of the passed in sequences to create a new list. C< zip > continues
468             until the end of the shortest sequence. C< LIST > can be any combination of
469             array references and generators.
470            
471             %hash = zip [qw/a b c/], [1..3]; # same as
472             %hash = (a => 1, b => 2, c => 3);
473            
474             in scalar context, C< zip > returns a generator, produced by C< zipgen >
475            
476             if the first argument to C< zip > is not an array or generator, it is assumed
477             to be code or a code like string. that code will be used to join the elements
478             from the remaining arguments.
479            
480             my $gen = zip sub {$_[0] . $_[1]}, [1..5], ;
481             # or = zip '.' => [1..5], ;
482             # or = zipwith {$_[0] . $_[1]} [1..5], ;
483            
484             $gen->str; # '1a 2b 3c 4d 5e'
485            
486             =cut
487            
488             sub zip {
489 0     0 1 0 my $code;
490 0 0       0 unless ($_[0]->$is_array_or_gen) {
491 0         0 $code = shift;
492 0         0 $code->$sv2cv;
493 0         0 unshift @_, $code;
494             }
495 0 0       0 local *zipgen = *zipwith if $code;
496 0 0       0 goto &zipgen unless wantarray;
497 0 0       0 return &zipgen->all if &$any_mutable;
498 0 0       0 if ($code) {
499 0         0 shift @_;
500 0         0 map {my $i = $_;
  0         0  
501 0         0 $code->(map $$_[$i] => @_)
502             } 0 .. min map $#$_ => @_
503             }
504             else {
505 0         0 map {my $i = $_;
  0         0  
506 0         0 map $$_[$i] => @_
507             } 0 .. min map $#$_ => @_
508             }
509             }
510            
511            
512             =item zipmax C< LIST >
513            
514             interleaves the passed in lists to create a new list. C< zipmax > continues
515             until the end of the longest list, C< undef > is returned for missing elements
516             of shorter lists. C< LIST > can be any combination of array references and
517             generators.
518            
519             %hash = zipmax [qw/a b c d/], [1..3]; # same as
520             %hash = (a => 1, b => 2, c => 3, d => undef);
521            
522             in scalar context, C< zipmax > returns a generator, produced by C< zipgenmax >
523            
524             C< zipmax > provides the same functionality as C< zip > did in versions before
525             0.90
526            
527             =cut
528            
529             sub zipmax {
530 0     0 1 0 my $code;
531 0 0       0 unless ($_[0]->$is_array_or_gen) {
532 0         0 $code = shift;
533 0         0 $code->$sv2cv;
534 0         0 unshift @_, $code;
535             }
536 0 0       0 local *zipgenmax = *zipwithmax if $code;
537 0 0       0 goto &zipgenmax unless wantarray;
538 0 0       0 return &zipgenmax->all if &$any_mutable;
539 0 0       0 if ($code) {
540 0         0 shift @_;
541 0         0 map {my $i = $_;
  0         0  
542 0 0       0 $code->(map {$i < @$_ ? $$_[$i] : undef} @_)
  0         0  
543             } 0 .. max map $#$_ => @_
544             }
545             else {
546 0         0 map {my $i = $_;
  0         0  
547 0 0       0 map {$i < @$_ ? $$_[$i] : undef} @_
  0         0  
548             } 0 .. max map $#$_ => @_
549             }
550             }
551            
552            
553             =item tuples C< LIST >
554            
555             interleaves the passed in lists to create a new list of arrays. C< tuples >
556             continues until the end of the shortest list. C< LIST > can be any combination
557             of array references and generators.
558            
559             @list = tuples [qw/a b c/], [1..3]; # same as
560             @list = ([a => 1], [b => 2], [c => 3]);
561            
562             in scalar context, C< tuples > returns a generator:
563            
564             tuples(...) ~~ zipwith {\@_} ...
565            
566             =cut
567            
568             sub tuples {
569 0 0   0 1 0 unless (wantarray) {
570 0         0 unshift @_, \∩
571 0         0 goto &zipwith
572             }
573 0 0       0 if (&$any_mutable) {
574 0         0 unshift @_, \∩
575 0         0 return &zipwith->all
576             }
577 0         0 map {my $i = $_;
  0         0  
578 0         0 cap (map $$_[$i] => @_)
579             } 0 .. min map $#$_ => @_
580             }
581            
582            
583             =item cap C< LIST >
584            
585             C< cap > captures a list, it is exactly the same as C<< sub{\@_}->(LIST) >>
586            
587             note that this method of constructing an array ref from a list is roughly 40%
588             faster than C< [ LIST ]>, but with the caveat and feature that elements are
589             aliases to the original list
590            
591             =item C< &\(LIST) >
592            
593             a synonym for C< cap >, the symbols C< &\(...) > will perform the same action.
594             it could be read as taking the subroutine style reference of a list. like all
595             symbol variables, once imported, C< &\ > is global across all packages.
596            
597             my $capture = & \(my $x, my $y); # a space between & and \ is fine
598             # and it looks a bit more syntactic
599             ($x, $y) = (1, 2);
600             say "@$capture"; # 1 2
601            
602             =cut
603            
604 51     51 1 169 sub cap {\@_}
605            
606            
607             =back
608            
609             =head2 generators
610            
611             =over 4
612            
613             in this document, a generator is an object similar to an array that generates
614             its elements on demand. generators can be used as iterators in perl's list
615             control structures such as C< for/foreach > and C< while >. generators, like
616             programmers, are lazy. unless they have to, they will not calculate or store
617             anything. this laziness allows infinite generators to be created. you can
618             choose to explicitly cache a generator, and several generators have implicit
619             caches for efficiency.
620            
621             there are source generators, which can be numeric ranges, arrays, or iterative
622             subroutines. these can then be modified by wrapping each element with a
623             subroutine, filtering elements, or combining generators with other generators.
624             all of this behavior is lazy, only resolving generator elements at the latest
625             possible time.
626            
627             all generator functions return a blessed and overloaded reference to a tied
628             array. this may sound a bit magical, but it just means that you can access
629             the generator in a variety of ways, all which remain lazy.
630            
631             given the generator:
632            
633             my $gen = gen {$_**2} range 0, 100;
634             or gen {$_**2} 0, 100;
635             or range(0, 100)->map(sub {$_**2});
636             or <0..100>->map('**2');
637             or <**2 for 0..100>;
638            
639             which describes the sequence of C< n**2 for n from 0 to 100 by 1 >:
640            
641             0 1 4 9 16 25 ... 9604 9801 10000
642            
643             the following lines are equivalent (each prints C<'25'>):
644            
645             say $gen->get(5);
646             say $gen->(5);
647             say $gen->[5];
648             say $gen->drop(5)->head;
649             say $gen->('5..')->head;
650            
651             as are these (each printing C<'25 36 49 64 81 100'>):
652            
653             say "@$gen[5 .. 10]";
654             say join ' ' => $gen->slice(5 .. 10);
655             say join ' ' => $gen->(5 .. 10);
656             say join ' ' => @$gen[5 .. 10];
657             say $gen->slice(range 5 => 10)->str;
658             say $gen->drop(5)->take(6)->str;
659             say $gen->(<5..10>)->str;
660             say $gen->('5..10')->str;
661            
662             =back
663            
664             =head3 generators as arrays
665            
666             =over 4
667            
668             you can access generators as if they were array references. only the requested
669             indicies will be generated.
670            
671             my $range = range 0, 1_000_000, 0.2;
672             # will produce 0, 0.2, 0.4, ... 1000000
673            
674             say "@$range[10 .. 15]"; # calculates 6 values: 2 2.2 2.4 2.6 2.8 3
675            
676             my $gen = gen {$_**2} $range; # attaches a generator function to a range
677            
678             say "@$gen[10 .. 15]"; # '4 4.84 5.76 6.76 7.84 9'
679            
680             for (@$gen) {
681             last if $_ > some_condition;
682             # the iteration of this loop is lazy, so when exited
683             # with `last`, no extra values are generated
684             ...
685             }
686            
687             =back
688            
689             =head3 generators in loops
690            
691             =over 4
692            
693             evaluation in each of these looping examples remains lazy. using C< last > to
694             escape from the loop early will result in some values never being generated.
695            
696             ... for @$gen;
697             for my $x (@$gen) {...}
698             ... while <$gen>;
699             while (my ($next) = $gen->()) {...}
700            
701             there are also looping methods, which take a subroutine. calling C< last > from
702             the subroutine works the same as in the examples above.
703            
704             $gen->do(sub {...}); or ->each
705            
706             For {$gen} sub {
707             ... # indirect object syntax
708             };
709            
710             there is also a user space subroutine named C< &last > that is installed into
711             the calling namespace during the execution of the loop. calling it without
712             arguments has the same function as the builtin C< last >. calling it with an
713             argument will still end the looping construct, but will also cause the loop to
714             return the argument. the C< done ... > exception also works the same way as
715             C< &last(...) >
716            
717             my $first = $gen->do(sub {&last($_) if /something/});
718             # same as: $gen->first(qr/something/);
719            
720             you can use generators as file handle iterators:
721            
722             local $_;
723             while (<$gen>) { # calls $gen->next internally
724             # do something with $_
725             }
726            
727             =back
728            
729             =head3 generators as objects
730            
731             all generators have the following methods by default
732            
733             =over 4
734            
735             =item * B:
736            
737             $gen->next # iterates over generator ~~ $gen->get($gen->index++)
738             $gen->() # same. iterators return () when past the end
739            
740             $gen->more # test if $gen->index not past end
741             $gen->reset # reset iterator to start
742             $gen->reset(4) # $gen->next returns $$gen[4]
743             $gen->index # fetches the current position
744             $gen->index = 4 # same as $gen->reset(4)
745             $gen->nxt # next until defined
746             $gen->iterator # returns the $gen->next coderef iterator
747            
748             =item * B:
749            
750             $gen->get(index) # returns $$gen[index]
751             $gen->(index) # same
752            
753             $gen->slice(4 .. 12) # returns @$gen[4 .. 12]
754             $gen->(4 .. 12) # same
755            
756             $gen->size # returns 'scalar @$gen'
757             $gen->all # same as list context '@$gen' but faster
758             $gen->list # same as $gen->all
759            
760             =item * B:
761            
762             $gen->join(' ') # join ' ', $gen->all
763             $gen->str # join $", $gen->all (recursive with nested generators)
764             $gen->str(10) # limits generators to 10 elements
765             $gen->perl # serializes the generator in array syntax (recursive)
766             $gen->perl(9) # limits generators to 9 elements
767             $gen->perl(9, '...') # prints ... at the end of each truncated generator
768             $gen->print(...); # print $gen->str(...)
769             $gen->say(...); # print $gen->str(...), $/
770             $gen->say(*FH, ...) # print FH $gen->str(...), $/
771             $gen->dump(...) # print $gen->perl(...), $/
772             $gen->debug # carps debugging information
773             $gen->watch(...) # prints ..., value, $/ each time a value is requested
774            
775             =item * B:
776            
777             $gen->do(sub {...}) # for (@$gen) {...} # but faster
778             $gen->each(sub{...}) # same
779            
780             =item * B:
781            
782             $gen->head # $gen->get(0)
783             $gen->tail # $gen->slice(<1..>) # lazy slices
784             $gen->drop(2) # $gen->slice(<2..>)
785             $gen->take(4) # $gen->slice(<0..3>)
786             $gen->x_xs # ($gen->head, $gen->tail)
787            
788             =item * B:
789            
790             $gen->range # range(0, $gen->size - 1)
791             $gen->keys # same as $gen->range, but a list in list context
792             $gen->values # same as $gen, but a list in list context
793             $gen->kv # zip($gen->range, $gen)
794             $gen->pairs # same as ->kv, but each pair is a tuple (array ref)
795            
796             =item * B:
797            
798             $gen->pick # return a random element from $gen
799             $gen->pick(n) # return n random elements from $gen
800             $gen->roll # same as pick
801             $gen->roll(n) # pick and replace
802             $gen->shuffle # a lazy shuffled generator
803             $gen->random # an infinite generator that returns random elements
804            
805             =item * B:
806            
807             $gen->first(sub {$_ > 5}) # first {$_ > 5} $gen->all # but faster
808             $gen->first('>5') # same
809             $gen->last(...) # $gen->reverse->first(...)
810             $gen->first_idx(...) # same as first, but returns the index
811             $gen->last_idx(...)
812            
813             =item * B:
814            
815             $gen->sort # sort $gen->all
816             $gen->sort(sub {$a <=> $b}) # sort {$a <=> $b} $gen->all
817             $gen->sort('<=>') # same
818             $gen->sort('uc', 'cmp') # does: map {$$_[0]}
819             # sort {$$a[1] cmp $$b[1]}
820             # map {[$_ => uc]} $gen->all
821            
822             =item * B:
823            
824             $gen->reduce(sub {$a + $b}) # reduce {$a + $b} $gen->all
825             $gen->reduce('+') # same
826             $gen->sum # $gen->reduce('+')
827             $gen->product # $gen->reduce('*')
828             $gen->scan('+') # [$$gen[0], sum(@$gen[0..1]), sum(@$gen[0..2]), ...]
829             $gen->min # min $gen->all
830             $gen->max # max $gen->all
831            
832             =item * B:
833            
834             $gen->cycle # infinite repetition of a generator
835             $gen->rotate(1) # [$gen[1], $gen[2] ... $gen[-1], $gen[0]]
836             $gen->rotate(-1) # [$gen[-1], $gen[0], $gen[1] ... $gen[-2]]
837             $gen->uniq # $gen->filter(do {my %seen; sub {not $seen{$_}++}})
838             $gen->deref # tuples($a, $b)->deref ~~ zip($a, $b)
839            
840             =item * B:
841            
842             $gen->zip($gen2, ...) # takes any number of generators or array refs
843             $gen->cross($gen2) # cross product
844             $gen->cross2d($gen2) # returns a 2D generator containing the same
845             # elements as the flat ->cross generator
846             $gen->tuples($gen2) # tuples($gen, $gen2)
847            
848             the C< zip > and the C< cross > methods all use the comma operator (C< ',' >)
849             by default to join their arguments. if the first argument to any of these
850             methods is code or a code like string, that will be used to join the arguments.
851             more detail in the overloaded operators section below
852            
853             $gen->zip(',' => $gen2) # same as $gen->zip($gen2)
854             $gen->zip('.' => $gen2) # $gen[0].$gen2[0], $gen[1].$gen2[1], ...
855            
856             =item * B:
857            
858             $gen->type # returns the package name of the generator
859             $gen->is_mutable # can the generator change size?
860            
861             =item * B:
862            
863             $gen->apply # causes a mutable generator to determine its true size
864             $gen->clone # copy a generator, resets the index
865             $gen->copy # copy a generator, preserves the index
866             $gen->purge # purge any caches in the source chain
867            
868             =item * B:
869            
870             $gen->leaves # returns a coderef iterator that will perform a depth first
871             # traversal of the edge nodes in a tree of nested generators.
872             # a full run of the iterator will ->reset all of the internal
873             # generators
874            
875             =item * B:
876            
877             $gen->while(...) # While {...} $gen
878             $gen->take_while(...) # same
879             $gen->drop_while(...) # $gen->drop( $gen->first_idx(sub {...}) )
880            
881             $gen->span # collects $gen->next calls until one
882             # returns undef, then returns the collection.
883             # ->span starts from and moves the ->index
884             $gen->span(sub{...}) # span with an argument splits the list when the code
885             # returns false, it is equivalent to but more efficient
886             # than ($gen->take_while(...), $gen->drop_while(...))
887             $gen->break(...) # $gen->span(sub {not ...})
888            
889             =item * B:
890            
891             the methods duplicate and extend the tied functionality and are necessary when
892             working with indices outside of perl's array limit C< (0 .. 2**31 - 1) > or when
893             fetching a list return value (perl clamps the return to a scalar with the array
894             syntax). in all cases, they are also faster than the tied interface.
895            
896             =item * B:
897            
898             most of the functions in this package are also methods of generators, including
899             by, every, mapn, gen, map (alias of gen), filter, grep (alias of filter), test,
900             cache, flip, reverse (alias of flip), expand, collect, overlay, mutable, while,
901             until, recursive, rec (alias of recursive).
902            
903             my $gen = (range 0, 1_000_000)->gen(sub{$_**2})->filter(sub{$_ % 2});
904             #same as: filter {$_ % 2} gen {$_**2} 0, 1_000_000;
905            
906             =item * B:
907            
908             when a method takes a code ref, that code ref can be specified as a string
909             containing an operator and an optional curried argument (on either side)
910            
911             my $gen = <0 .. 1_000_000>->map('**2')->grep('%2'); # same as above
912            
913             you can prefix C< ! > or C< not > to negate the operator:
914            
915             my $even = <1..>->grep('!%2'); # sub {not $_ % 2}
916            
917             you can even use a typeglob to specify an operator when the method expects a
918             binary subroutine:
919            
920             say <1 .. 10>->reduce(*+); # 55 # and saves a character over '+'
921            
922             or a regex ref:
923            
924             <1..30>->grep(qr/3/)->say; # 3 13 23 30
925            
926             you can flip the arguments to a binary operator by prefixing it with C< R > or
927             by applying the C< ~ > operator to it:
928            
929             say ->reduce('R.'); # 'dcba' # lowercase r works too
930             say ->reduce(~'.'); # 'dcba'
931             say ->reduce(~*.); # 'dcba'
932            
933             =item * B:
934            
935             the methods that do not have a useful return value, such as C<< ->say >>,
936             return the same generator they were called with. this lets you easily insert
937             these methods at any point in a method chain for debugging.
938            
939             =back
940            
941             =head3 predicates
942            
943             =over 4
944            
945             several predicates are available to use with the filtering methods:
946            
947             <1..>->grep('even' )->say(5); # 2 4 6 8 10
948             <1..>->grep('odd' )->say(5); # 1 3 5 7 9
949             <1..>->grep('prime')->say(5); # 2 3 5 7 11
950             <1.. if prime>->say(5); # 2 3 5 7 11
951            
952             others are: defined, true, false
953            
954             =back
955            
956             =head3 lazy slices
957            
958             =over 4
959            
960             if you call the C< slice > method with a C< range > or other numeric generator
961             as its argument, the method will return a generator that will perform the slice
962            
963             my $gen = gen {$_ ** 2};
964             my $slice = $gen->slice(range 100 => 1000); # nothing calculated
965            
966             say "@$slice[5 .. 10]"; # 6 values calculated
967            
968             or using the glob syntax:
969            
970             my $slice = $gen->slice(<100 .. 1000>);
971            
972             infinite slices are fine:
973            
974             my $tail = $gen->slice(<1..>);
975            
976             lazy slices also work with the dwim code-deref syntax:
977            
978             my $tail = $gen->(<1..>);
979            
980             stacked continuous lazy slices collapse into a single composite slice for
981             efficiency
982            
983             my $slice = $gen->(<1..>)->(<1..>)->(<1..>);
984            
985             $slice == $gen->(<3..>);
986            
987             if you choose not to import the C< glob > function, you can still write ranges
988             succinctly as strings, when used as arguments to slice:
989            
990             my $tail = $gen->('1..');
991             my $tail = $gen->slice('1..');
992            
993             =back
994            
995             =head3 dwim code dereference
996            
997             =over 4
998            
999             when dereferenced as code, a generator decides what do do based on the
1000             arguments it is passed.
1001            
1002             $gen->() ~~ $gen->next
1003             $gen->(1) ~~ $gen->get(1) or $$gen[1]
1004             $gen->(1, 2, ...) ~~ $gen->slice(1, 2, ...) or @$gen[1, 2, ...]
1005             $gen->(<1..>) ~~ $gen->slice(<1..>) or $gen->tail
1006            
1007             if passed a code ref or regex ref, C<< ->map >> will be called with the argument,
1008             if passed a reference to a code ref or regex ref, C<< ->grep >> will be called.
1009            
1010             my $pow2 = <0..>->(sub {$_**2}); # calls ->map(sub{...})
1011             my $uc = $gen->(\qr/[A-Z]/); # calls ->grep(qr/.../)
1012            
1013             you can lexically enable code coercion from strings (experimental):
1014            
1015             local $List::Gen::DWIM_CODE_STRINGS = 1;
1016            
1017             my $gen = <0 .. 1_000_000>->('**2')(\'%2');
1018             ^map ^grep
1019            
1020             due to some scoping issues, if you want to install this dwim coderef into
1021             a subroutine, the reliable way is to call the C<< ->code >> method:
1022            
1023             *fib = <0, 1, *+*...>->code; # rather than *fib = \&{<0, 1, *+*...>}
1024            
1025             =back
1026            
1027             =head3 overloaded operators
1028            
1029             =over 4
1030            
1031             to make the usage of generators a bit more syntactic the following operators
1032             are overridden:
1033            
1034             $gen1 x $gen2 ~~ $gen1->cross($gen2)
1035             $gen1 x'.'x $gen2 ~~ $gen1->cross('.', $gen2)
1036             or $gen1->cross(sub {$_[0].$_[1]}, $gen2)
1037             $gen1 x sub{$_[0].$_[1]} x $gen2 # same as above
1038            
1039             $gen1 + $gen2 ~~ sequence $gen1, $gen2
1040             $g1 + $g2 + $g3 ~~ sequence $g1, $g2, $g3 # or more
1041            
1042             $gen1 | $gen2 ~~ $gen1->zip($gen2)
1043             $gen1 |'+'| $gen2 ~~ $gen1->zip('+', $gen2)
1044             or $gen1->zip(sub {$_[0] + $_[1]}, $gen2)
1045             $gen1 |sub{$_[0]+$_[1]}| $gen2 # same as above
1046            
1047             $x | $y | $z ~~ $x->zip($y, $z)
1048             $w | $x | $y | $z ~~ $w->zip($x, $y, $z) # or more
1049            
1050             if the first argument to a C<< ->zip >> or C<< ->cross >> method is not an
1051             array or generator, it is assumed to be a subroutine and the corresponding
1052             C<< ->(zip|cross)with >> method is called:
1053            
1054             $gen1->zipwith('+', $gen2) ~~ $gen1->zip('+', $gen2);
1055            
1056             B:
1057            
1058             not quite as elegant as perl6's hyper operators, but the same idea. these are
1059             similar to C< zipwith > but with more control over the length of the returned
1060             generator. all of perl's non-mutating binary operators are available to use as
1061             strings, or you can use a subroutine.
1062            
1063             $gen1 <<'.'>> $gen2 # longest list
1064             $gen1 >>'+'<< $gen2 # equal length lists or error
1065             $gen1 >>'-'>> $gen2 # length of $gen2
1066             $gen1 <<'=='<< $gen2 # length of $gen1
1067            
1068             $gen1 <> $gen2
1069             $gen1 <<\&some_sub>> $gen2
1070            
1071             my $x = <1..> <<'.'>> 'x';
1072            
1073             $x->say(5); # '1x 2x 3x 4x 5x'
1074            
1075             in the last example, a bare string is the final element, and precedence rules
1076             keep everything working. however, if you want to use a non generator as the
1077             first element, a few parens are needed to force the evaluation properly:
1078            
1079             my $y = 'y' <<('.'>> <1..>);
1080            
1081             $y->say(5); # 'y1 y2 y3 y4 y5'
1082            
1083             otherwise C<<< 'y' << '.' >>> will run first without overloading, which will be
1084             an error. since that is a bit awkward, where you can specify an operator string,
1085             you can prefix C< R > or C< r > to indicate that the arguments to the operator
1086             should be reversed.
1087            
1088             my $y = <1..> <<'R.'>> 'y';
1089            
1090             $y->say(5); # 'y1 y2 y3 y4 y5'
1091            
1092             just like in perl6, hyper operators are recursively defined for multi
1093             dimensional generators.
1094            
1095             say +(list(<1..>, <2..>, <3..>) >>'*'>> -1)->perl(4, '...')
1096            
1097             # [[-1, -2, -3, -4, ...], [-2, -3, -4, -5, ...], [-3, -4, -5, -6, ...]]
1098            
1099             hyper operators currently do not work with mutable generators. this will be
1100             addressed in a future update.
1101            
1102             you can also specify the operator in a hyper-operator as a typeglob:
1103            
1104             my $xs = <1..> >>*.>> 'x'; # *. is equivalent to '.'
1105            
1106             $xs->say(5); # 1x 2x 3x 4x 5x
1107            
1108             my $negs = <0..> >>*-; # same as: <0..> >>'-'
1109            
1110             $negs->say(5); # 0 -1 -2 -3 -4
1111            
1112             hyper also works as a method:
1113            
1114             <1..>->hyper('<<.>>', 'x')->say(5); # '1x 2x 3x 4x 5x'
1115             # defaults to '<<...>>'
1116             <1..>->hyper('.', 'x')->say(5); # '1x 2x 3x 4x 5x'
1117            
1118             hyper negation can be done directly with the prefix minus operator:
1119            
1120             -$gen ~~ $gen >>'-' ~~ $gen->hyper('-')
1121            
1122             =back
1123            
1124             =head3 mutable generators
1125            
1126             =over 4
1127            
1128             mutable generators (those returned from mutable, filter, While, Until, and
1129             iterate_multi) are generators with variable length. in addition to all normal
1130             methods, mutable generators have the following methods:
1131            
1132             $gen->when_done(sub {...}) # schedule a method to be called when the
1133             # generator is exhausted
1134             # when_done can be called multiple times to
1135             # schedule multiple end actions
1136            
1137             $gen->apply; # causes the generator to evaluate all of its elements in
1138             # order to find out its true size. it is a bad idea to call
1139             # ->apply on an infinite generator
1140            
1141             due to the way perl processes list operations, when perl sees an expression
1142             like:
1143            
1144             print "@$gen\n"; # or
1145             print join ' ' => @$gen;
1146            
1147             it calls the internal C< FETCHSIZE > method only once, before it starts getting
1148             elements from the array. this is fine for immutable generators. however, since
1149             mutable generators do not know their true size, perl will think the array is
1150             bigger than it really is, and will most likely run off the end of the list,
1151             returning many undefined elements, or throwing an exception.
1152            
1153             the solution to this is to call C<< $gen->apply >> first, or to use the
1154             C<< $gen->all >> method with mutable generators instead of C< @$gen >, since
1155             the C<< ->all >> method understands how to deal with arrays that can change size
1156             while being read.
1157            
1158             perl's C< for/foreach > loop is a bit smarter, so just like immutable
1159             generators, the mutable ones can be dereferenced as the loop argument with no
1160             problem:
1161            
1162             ... foreach @$mutable_generator; # works fine
1163            
1164             =back
1165            
1166             =head3 stream generators
1167            
1168             =over 4
1169            
1170             the generators C, C, and C (all of its flavors) have
1171             internal caches that allow random access within the generator. some algorithms
1172             only need monotonically increasing access to the generator (all access via
1173             repeated calls to C<< $gen->next >> for example), and the cache could become a
1174             performance/memory problem.
1175            
1176             the C< *_stream > family of generators do not maintain an internal cache, and
1177             are subsequently unable to fulfill requests for indicies lower than or equal to
1178             the last accessed index. they will however be faster and use less memory than
1179             their non-stream counterparts when monotonically increasing access is all that
1180             an algorithm needs.
1181            
1182             stream generators can be thought of as traditional subroutine iterators that
1183             also have generator methods. it is up to you to ensure that all operations and
1184             methods follow the monotonically increasing index rule. you can determine the
1185             current position of the stream iterator with the C<< $gen->index >> method.
1186            
1187             my $nums = iterate_stream{2*$_}->from(1);
1188            
1189             say $nums->(); # 1
1190             say $nums->(); # 2
1191             say $nums->(); # 4
1192             say $nums->index; # 3
1193             say $nums->drop( $nums->index )->str(5); # '8 16 32 64 128'
1194             say $nums->index; # 8
1195            
1196             the C<< $gen->drop( $gen->index )->method >> pattern can be shortened to
1197             C<< $gen->idx->method >>
1198            
1199             say $nums->idx->str(5); # '256 512 1024 2048 4096'
1200            
1201             the C<< $gen->index >> method of stream generators is read only. calling
1202             C<< $gen->reset >> on a stream generator will throw an error.
1203            
1204             stream generators are experimental and may change in future versions.
1205            
1206             =back
1207            
1208             =head3 threads
1209            
1210             =over 4
1211            
1212             generators have the following multithreaded methods:
1213            
1214             $gen->threads_blocksize(3) # sets size to divide work into
1215             $gen->threads_cached; # implements a threads::shared cache
1216             $gen->threads_cached(10) # as normal, then calls threads_start with arg
1217            
1218             $gen->threads_start; # creates 4 worker threads
1219             $gen->threads_start(2); # or however many you want
1220             # if you don't call it, threads_slice will
1221            
1222             my @list = $gen->threads_slice(0 .. 1000); # sends work to the threads
1223             my @list = $gen->threads_all;
1224            
1225             $gen->threads_stop; # or let the generator fall out of scope
1226            
1227             all threads are local to a particular generator, they are not shared.
1228             if the passed in generator was cached (at the top level) that cache is shared
1229             and used automatically. this includes most generators with implicit caches.
1230             threads_slice and threads_all can be called without starting the threads
1231             explicitly. in that case, they will start with default values.
1232            
1233             the threaded methods only work in perl versions 5.10.1 to 5.12.x, patches to
1234             support other versions are welcome.
1235            
1236             =back
1237            
1238             =cut
1239            
1240             {package
1241             List::Gen::Base;
1242             for my $sub (qw(TIEARRAY FETCH STORE STORESIZE CLEAR PUSH
1243             POP SHIFT UNSHIFT SPLICE UNTIE EXTEND)) {
1244 10     10   94 no strict 'refs';
  10         35  
  10         2063  
1245 0     0   0 *$sub = sub {Carp::confess "$sub(".(join ', ' => @_).") not supported"}
1246             }
1247 134     134   219 sub DESTROY {}
1248 130     130   560 sub source {}
1249             sub FETCHSIZE {
1250 7     7   10 my $self = shift;
1251 7         15 my $install = (ref $self).'::FETCHSIZE';
1252 7         14 my $fsize = $self->can('fsize');
1253             my $fetchsize = sub {
1254 7     7   11 my $size = $fsize->();
1255 7 50       16 $size > 2**31-1
1256             ? 2**31-1
1257             : $size
1258 7         24 };
1259 10     10   64 no strict 'refs';
  10         35  
  10         3843  
1260 7         11 my $size = $fetchsize->();
1261 14     14   36 *$install = $self->mutable
1262             ? $fetchsize
1263 7 50       40 : sub {$size};
1264 7         44 $size
1265             }
1266             sub mutable {
1267 128     128   239 my @src = shift;
1268 128         147 my %seen;
1269 128         342 while (my $src = shift @src) {
1270 172 50       603 next if $seen{$src}++;
1271 172 50       1373 return 1 if $src->isa('List::Gen::Mutable');
1272 172 100       660 if (my $source = $src->source) {
1273 42 100       189 push @src, ref $source eq 'ARRAY' ? @$source : $source
1274             }
1275             }
1276             ''
1277 128         599 }
1278             sub sources {
1279 0     0   0 my $self = shift;
1280 0 0       0 my $src = $self->source or return;
1281 0 0       0 if (ref $src eq 'ARRAY')
  0         0  
1282 0         0 {@$src, map $_->sources, @$src}
1283             else {$src, $src->sources}
1284             }
1285            
1286             sub tail_size {
1287 0     0   0 $_[1] = List::Gen::TailSize->new($_[0]->can('fsize'))
1288             }
1289             {package
1290             List::Gen::TailSize;
1291 0     0   0 sub new {bless [pop]}
1292 0     0   0 use overload fallback => 1, '0+' => sub {&{$_[0][0]}}
  0         0  
1293 10     10   59 }
  10         19  
  10         188  
1294            
1295             sub closures {
1296 176 50 33     1518 map {
      33        
1297 88     88   137 Scalar::Util::reftype($_[0]) eq 'HASH' && $_[0]{$_}
1298             or $_[0]->can($_)
1299             or Carp::confess("no $_ on $_[0]")
1300             } qw (FETCH fsize)
1301             }
1302             }
1303            
1304             my $op2cv = do {
1305             my %unary_only = map {$_ => 1} qw (! \ ~);
1306             my %unary_ok = map {$_ => 1} qw (+ - not);
1307             sub {
1308             my $op = shift;
1309             my $src = $unary_only{$op} ? "sub {\@_ ? $op \$_[0] : $op \$_}"
1310             : 'sub ($$) {'.
1311             ($unary_ok{$op} ? "
1312             if (\@_ == 0) {return ($op \$_)}
1313             if (\@_ == 1) {return ($op \$_[0])}
1314             " : "
1315             if (\@_ == 0) {return (\$a $op \$b)}
1316             if (\@_ == 1) {Carp::croak(q(too few arguments for '$op'))}
1317             ") ."
1318             if (\@_ == 2) {return (\$_[0] $op \$_[1])}
1319             reduce {\$a $op \$b} \@_
1320             }";
1321             eval $src or die "$@\n$src"
1322             }
1323             };
1324             my %ops = map {$_ => $_->$op2cv} qw (
1325             + - / * ** x % . & | ^ < > << >> <=> cmp lt gt eq ne le ge == != <= >=
1326             and or xor && || =~ !~
1327             ! \ ~
1328             );
1329             my $ops = join '|' =>
1330             map {('\b' x /^\w/).(quotemeta).('\b' x /\w$/)}
1331             sort {length $b <=> length $a}
1332             grep {$_ ne '\\'}
1333             keys %ops, ',';
1334            
1335             $ops{','} = my $comma = sub ($$) {$_[0], $_[1]};
1336             $ops{'R,'} =
1337             $ops{'r,'} = my $rcomma = sub ($$) {$_[1], $_[0]};
1338             $ops{even} = sub ($) { not + (@_ ? $_[0] : $_) % 2};
1339             $ops{odd} = sub ($) { (@_ ? $_[0] : $_) % 2};
1340             $ops{defined} = sub ($) {defined (@_ ? $_[0] : $_)};
1341             $ops{true} = sub ($) {not not @_ ? $_[0] : $_};
1342             $ops{false} = sub ($) { not @_ ? $_[0] : $_};
1343             $ops{reverse} = sub ($) {scalar reverse (@_ ? $_[0] : $_)};
1344             $ops{say} = sub ($) {print @_ ? @_ : $_, $/; @_ ? @_[0..$#_] : $_};
1345            
1346             $sv2cv = sub {
1347             defined $_[0] or croak 'an undefined value can not be coerced into code';
1348             local $_ = $_[0];
1349             return $_ if ref and reftype($_) eq 'CODE';
1350             $_[0] = ($ops{$_} or do {
1351             $ops{$_} = do {
1352             if (ref eq ref qr//) {
1353             my $re = $_;
1354             sub {/$re/}
1355             }
1356             elsif (ref \$_ eq 'GLOB') {
1357             my $op = B::svref_2object(\$_)->NAME;
1358             $ops{$op} or $op->$sv2cv
1359             }
1360             elsif (ref and overload::Method($_, '&{}')) {
1361             \&{$_}
1362             }
1363             elsif ($ops{~$_}
1364             or /^[Rr]\s*($ops)\s*$/
1365             or ~$_ =~ /^\*main::($ops)$/
1366             ) {
1367             my $op = $ops{$1 ? $1 : ~$_};
1368             sub ($$) {$op->(reverse @_)}
1369             }
1370             elsif (/[\$\@]\s*_\b/) {
1371             '$_/@_'->$eval("sub (\$) {$_}")
1372             }
1373             elsif (/\$a(?:\b|$)/ and /\$b(?:\b|$)/) {
1374             # $a $b:
1375             s{\$a(?:\b(?!\s*[\[\}])|$)} '$_[0]'gx;
1376             s{\$b(?:\b(?!\s*[\[\}])|$)} '$_[1]'gx;
1377             # $a[1] $b[1]:
1378             s{(?
1379             s{(?
1380             # $$a[1] $$b[1]:
1381             s{\$a(?:\b|$)} '${\$_[0]}'gx;
1382             s{\$b(?:\b|$)} '${\$_[1]}'gx;
1383            
1384             '$a $b'->$eval('sub ($$) '."{$_}")
1385             }
1386             elsif (not m[/.+/]
1387             and /^ \s* ( ! | not\b | ) \s*
1388             (?: (.+?) \s* ($ops) | ($ops) \s* (.+?) )
1389             \s* $/x
1390             ) {
1391             my $arg = $2 ? $2 : $5;
1392             my $op = $ops{$2 ? $3 : $4};
1393             if ($1) {
1394             my $normal = $op;
1395             $op = sub {not &$normal}
1396             }
1397             $arg = 'curry'->$eval($arg) unless looks_like_number $arg;
1398             $2 ? sub ($) {$op->($arg, @_ ? $_[0] : $_)}
1399             : sub ($) {$op->(@_ ? $_[0] : $_, $arg)}
1400             }
1401             elsif (/^[a-zA-Z_][\w\s]*$/) {
1402             'bareword'->$eval("sub (\$) {$_(\$_)}")
1403             }
1404             elsif (/^ \s*(?:not|!|)\s* (?: ( [sy] | tr ) | m | (?=\s*\/) ) \s*
1405             ( [^\w\s] | (?<= \s )\w ) .* (?: \2 | [\}\)\]] )
1406             [a-z]* \s* $/x
1407             ) {
1408             $_ = '(my $x = $_) =~ '.$_.'; $x' if $1;
1409             'regex'->$eval("sub (\$) {$_}")
1410             }
1411             }
1412             } or Carp::croak "error, no dwim code type found for: '$_[0]'")
1413             };
1414            
1415             {package
1416             List::Gen::Hyper;
1417 0         0 use overload fallback => 1,
1418 0     0   0 '&{}' => sub {\&{$_[0]->self}},
1419 20         45 map {
1420 10         82 my $op = $_;
1421             $op => sub {
1422 5     5   10 my ($x, $y, $flip) = @_;
1423 5 50       20 hyper ($flip ? ($y, $op, @$x) : (@$x, $op, $y))
1424             }
1425 10     10   31897 } qw (<< >>);
  10         100  
  20         151  
1426 0     0   0 sub DESTROY {}
1427             sub AUTOLOAD {
1428 0     0   0 my ($method) = our $AUTOLOAD =~ /([^:']+)$/;
1429 0 0       0 my ($op, $gen) = @{$_[0]}[List::Gen::isagen($_[0][0]) ? (2,0) : (0,2)];
  0         0  
1430 0         0 $gen->hyper($op)->$method(@_[1..$#_])
1431             }
1432             my %cache;
1433             sub hyper {
1434 5     5   12 my ($left, $lh, $code, $rh, $right) = @_;
1435 5 50       22 $code->$sv2cv unless ref $code eq 'CODE';
1436 5         14 for ($left, $right) {
1437 10 100       17 next if &List::Gen::isagen($_);
1438 5         8 my $src = $_;
1439 5 100       13 if (ref $src eq 'ARRAY') {
1440 1         4 $_ = &List::Gen::makegen($src);
1441             } else {
1442 4     40   16 $_ = &List::Gen::gen(sub {$src}, 1);
  40         80  
1443             }
1444             }
1445 5 50 33     19 if ($left->is_mutable or $right->is_mutable) {
1446 0         0 Carp::croak('hyper operators not yet supported with mutable generators')
1447             } else {
1448 5         19 my ($lsize, $rsize) = map tied(@$_)->fsize => $left, $right;
1449             my $size =
1450             ($lh eq '<<' and $rh eq '>>') ? List::Util::max($lsize, $rsize)
1451             : $lh eq '<<' ? $rsize
1452             : $rh eq '>>' ? $lsize
1453 5 50 66     40 : do {
    50          
    100          
1454 0 0       0 Carp::croak("unequal size lists passed to non-dwimmy hyper")
1455             if $lsize != $rsize;
1456 0         0 $lsize
1457             };
1458 5 50 66     36 for my $src (($lh eq '<<' and $lsize < $size) ? $left : (),
    50 33        
1459             ($rh eq '>>' and $rsize < $size) ? $right : ()) {
1460 5         22 my $fetch = tied(@$src)->can('FETCH');
1461 5         11 my $src_size = tied(@$src)->fsize;
1462 5     50   26 $src = &List::Gen::gen(sub {$fetch->(undef, $_ % $src_size)}, $size)
  50         82  
1463             }
1464 5         445 my ($lfetch, $rfetch) = map tied(@$_)->can('FETCH') => $left, $right;
1465             $code == $comma
1466             ? &List::Gen::gen(sub {
1467 0 0   0   0 my $got = $_ % 2 ? $rfetch->(undef, int($_/2))
1468             : $lfetch->(undef, int($_/2));
1469 0 0       0 if (ref $got) {
1470 0 0 0     0 if (ref $got eq 'ARRAY' or List::Gen::isagen($got)) {
1471 0         0 Carp::croak("hyper comma not yet supported with multi-dimentional generators");
1472             #my $other = ($_ % 2 ? $lfetch : $rfetch)->(undef, int($_/2));
1473             #my ($l, $r) = $_ % 2 ? ($other, $got) : ($got, $other);
1474             #return $cache{join $; => $l, $lh, $code, $rh, $r}
1475             # ||= hyper($l, $lh, $code, $rh, $r);
1476             }
1477             }
1478             $got
1479 0         0 }, $size * 2)
1480             : &List::Gen::gen(sub {
1481 50     50   80 my $l = $lfetch->(undef, $_);
1482 50         79 my $r = $rfetch->(undef, $_);
1483 50         134 for (grep ref, $l, $r) {
1484 0 0 0     0 if (ref $_ eq 'ARRAY' or &List::Gen::isagen($_)) {
1485 0   0     0 return $cache{join $; => $l, $lh, $code, $rh, $r}
1486             ||= hyper($l, $lh, $code, $rh, $r)
1487             }
1488             }
1489 50         203 $code->($l, $r)
1490 5 50       37 }, $size)
1491             }
1492             }
1493             }
1494             {
1495             my $build; BEGIN {$build = sub {
1496 20         42 my $method = shift;
1497             sub {
1498 8     8   18 my ($self, $ys, $flip) = @_;
1499 8         22 my ($code, $xs) = @$self{qw(code xs)};
1500 8         22 $code->$sv2cv;
1501 8 50       18 ($xs, $ys) = ($ys, $xs) if $flip;
1502 8         19 for ($xs, $ys) {
1503 16 50       30 next if isagen(my $x = $_);
1504 0 0 0     0 $_ = ref && reftype($_) eq 'ARRAY'
    0          
1505             ? &makegen($_)
1506             : $method eq 'zip'
1507             ? &repeat($x)
1508             : &list($x)
1509             }
1510 8         31 $xs->$method($code, $ys)
1511             }
1512 10     10   15656 }}
  20         185  
1513             package
1514             List::Gen::xWith;
1515             my $end = qr/([^:]+)$/;
1516             sub AUTOLOAD {
1517 0     0   0 my ($self) = $_[0];
1518 0         0 my ($xWith) = map lc, ref($self) =~ $end;
1519 0         0 my ($method) = our $AUTOLOAD =~ $end;
1520 0         0 my ($xs, $ys) = @$self{qw(xs ys)};
1521 0 0       0 unless ($ys->$isagen) {
1522 0         0 my $y = $ys;
1523 0 0       0 $ys = $xWith eq 'zip' ? &List::Gen::repeat($y)
1524             : &List::Gen::list($y)
1525             }
1526 0 0       0 ($xs, $ys) = ($ys, $xs) if $$self{flip};
1527            
1528 0         0 $_[0] = $xs->$xWith($ys);
1529            
1530 0 0       0 goto &{$_[0]->can($method)
  0         0  
1531             or Carp::croak "no method '$method' on $_[0]"}
1532             }
1533 0     0   0 sub DESTROY {}
1534             package
1535             List::Gen::xWith::Cross;
1536             our @ISA = 'List::Gen::xWith';
1537 10     10   69 use overload fallback => 1, 'x' => $build->('cross');
  10         20  
  10         38  
1538             package
1539             List::Gen::xWith::Zip;
1540             our @ISA = 'List::Gen::xWith';
1541 10     10   1194 use overload fallback => 1, '|' => $build->('zip');
  10         21  
  10         38  
1542             }
1543             {package
1544             List::Gen::erator;
1545             List::Gen::DEBUG or $Carp::Internal{ (__PACKAGE__) }++;
1546 2     2   18 use overload fallback => 1,
1547             '&{}' => sub {$_[0]->_overloader},
1548 0     0   0 '<>' => sub {$_[0]->_overloader; $_[0]->next},
  0         0  
1549 20         185 'cross: zip:<|>'->${\sub {map {
1550 10         47 my ($method, $op) = /(.+):<(.)>/;
1551 20         68 my $package = 'List::Gen::xWith::'.ucfirst $method;
1552 20         41 my $method_with = $method.'with';
1553             $op => sub {
1554 11     11   28 my ($xs, $ys, $flip) = @_;
1555 11         16 my $ys_save = $ys;
1556 11 50       34 if (ref \$ys eq 'GLOB') {
1557 0         0 $ys = B::svref_2object(\$ys)->NAME
1558             }
1559 11 100       38 $ys = $ops{$ys} if $ops{$ys};
1560 11 100 100     54 if (not ref $ys or ref $ys eq 'CODE') {
1561 8         75 return bless {
1562             flip => $flip,
1563             code => $ys,
1564             ys => $ys_save,
1565             xs => $xs,
1566             } => $package
1567             }
1568 3 50       11 if (ref $ys eq $package) {
1569 0         0 (my $code, $ys) = @$ys{qw(code xs)};
1570 0         0 $code->$sv2cv;
1571 0 0       0 ($xs, $ys) = ($ys, $xs) if $flip;
1572 0 0       0 return $code == $comma
1573             ? $xs->$method($ys)
1574             : $xs->$method_with($code, $ys)
1575             }
1576            
1577 3 100       11 if (ref $ys eq 'ARRAY') {
1578 1         4 $ys = &List::Gen::makegen($ys)
1579             }
1580            
1581 3         13 for ([xs => $xs], [ys => $ys]) {
1582 6         10 my ($n, $s) = @$_;
1583 6 50       22 if ($s->type =~ /List::Gen::(Zip)/) {
1584 0         0 my $type = lc $1;
1585 0 0       0 if ($type eq $method) {
1586 0         0 my $src = tied(@$s)->source;
1587 0 0       0 my $other = $n eq 'xs' ? $ys : $xs;
1588 0         0 my @other = $other->type =~ /List::Gen::$type/i
1589 0 0       0 ? @{tied(@$other)->source}
1590             : tied @$other;
1591 0 0       0 return List::Gen::tiegen(
1592             ucfirst $type =>
1593             $n eq 'ys' ? (@other, @$src)
1594             : (@$src, @other)
1595             )
1596             }
1597             }
1598             }
1599 3 50       14 ($xs, $ys) = ($ys, $xs) if $flip;
1600 3         19 $xs->$method($ys)
1601             }
1602 10         130 } split /\s+/, shift}},
  20         213  
1603             '+' => sub {
1604 0     0   0 my ($x, $y, $flip) = @_;
1605 0 0       0 ($x, $y) = ($y, $x) if $flip;
1606 0         0 List::Gen::sequence($x, $y);
1607             },
1608 30         88 (map {
1609             (my $op = $_) =~ s/neg/-/;
1610 0     0   0 $_ => sub {$_[0]->hyper($op)}
1611 30         183 } qw (neg ! ~)),
1612 10         78 do {
1613 120         315 my %unary = map {
1614 10         1070 (my $op = $_) =~ s/^u//i;
1615 120   50     12550 $_ => (eval (m/(..)(.)/?"sub {$1\$_[0]$2}":"sub {$op \$_[0]}") or die $@)
1616             } qw (! ~ \ @{} ${} %{} &{} *{} U- U+ u- u+);
1617 20         30 map {
1618 10         46 my $op = $_;
1619             $op => sub {
1620 5     5   14 my ($x, $y, $flip) = @_;
1621 5 50       15 if (my $code = $unary{$y}) {
1622 0         0 return $x->hyper($code);
1623             }
1624 5 50       14 ($x, $y) = ($y, $x) if $flip;
1625 5         66 bless [$x, $op, $y] => 'List::Gen::Hyper';
1626             }
1627 20         140 } qw (<< >>)
1628 10     10   11806 };
  10         22  
1629            
1630             #END {defined &$_ and print "$_\n"
1631             # for sort {lc $a cmp lc $b} keys %List::Gen::erator::}
1632             my $l2g = \&List::Gen::list;
1633            
1634             sub new {
1635 129 50   129   248 goto &_new if $STRICT;
1636 129         855 bless $_[1] => 'List::Gen::era::tor'}
1637             {package
1638             List::Gen::era::tor;
1639             our @ISA = 'List::Gen::erator';
1640             my $force = sub {List::Gen::erator->_new($_[0])};
1641            
1642             tie my @by, 'List::Gen::By', 2, [1..10];
1643             my $by = List::Gen::erator->_new(\@by);
1644 10     10   3826 no strict 'refs';
  10         20  
  10         19495  
1645             for my $proxy (grep /[a-z]/, keys %{ref($by).'::'}) {
1646 0     0   0 *$proxy = $proxy eq 'index'
1647             ? sub :lvalue {&$force->index}
1648 42     42   50 : sub {goto & {&$force->can($proxy)}}
  42         73  
1649             }
1650 0     0   0 sub DESTROY {}
1651             }
1652             {
1653             my %code_ok = map {ref, 1} sub {}, qr {};
1654             my $croak_msg = 'not supported in dwim generator code dereference';
1655             sub _new {
1656             package List::Gen;
1657 52     52   100 my ($class, $gen) = @_;
1658 52         80 my $src = tied @$gen;
1659 52         188 weaken $gen;
1660 52         412 my ($fetch, $fsize) = $src->closures;
1661 52   50 52   733 my $index = ($src->can('index') or sub {0})->();
  52         106  
1662 52         174 my $size = $fsize->();
1663 52         231 my $mutable = $src->mutable;
1664 52 100       133 if($mutable) {
1665 2         6 $src->tail_size($size)
1666             }
1667 52         84 my $dwim_code_strings = $DWIM_CODE_STRINGS;
1668             my $overload = sub {
1669 36 50   36   96 if (@_ == 0) {
    50          
1670 0 0       0 ref $index
    0          
    0          
1671             ? $$index < $size ? $fetch->(undef, $$index ) : ()
1672             : $index < $size ? $fetch->(undef, $index++) : ()
1673             }
1674 0         0 elsif (@_ == 1) {
1675 36 50       63 if (looks_like_number($_[0])) {$fetch->(undef, $_[0])}
  36 0       79  
    0          
    0          
1676 0         0 elsif (ref $_[0]) {
1677 0 0 0     0 if (isagen($_[0])) {slice($gen, $_[0])}
  0 0 0     0  
    0 0        
1678 0         0 elsif ($code_ok{ref $_[0]}) {
1679 0         0 $gen->map($_[0])
1680             }
1681             elsif (ref $_[0] eq 'REF' && $code_ok{ref ${$_[0]}}
1682             or $dwim_code_strings && ref $_[0] eq 'SCALAR'
1683 0         0 ) {
1684 0         0 $gen->grep(${$_[0]})
  0         0  
1685             }
1686             else {croak "reference '$_[0]' $croak_msg"}
1687             }
1688             elsif (canglob($_[0])) {slice($gen, $_[0])}
1689 0         0 elsif ($dwim_code_strings) { $gen->map ($_[0])}
  0         0  
1690             else {croak "value '$_[0]' $croak_msg"}
1691             }
1692 0         0 else {unshift @_, $gen; goto &{$gen->can('slice')}}
  0         0  
1693 52         285 };
1694             curse {
1695             -bless => $gen,
1696             _overloader => sub {
1697 2 50   2   4 eval qq {
  1     1   11  
  1     1   3  
  1         12  
  17         142  
  1         7  
  1         2  
  1         8  
  17         171  
1698 2         325 package @{[ref $_[0]]};
1699             use overload fallback => 1, '&{}' => sub {\$overload},
1700             '<>' => \\&next;
1701             local *DESTROY;
1702             bless []; 1
1703             } or croak "overloading failed: $@";
1704 2         6 $overload
1705             },
1706 3     3   4 size => $fsize,
1707             get => $fetch,
1708             slice => sub {shift;
1709 3 0 0     10 @_ == 1 and (isagen($_[0]) or canglob($_[0]))
      33        
1710             and return slice($gen, $_[0]);
1711 3 50       5 if ($mutable) {
1712 0         0 my @ret;
1713 0         0 for my $i (@_) {
1714 0 0       0 $i < $size or next;
1715 0         0 my @x = \($fetch->(undef, $i));
1716 0 0       0 $i < $size or next;
1717 0         0 push @ret, @x;
1718             }
1719 0 0       0 wantarray ? map $$_ => @ret
1720             : $l2g->(map $$_ => @ret)
1721             }
1722             else {
1723 3 50       10 wantarray ? map $fetch->(undef, $_) => @_
1724             : $l2g->(map $fetch->(undef, $_) => @_)
1725             }
1726             },
1727 0     0   0 index => ref $index ? sub {$$index} : sub :lvalue {$index},
  0         0  
1728 0     0   0 more => ref $index ? sub {$$index < $size} : sub {$index < $size},
  0         0  
1729 0 0   0   0 next => ref $index
1730             ? sub {$$index < $size ? $fetch->(undef, $$index ) : ()}
1731 0 0   0   0 : sub { $index < $size ? $fetch->(undef, $index++) : ()},
1732 52 50       1106 } => $class
    50          
    50          
1733             }
1734             }
1735             sub reset {
1736 0 0   0   0 tied(@{$_[0]})->can('index')
  0         0  
1737             and Carp::croak "can not call ->reset on stream generator";
1738            
1739 0   0     0 $_[0]->index = $_[1] || 0; $_[0]
  0         0  
1740             }
1741            
1742             sub all {
1743 20     20   25 my $gen = shift;
1744 20         34 my $src = tied @$gen;
1745 20         47 my $size = $src->fsize;
1746 20         117 my $mutable = $src->mutable;
1747            
1748 20 0 33     93 $mutable or $size < 2**31
    50          
1749             or Carp::confess "can't call ->all on ",
1750             $size < 9**9**9
1751             ? 'generator larger than 2**31, use iteration instead'
1752             : 'infinite generator';
1753            
1754 20 50       353 if (my $cap = $src->can('capture')) {
    50          
1755 0         0 @{ $cap->() }
  0         0  
1756             }
1757             elsif (my $range = $src->can('range')) {
1758 0         0 my ($low, $step, $size) = $range->();
1759 0         0 map $low + $step * $_ => 0 .. $size - 1
1760             }
1761             else {
1762 20         48 my $fetch = $src->can('FETCH');
1763 20 50       40 if ($mutable) {
1764 0         0 my ($i, @ret) = 0;
1765 0         0 $src->tail_size($size);
1766 0         0 while ($i < $size) {
1767 0         0 my @got = \($fetch->(undef, $i));
1768 0 0       0 last unless $i++ < $size;
1769 0         0 push @ret, @got
1770             }
1771 0         0 map $$_ => @ret
1772             }
1773             else {
1774 20         73 map $fetch->(undef, $_) => 0 .. $size - 1
1775             }
1776             }
1777             }
1778 10     10   6582 BEGIN {*list = *all}
1779            
1780             {my $inf;
1781             sub hyper {
1782 0 0   0   0 if (@_ == 2) {
1783 0   0     0 $inf ||= &List::Gen::range(0, 9**9**9);
1784 0         0 my $code = $_[1];
1785 0 0 0     0 unless ((ref($code)||'') eq 'CODE') {
1786 0 0       0 if (ref \$code eq 'GLOB') {
1787 0         0 ($code) = $code =~ /([^:]+)$/
1788             } else {
1789 0         0 $code =~ s/^\s*(?:<<|>>)\s*(.+?)\s*$/$1/
1790             }
1791 0 0       0 $code =~ /[~!-\\]/ or Carp::croak 'arg 1 to ->hyper(str) must match /(<<|>>)?[~!-\]/';
1792 0         0 $code = 'hyper'->$eval("sub {$code \$_[0]}")
1793             }
1794 0         0 return $_[0]->hyper('>>', $code, '>>', $inf)
1795             }
1796 0 0       0 if (@_ == 3) {
1797 0 0 0     0 if (ref \$_[1] eq 'GLOB' or $_[1] =~ /^(?:<>?|>=|<=|[^<>]+)$/) {
1798 0         0 return List::Gen::Hyper::hyper (
1799             $_[0], '<<', $_[1], '>>', $_[2]
1800             )
1801             }
1802 0 0       0 if ($_[1] =~ /^\s*(<>?)?\s*(\S+?)\s*(<>?)?\s*$/) {
1803            
1804 0 0       0 return List::Gen::Hyper::hyper (
    0          
    0          
    0          
1805             $_[0],
1806             $1 ? (length $1 == 1 ? $1.$1 : $1) : '<<',
1807             $2,
1808             $3 ? (length $3 == 1 ? $3.$3 : $3) : '>>',
1809             $_[2]
1810             )
1811             }
1812 0         0 Carp::croak "arg 1 to ->hyper(str, val) must match (<<|>>)op(<<|>>)";
1813             }
1814 0 0       0 goto &List::Gen::Hyper::hyper if @_ == 5;
1815 0         0 Carp::croak q{takes 1 `->hyper('-')` or 2 `->hyper('<<+>>', 1)` }.
1816             q{or 4 `->hyper(qw(<< + >>), 1)` args, not }.$#_
1817             }}
1818            
1819             for my $proxy (qw(apply purge rewind)) {
1820 10     10   250 no strict 'refs';
  10         26  
  10         5166  
1821             *$proxy = sub {
1822 0     0   0 my @src;
1823 0         0 my @todo = tied @{$_[0]};
  0         0  
1824 0         0 while (my $next = shift @todo) {
1825 0         0 unshift @src, $next;
1826 0 0       0 next if ref($next) =~ /^List::Gen::While/;
1827 0 0       0 if (my $source = $next->source) {
1828 0 0       0 unshift @todo, ref $source eq 'ARRAY'
1829             ? @$source
1830             : $source
1831             }
1832             }
1833 0   0     0 ($_->can($proxy) or next)->($_) for @src;
1834 0         0 $_[0]
1835             }
1836             }
1837            
1838 0     0   0 sub is_inf {$_[0]->size >= 9**9**9}
1839 0     0   0 sub x_xs {$_[0]->head, $_[0]->tail}
1840 0     0   0 sub idx {$_[0]->drop( $_[0]->index + 0 )}
1841            
1842             sub tee {
1843 0     0   0 my @ret;
1844 0         0 for (shift) {
1845 0         0 for my $code (@_)
  0         0  
1846             {push @ret, $code->()}}
1847             wantarray
1848             ? @ret
1849 0 0       0 : @ret > 1
    0          
1850             ? &List::Gen::makegen(\@ret)
1851             : pop @ret
1852             }
1853            
1854             BEGIN {
1855 10     10   35 *from_index = *idx;
1856 0     0   0 *s = *self = *scalar = sub {$_[0]}
1857 10         5773 }
1858            
1859 6     6   8 sub type {(my $t = ref tied @{$_[0]}) =~ s/::_\d+$//; $t}
  6         37  
  6         26  
1860            
1861 0     0   0 sub elems {$_[0]->size}
1862 0     0   0 sub end {$_[0]->apply->size - 1}
1863            
1864             {package
1865             List::Gen::DwimCode;
1866             my %save;
1867             sub new {
1868 0     0   0 my ($class, $gen) = @_;
1869 0         0 my $code = \&$gen;
1870 0         0 bless $code => $class;
1871 0         0 $save{$code} = $gen;
1872 0         0 $code
1873             }
1874             sub DESTROY {
1875 0     0   0 delete $save{$_[0]}
1876             }
1877             }
1878 0     0   0 sub code {List::Gen::DwimCode->new($_[0])}
1879            
1880             sub size_from {
1881 0     0   0 List::Gen::tiegen(Size_From => map tied @$_ => @_)
1882             }
1883             List::Gen::generator Size_From => sub {
1884 0     0   0 my ($class, $self, $from) = @_;
1885 0     0   0 List::Gen::curse {
1886             fsize => $from->can('fsize'),
1887             FETCH => $self->can('FETCH'),
1888             source => sub {[$self, $from]},
1889 0 0   0   0 $from->mutable ? (mutable => sub {1}) : ()
  0         0  
1890             } => $class
1891             };
1892            
1893 0     0   0 sub defined {$_[0]->grep('defined')}
1894            
1895 0     0   0 sub iterator {$_[0]->index; $_[0]->can('next')}
  0         0  
1896 10     10   622 BEGIN {*iter = *iterator}
1897            
1898 0     0   0 sub range {&List::Gen::range(0, $_[0]->size - 1)}
1899 10     10   100 {no warnings 'once';
  10         20  
  10         4509  
1900 0 0   0   0 *keys = sub {wantarray ? $_[0]->range->all : $_[0]->range};
1901 0 0   0   0 *values = sub {wantarray ? $_[0]->all : $_[0]};
1902             }
1903 0     0   0 sub kv {&List::Gen::zip($_[0]->range, $_[0])}
1904 0     0   0 sub tuples {&List::Gen::tuples}
1905 0     0   0 sub pairs {$_[0]->range->tuples($_[0])}
1906            
1907             sub sort {
1908 0     0   0 my $self = shift;
1909 0 0       0 @_ == 2 and return $self->wrapsort(@_);
1910             @_ == 0
1911             ? wantarray ? sort $self->all
1912             : $l2g->(sort $self->all)
1913 0 0       0 : do {
    0          
1914 0         0 my $code = pop;
1915 0         0 $code->$sv2cv;
1916 0         0 my ($ca, $cb) = $code->$cv_ab_ref;
1917 0         0 local (*$ca, *$cb) = (*a, *b);
1918 0 0       0 wantarray ? sort $code $self->all
1919             : $l2g->(sort $code $self->all)
1920             }
1921             }
1922             {package
1923             List::Gen::Wrap;
1924 10     10   60 use overload fallback => 1, '""' => sub {$_[0][1]};
  10     0   16  
  10         137  
  0         0  
1925             }
1926             sub wrap {
1927 0     0   0 my ($gen, $code) = splice @_;
1928 0         0 $code->$sv2cv;
1929 0         0 $l2g->(map {bless [$_ => &$code] => 'List::Gen::Wrap'} $gen->all)
  0         0  
1930             }
1931             sub unwrap {
1932 0 0   0   0 wantarray ? map $$_[0], $_[0]->all
1933             : $l2g->(map $$_[0], $_[0]->all)
1934             }
1935             sub wrapsort {
1936 0     0   0 my ($gen, $code, @by) = @_;
1937 0         0 $gen->wrap($code)->sort(@by)->unwrap
1938             }
1939 10     10   6352 BEGIN {*wsort = *wrapsort}
1940            
1941             sub perl {
1942 0     0   0 my $src = shift;
1943 0 0       0 '[' .(join ', ' => map {
    0          
    0          
    0          
1944 0 0 0     0 ref $_
    0 0        
    0          
1945             ? &List::Gen::isagen($_)
1946             ? $_->perl(@_)
1947             : ref eq 'ARRAY'
1948             ? &List::Gen::makegen($_)->perl(@_)
1949             : "'$_'"
1950             : /^-?\d+(?:\.\d+)?$/
1951             ? $_
1952             : "'$_'"
1953             } (@_ and $_[0] < 9**9**9)
1954             ? $src->size <= $_[0]
1955             ? $src->all
1956             : $src->slice(0 .. $_[0] - 1)
1957             : $src->all
1958             ).((@_ == 2 and $_[0] < $src->size) ? ", $_[1]" : ''). ']'
1959             }
1960             sub str {
1961 23     23   37 my $src = shift;
1962 23 50       99 join defined $" ? $" : '' => $src->flat(@_)
1963             }
1964 10     10   60 {no warnings 'once';
  10         16  
  10         28556  
1965             *join = sub {
1966 0 0   0   0 join @_ > 1 ? $_[1] : '',
    0          
1967             @_ > 2 ? $_[0]->take($_[2])->all : $_[0]->all,
1968             @_[3 .. $#_]
1969             }}
1970             sub flat {
1971 23     23   33 my $src = shift;
1972 204 0       521 map {
    0          
    50          
1973 23 50 66     123 ref $_
    50          
    100          
1974             ? &List::Gen::isagen($_)
1975             ? $_->flat(@_)
1976             : ref eq 'ARRAY'
1977             ? &List::Gen::makegen($_)->flat(@_)
1978             : $_
1979             : $_
1980             } (@_ and $_[0] < 9**9**9)
1981             ? $src->size <= $_[0]
1982             ? $src->all
1983             : ($src->slice(0 .. $_[0] - 1), @_ == 2 ? $_[1] : ())
1984             : $src->all
1985             }
1986             sub say {
1987 0     0   0 local $\ = "\n";
1988 0         0 &print
1989             }
1990            
1991             sub print {
1992 0     0   0 my $src = shift;
1993 0 0 0     0 if (@_ and Scalar::Util::openhandle($_[0])) {
  0         0  
1994 0         0 my $fh = shift;
1995 0         0 print $fh $src->str(@_)
1996             }
1997             else {print $src->str(@_)}
1998 0         0 $src
1999             }
2000             sub dump {
2001 0     0   0 local *flat = *perl;
2002 0         0 &say
2003             }
2004             {my $bool = sub {$_[0] ? 'yes' : 'no'};
2005             sub debug {
2006 0     0   0 my ($gen, $num) = (@_, 10);
2007 0 0       0 my ($max) = map {$_ >= 9**9**9 ? 'inf' : $_} $gen->size - 1;
  0         0  
2008 0         0 my $stream = tied(@$gen)->can('index');
2009 0 0       0 my $perl = !$num ? ''
    0          
    0          
2010             : ($stream ? 'from '.$gen->index.': ' : '')
2011             . ($stream ? $gen->idx : $gen)->perl($num, '...');
2012            
2013 0 0       0 Carp::carp join '' => map {
2014 0         0 sprintf "%-8s %s\n", "$$_[0]:",
2015             $#$_ > 0 ? join ', ' => @$_[1 .. $#$_] : 'none'
2016             } [debug => $gen],
2017             [type => $gen->type],
2018 0 0       0 [source => map {ref =~ /(.+)::/} tied(@$gen)->sources],
2019             [mutable => $bool->($gen->is_mutable)],
2020             [stream => $bool->($stream)],
2021             [range => "[0 .. $max]"],
2022             [index => $gen->index],
2023             $perl ? [perl => $perl] :();
2024 0         0 $gen
2025             }}
2026            
2027             sub watch {
2028 0     0   0 my ($gen, $fh) = shift;
2029 0   0     0 my $msg = join ' ', grep {
2030 0         0 not (Scalar::Util::openhandle $_ and $fh = $_)
2031             } @_;
2032 0 0       0 $msg .= ': ' if $msg =~ /^\w+$/;
2033             &List::Gen::gen(sub {
2034 0 0   0   0 defined $\ or local $\ = $/;
2035 0 0       0 $fh ? print $fh $msg, $_
2036             : print $msg, $_;
2037 0         0 $_
2038 0         0 }, $gen)
2039             }
2040            
2041             sub pick {
2042 0     0   0 my ($self, $n) = (@_, 1);
2043 0 0 0     0 if ($n == 1 and not $self->is_mutable) {
2044 0         0 my $size = $self->size;
2045 0 0       0 $self->get(int rand ($size >= 9**9**9 ? $MAX_IDX : $size))
2046             } else {
2047 0         0 my $pick = $self->shuffle->take($n);
2048 0 0       0 wantarray ? $pick->all : $pick
2049             }
2050             }
2051             my $wantgen = sub {wantarray ? @_ : &List::Gen::makegen(\@_)};
2052             sub roll {
2053 0     0   0 my ($self, $n) = (@_, 1);
2054 0 0       0 $n > 1 ? $wantgen->(map $self->pick, 1 .. $n) : $self->pick
2055             }
2056            
2057             sub random {
2058 0     0   0 my $self = shift;
2059 0         0 my $size = $self->size;
2060 0         0 my $fetch = tied(@$self)->can('FETCH');
2061 0         0 my %map;
2062 0 0       0 $self->tail_size($size) if $self->is_mutable;
2063 0 0       0 &List::Gen::gen(sub {{
2064 0     0   0 return $fetch->(undef, $map{$_}) if exists $map{$_};
2065 0 0       0 my $i = int rand ($size >= 9**9**9 ? $MAX_IDX : $size);
2066 0         0 my $x = $fetch->(undef, $i);
2067 0 0       0 redo unless $i < $size;
2068 0         0 $map{$_} = $i;
2069 0         0 $x
2070             }})
2071 0         0 }
2072             sub shuffle {
2073 0     0   0 my $src = shift;
2074 0         0 my $size = $src->size;
2075 0         0 my $fetch = tied(@$src)->can('FETCH');
2076 0         0 my (%seen, %map);
2077 0 0       0 $src->tail_size($size) if $src->is_mutable;
2078             &List::Gen::gen(sub {
2079 0 0   0   0 return $fetch->(undef, $map{$_}) if exists $map{$_};
2080 0         0 while (keys %seen < $size) {
2081 0 0       0 my $i = int rand ($size >= 9**9**9 ? $MAX_IDX : $size);
2082 0         0 my $start = $i;
2083 0   0     0 $i++ while $i < $size-1 and $seen{$i};
2084 0 0       0 $i = $start if $seen{$i};
2085 0   0     0 $i-- while $i > 0 and $seen{$i};
2086 0 0       0 $seen{$i}++ or return $fetch->(undef, $map{$_} = $i)
2087             }
2088 0         0 })->size_from($src)
2089             }
2090            
2091             sub uniq {
2092 0     0   0 my %seen;
2093 0     0   0 &List::Gen::filter(sub {not $seen{$_}++}, $_[0])
  0         0  
2094             }
2095            
2096             our $first_idx;
2097             sub first {
2098 0 0   0   0 return $_[0]->get(0) if @_ == 1;
2099 0         0 my ($self, $code) = @_;
2100 0         0 $code->$sv2cv;
2101 0         0 my $fetch = tied(@$self)->can('FETCH');
2102 0         0 my $i = 0;
2103 0         0 local @_;
2104 0         0 local *_ = \undef;
2105 0         0 my $size = $self->size;
2106 0 0       0 if ($self->is_mutable) {
2107 0         0 $self->tail_size($size);
2108 0         0 while ($i < $size) {
2109 0         0 *_ = \$fetch->(undef, $i);
2110 0 0       0 return if $i >= $size;
2111 0 0       0 return $first_idx ? $i : $_ if &$code;
    0          
2112 0         0 $i++;
2113             }
2114             } else {
2115 0         0 while ($i < $size) {
2116 0         0 *_ = \$fetch->(undef, $i);
2117 0 0       0 return $first_idx ? $i : $_ if &$code;
    0          
2118 0         0 $i++;
2119             }
2120             }
2121             return
2122 0         0 }
2123             sub last {
2124 0 0   0   0 @_ == 1 ? $_[0]->get( $_[0]->apply->size-1 )
2125             : $_[0]->reverse->first($_[1])
2126             }
2127            
2128             sub first_idx {
2129 0     0   0 local $first_idx = 1;
2130 0         0 &first
2131             }
2132             sub last_idx {
2133 0     0   0 local $first_idx = 1;
2134 0         0 &last
2135             }
2136             BEGIN {
2137 10     10   36 *firstidx = *first_idx;
2138 10         47036 *lastidx = *last_idx;
2139             }
2140            
2141             sub deref {
2142 0     0   0 List::Gen::tiegen(Deref => @_)
2143             }
2144             List::Gen::generator Deref => sub {
2145 0     0   0 my ($class, $gen, $mod) = @_;
2146 0         0 my ($src, $pos) = (tied @$gen, -1);
2147 0         0 my ($fetch, $fsize) = $src->closures;
2148 0         0 my ($ref, $i);
2149 0   0     0 $mod ||= @{$ref = $fetch->(undef, $pos = 0)};
  0         0  
2150 0         0 my $size = $fsize->();
2151             List::Gen::curse {
2152             FETCH => sub {
2153 0     0   0 $i = int ($_[1] / $mod);
2154 0 0       0 $ref = $fetch->(undef, $pos = $i) if $i != $pos;
2155 0         0 $$ref[ $_[1] % $mod ]
2156             },
2157 0         0 fsize => $src->mutable ? do {
2158 0         0 $src->tail_size($size);
2159 0     0   0 sub {$size * $mod}
2160 0         0 }
2161 0     0   0 : do {$size *= $mod; sub {$size}},
  0         0  
  0         0  
2162             source => sub {$src},
2163 0 0       0 } => $class
2164             };
2165            
2166             sub drop_while {
2167 0     0   0 my ($gen, $code) = @_;
2168 0         0 $code->$sv2cv;
2169 0     0   0 $gen->drop_until(sub {not &$code})
2170            
2171 0         0 }
2172             sub drop_until {
2173 0     0   0 my ($gen, $code) = @_;
2174 0         0 my $n = $gen->first_idx($code);
2175 0 0       0 defined $n ? $gen->drop($n) : List::Gen::empty()
2176             }
2177            
2178             sub cross2d {
2179 0 0   0   0 if ($_[1]->$is_array_or_gen) {
2180 0         0 $_[0]->crosswith2d($comma, @_[1..$#_])
2181             } else {
2182 0         0 goto &crosswith2d
2183             }
2184             }
2185             sub crosswith2d {
2186 0     0   0 my ($xs, $code, $ys) = splice @_, 0, 3;
2187 0         0 $code->$sv2cv;
2188 0 0       0 if (grep {$_->is_mutable} $xs, $ys) {
  0         0  
2189 0         0 Carp::croak "mutable generators not yet supported"
2190             }
2191             &List::Gen::iterate(sub {
2192 0     0   0 my $x = $xs->get($_);
2193 0         0 &List::Gen::gen(sub {$code->($x, $_)}, $ys)
  0         0  
2194 0         0 }, $xs->size);
2195             }
2196            
2197             sub cross {
2198 5 100   5   11 if ($_[1]->$is_array_or_gen) {
2199 1         12 $_[0]->crosswith($comma, @_[1..$#_])
2200             } else {
2201 4         13 goto &crosswith
2202             }
2203             }
2204             sub crosswith {
2205 5     5   11 my ($xs, $code, $ys) = splice @_, 0, 3;
2206 5         13 $code->$sv2cv;
2207 5 50       14 if (@_) {
2208 0         0 $xs = $xs->crosswith($code, $_) for $ys, @_;
2209 0         0 return $xs
2210             }
2211 5         6 my $mutable;
2212             List::Gen::mapn {
2213 10     10   23 $_[1] = $_->size;
2214 10 50       50 if ($_->is_mutable) {
2215 0         0 $mutable = $_[2] = 1;
2216 0         0 $_->tail_size($_[1])
2217             }
2218 5         31 } 3 => $xs => my ($xsize, $xs_mutable),
2219             $ys => my ($ysize, $ys_mutable);
2220            
2221 5 50 33     30 if ($ysize >= 9**9**9 and not $ys_mutable) {
2222             return &List::Gen::gen(sub {
2223 0     0   0 $code->($xs->get(0), $ys->get($_))
2224             })
2225 0         0 }
2226 5 50 33     14 if ($xsize >= 9**9**9 and not $xs_mutable) {
2227             return &List::Gen::gen(sub {
2228 0     0   0 $code->($xs->get(int($_ / $ysize)), $ys->get($_ % $ysize))
2229             })
2230 0         0 }
2231 5         6 my ($xi, $yi, $gen);
2232 5 100       14 if ($code == $comma) {
2233 1         3 my $i;
2234             my $got;
2235             $gen = &List::Gen::gen(
2236             $mutable
2237             ? do {
2238             my $set_size = sub {
2239 0     0   0 $gen->set_size($xs->size * $ys->size * 2)
2240 0         0 };
2241 0 0       0 $xs->when_done($set_size) if $xs_mutable;
2242 0 0       0 $ys->when_done($set_size) if $ys_mutable;
2243             sub {
2244 0 0 0 0   0 if ($got and int($_ / 2) == $i) {
2245 0         0 return $$got[$_ % 2]
2246             }
2247 0         0 $i = int ($_ / 2);
2248 0         0 $xi = int ($i / $ysize);
2249 0         0 $yi = $i - $xi * $ysize;
2250 0         0 $got = sub {\@_}->($xs->get($xi), $ys->get($yi));
  0         0  
2251 0         0 $$got[$_ % 2]
2252             }
2253 0         0 }
2254             : sub {
2255 18     18   44 $i = int ($_ / 2);
2256 18         19 $xi = int ($i / $ysize);
2257 18 100       47 $_ % 2 ? $ys->get($i - $xi * $ysize)
2258             : $xs->get($xi)
2259             },
2260 1 50       11 $xsize * $ysize * 2
2261             )
2262             } else {
2263             $gen = &List::Gen::gen(
2264             $mutable
2265             ? do {
2266             my $set_size = sub {
2267 0     0   0 $gen->set_size($xs->size * $ys->size)
2268 0         0 };
2269 0 0       0 $xs->when_done($set_size) if $xs_mutable;
2270 0 0       0 $ys->when_done($set_size) if $ys_mutable;
2271             sub {
2272 0     0   0 $xi = int ($_ / $ysize);
2273 0         0 $yi = $_ - $xi * $ysize;
2274 0         0 $code->($xs->get($xi), $ys->get($yi))
2275             }
2276 0         0 }
2277             : sub {
2278 21     21   30 $xi = int ($_ / $ysize);
2279 21         24 $yi = $_ - $xi * $ysize;
2280 21         42 $code->($xs->get($xi), $ys->get($yi))
2281             },
2282 4 50       26 $xsize * $ysize
2283             )
2284             }
2285 5 50       24 $gen = &List::Gen::mutable($gen) if $mutable;
2286 5         36 $gen
2287             }
2288            
2289             sub cycle {
2290 0     0   0 my $src = shift;
2291 0         0 my ($fetch, $fsize) = tied(@$src)->closures;
2292 0         0 my $size = $fsize->();
2293             $src->is_mutable
2294             ? do {
2295 0         0 $src->tail_size($size);
2296             &List::Gen::gen(sub {
2297 0 0   0   0 my $ret = \$fetch->(undef, $size >= 9**9**9 ? $_ : $_ % $size);
2298 0 0       0 $_ < $size ? $$ret : $fetch->(undef, $_ % $size)
2299             })
2300 0         0 }
2301 0 0       0 : do {
2302 0     0   0 $size >= 9**9**9
2303             ? $src
2304             : &List::Gen::gen(sub {$fetch->(undef, $_ % $size)})
2305 0 0       0 }
2306             }
2307            
2308             sub reduce {
2309 7     7   10 my ($self, $code) = @_;
2310 7         17 $code->$sv2cv;
2311 7 50       21 return $self if $code == $comma;
2312 7 50       17 return $self->flip if $code == $rcomma;
2313            
2314 7         17 my ($ca, $cb) = $code->$cv_ab_ref;
2315 7         26 local (*a, *b) = local (*$ca, *$cb);
2316            
2317 7         56 my $fetch = tied(@$self)->can('FETCH');
2318 7 50       44 $a = $fetch->(undef, 0) if @$self;
2319 7 50       16 return unless @$self;
2320            
2321 7         15 my $args = $code->$cv_wants_2_args;
2322 7 50       19 if ($self->is_mutable) {
2323 0         0 my $i;
2324 0         0 my $size = $self->size;
2325 0         0 $self->tail_size($size);
2326 0         0 while (++$i < $size) {
2327 0         0 $b = $fetch->(undef, $i);
2328 0 0       0 last if $i >= $size;
2329 0 0       0 $a = $code->($args ? ($a, $b) : ())
2330             }
2331             } else {
2332 7 50       21 $self->size < 9**9**9 or Carp::croak "can not reduce infinite generator";
2333 7         436 for (1 .. $#$self) {
2334 45         74 $b = $fetch->(undef, $_);
2335 45 50       529 $a = $code->($args ? ($a, $b) : ())
2336             }
2337             }
2338 7         52 $a
2339             }
2340 0 0   0   0 sub sum {$_[0]->reduce(sub {$a + $b}) or 0}
  0     0   0  
2341 0 0   0   0 sub product {$_[0]->reduce(sub {$a * $b}) or 0}
  0     0   0  
2342 0 0   0   0 sub min {$_[0]->reduce(sub {$a > $b ? $b : $a})}
  0     0   0  
2343 0 0   0   0 sub max {$_[0]->reduce(sub {$a > $b ? $a : $b})}
  0     0   0  
2344            
2345             sub rotate {
2346 0     0   0 my ($self, $n) = (@_, 1);
2347 0 0       0 $self->apply if $self->is_mutable;
2348 0         0 my $size = $self->size;
2349 0 0       0 if ($n < 0) {
2350 0         0 $n = $size - (abs($n) % $size);
2351             }
2352 0 0       0 return $self->drop($n) if $size >= 9**9**9;
2353 0 0       0 if ($n >= $size) {
2354 0         0 $n %= $size
2355             }
2356 0         0 List::Gen::tiegen( Rotate => tied @$self, $n )
2357             }
2358            
2359             List::Gen::generator Rotate => sub {
2360 0     0   0 my ($class, $src, $n) = @_;
2361 0         0 my $size = $src->fsize;
2362 0         0 while ($src->can('rotate')) {
2363 0         0 $n += $src->rotate;
2364 0         0 $src = $src->source;
2365             }
2366 0         0 my $fetch = $src->can('FETCH');
2367 0     0   0 &List::Gen::curse({
2368             FETCH => sub {$fetch->(undef, ($_[1] + $n) % $size)},
2369 0     0   0 fsize => sub {$size},
2370 0     0   0 source => sub {$src},
2371 0     0   0 rotate => sub {$n},
2372 0         0 } => $class)
2373 0     0   0 }, mutable => sub {0};
2374            
2375             sub nxt {
2376 0     0   0 my ($self, $n) = @_;
2377 0         0 my @ret;
2378 0         0 while ($self->more) {
2379 0 0       0 my @x = $self->next or next;
2380 0 0       0 if ($n) {
2381 0         0 push @ret, @x;
2382 0 0       0 next if @ret < $n;
2383             last
2384 0         0 }
2385 0 0       0 return wantarray ? @x : pop @x
2386             }
2387 0 0       0 wantarray ? @ret : &List::Gen::makegen(\@ret)
2388             }
2389            
2390             sub span {
2391 0     0   0 my $self = shift;
2392 0 0       0 if (@_) {
2393 0         0 my $code = shift;
2394 0         0 $code->$sv2cv;
2395 0         0 my $size = $self->size;
2396 0 0       0 $self->tail_size($size) if $self->is_mutable;
2397 0         0 my $done;
2398 0         0 my $take = $self->take_while($code);
2399 0     0   0 $take->when_done(sub {$done = $take->size});
  0         0  
2400             my $drop = &List::Gen::gen(sub {
2401 0 0   0   0 $take->apply unless defined $done;
2402 0         0 my $i = $_ + $done;
2403 0 0       0 List::Gen::done() if $i >= $size;
2404 0         0 my $x = $self->get($_ + $done);
2405 0 0       0 List::Gen::done() if $i >= $size;
2406 0 0       0 List::Gen::done($x) if $i == $size - 1;
2407 0         0 $x
2408 0         0 })->mutable;
2409 0         0 $take, $drop
2410             }
2411             else {
2412 0         0 my (@i, @ret);
2413 0         0 while ($self->more) {
2414 0 0       0 @ret ? last : next unless @i = $self->next;
    0          
2415 0         0 push @ret, @i;
2416             }
2417 0 0       0 wantarray ? @ret : \@ret
2418             }
2419             }
2420             sub break {
2421 0     0   0 my ($self, $code) = @_;
2422 0         0 $code->$sv2cv;
2423 0     0   0 $self->span(sub {not &$code})
2424 0         0 }
2425            
2426             sub zip {
2427 6 100   6   23 if ($_[1]->$is_array_or_gen) {
2428 2         10 goto &List::Gen::zipgen
2429             }
2430 4         14 goto &zipwith
2431             }
2432             sub zipwith {
2433 4     4   12 my ($self, $code) = splice @_, 0, 2;
2434 4         8 $code->$sv2cv;
2435 4         13 &List::Gen::zipwith($code, $self, @_);
2436             }
2437            
2438             sub zipwithab {
2439 0     0   0 my ($xs, $code, $ys) = @_;
2440 0 0       0 if ($code =~ /(?=.* \$a \b) (?=.* \$b \b)/sx) {
2441 0         0 $code = 'zipwithab'->$eval("sub {$code}");
2442             }
2443 0 0       0 ref $code eq 'CODE' or Carp::croak "not \$a / \$b code: $code";
2444 0         0 &List::Gen::zipwithab($code, $xs, $ys)
2445             }
2446 10     10   3060 BEGIN {*zipab = *zipwithab}
2447            
2448             sub mapn {
2449 0     0   0 my $self = shift;
2450 0 0       0 my ($n, $code) = $_[0] =~ /^\d+$/ ? @_ : @_[1, 0];
2451 0         0 $code->$sv2cv;
2452             $self->by($n)->map(sub {
2453 0     0   0 local *_ = $_;
2454 0         0 local *_ = \$_[0];
2455 0         0 &$code
2456             })
2457 0         0 }
2458            
2459             *clone = \&List::Gen::clone;
2460             sub copy {
2461 0     0   0 my $src = shift;
2462 0         0 my $new = clone($src);
2463 0         0 $new->index = $src->index;
2464 0         0 $new
2465             }
2466             {
2467 10     10   209 no warnings 'once';
  10         25  
  10         876  
2468             *For = *each = *do = sub {
2469 10     10   74 use warnings;
  10         29  
  10         1340  
2470 0 0   0   0 @_ == 2 or Carp::croak 'call as $gen->do/each(CODE or STRING)';
2471 0         0 my ($gen, $code) = @_;
2472 0         0 my $src = tied @$gen;
2473 0         0 my ($fetch, $fsize) = $src->closures;
2474 0         0 my $i = 0;
2475            
2476 0         0 $code->$sv2cv;
2477 0         0 my $last = $code->$cv_local('last');
2478 10     10   57 no warnings 'redefine';
  10         22  
  10         771  
2479 0     0   0 local *$last = sub {die bless [@_] => 'List::Gen::Last'};
  0         0  
2480 10     10   63 use warnings;
  10         18  
  10         7187  
2481            
2482 0         0 my $warn = $SIG{__WARN__};
2483             local $SIG{__WARN__} = sub {
2484 0 0   0   0 return if $_[0] =~ /^Exiting subroutine via last/i;
2485 0 0       0 $warn ? &$warn : print STDERR @_
2486 0         0 };
2487 0         0 local ($@, @_);
2488 0         0 local *_ = \0;
2489 0         0 eval {
2490 0         0 my $size = $fsize->();
2491 0 0       0 if ($src->mutable) {
2492 0         0 $src->tail_size($size);
2493 0         0 while ($i < $size) {
2494 0         0 *_ = \$fetch->(undef, $i);
2495 0 0       0 last unless $i++ < $size;
2496 0         0 &$code
2497             }
2498             } else {
2499 0         0 while ($i < $size) {
2500 0         0 *_ = \$fetch->(undef, $i++);
2501 0         0 &$code
2502             }
2503             }
2504 0         0 1} or ref $@
2505             ? ref($@) =~ /^List::Gen::(Last|Done)$/
2506 0 0       0 ? return wantarray ? @{$@} : pop @{$@}
  0 0       0  
    0          
    0          
2507             : die $@
2508             : Carp::croak $@;
2509             return
2510 0         0 }
2511             }
2512            
2513 0     0   0 sub head {tied(@{$_[0]})->FETCH(0)}
  0         0  
2514             {
2515             my ($slice, $range) = \(&List::Gen::slice, &List::Gen::range);
2516 0   0 0   0 {my $span; sub tail {$_[0]->$slice($span ||= $range->( 1 => 9**9**9 ))}}
2517 0   0 0   0 {my %span; sub drop {$_[0]->$slice($span{$_[1]} ||= $range->($_[1] => 9**9**9 ))}}
2518 9   66 9   374 {my %span; sub take {$_[0]->$slice($span{$_[1]} ||= $range->( 0 => $_[1] - 1))}}
2519             }
2520 10     10   66 {no strict 'refs';
  10         21  
  10         3859  
2521             for my $sub (qw(
2522             gen test cache expand contract collect flip While Until recursive
2523             mutable by every filter filter_stream scan scan_stream
2524             iterate iterate_multi iterate_stream iterate_multi_stream
2525             gather gather_multi gather_stream gather_multi_stream
2526             )) {
2527             my $code = \&{"List::Gen::$sub"};
2528             if ((prototype $code or '') =~ /^&/) {
2529             *$sub = sub {
2530 7     7   14 push @_, shift;
2531 7         18 $sv2cv->(my $sub = shift);
2532 7         15 unshift @_, $sub;
2533 7         80 goto &$code;
2534             }
2535             } else {
2536 0     0   0 *$sub = sub {push @_, shift; goto &$code}
  0         0  
2537             }
2538             if ($sub =~ /_/) {
2539             (my $joined = $sub) =~ s/_//g;
2540             (my $short = $sub) =~ s/_([a-z])[a-z]+/\U$1/g;
2541             *$short = *$joined = *$sub;
2542             }
2543             }
2544 10     10   73 {no warnings 'once';
  10         20  
  10         104151  
2545             *map = *gen;
2546             *grep = *filter;
2547             *x = *X = *cross;
2548             *z = *Z = *zip;
2549             *while = *take_while = *While;
2550             *until = *take_until = *Until;
2551             *rec = *with_self = *withself = *recursive;
2552             *cached = *memoized = *memoize = *cache;
2553             *filterS = *grepS = *grep_stream = *filter_stream;
2554             }
2555             for my $internal (qw(set_size when_done clear_done is_mutable set from
2556             PUSH POP SHIFT UNSHIFT SPLICE tail_size load)) {
2557             my $method = $internal eq 'is_mutable' ? 'mutable' : $internal;
2558             my $search = $internal =~ /^(?:set_size|when_done|clear_done)$/;
2559             *{lc $internal} = sub {
2560 45     45   58 my $gen = shift;
2561 45         624 my $self = tied @$gen;
2562 45 50 33     418 if (my $code = $self->can($method) || $search && do {
2563             my @src = $self->sources;
2564             while (@src) {
2565             last if $src[0]->can($method);
2566             shift @src;
2567             }
2568             @src ? ($self = $src[0])->can($method) : ()
2569 0         0 }) {
2570 45         85 unshift @_, $self;
2571 45 50       138 if ($internal =~ /^(PUSH|UNSHIFT|from|load)$/) {
  45         78  
2572 0         0 &$code;
2573 0         0 $gen
2574             } else {&$code}
2575             }
2576             else {Carp::croak "no method '$method' on '".ref($self)."'"}
2577             }
2578             }
2579             }
2580 0     0   0 sub reverse {goto &List::Gen::flip}
2581 0     0   0 sub overlay {goto &List::Gen::overlay}
2582 0     0   0 sub zipmax {goto &List::Gen::zipgenmax}
2583             sub zipwithmax {
2584 0     0   0 my $code = splice @_, 1, 1;
2585 0         0 $code->$sv2cv;
2586 0         0 unshift @_, $code;
2587 0         0 goto &List::Gen::zipwithmax
2588             }
2589            
2590             sub leaves {
2591 0     0   0 my @stack = @_;
2592 0         0 for (@stack) {
2593 0 0 0     0 $_->reset if ref and List::Gen::isagen($_)
2594             }
2595             sub {
2596 0   0 0   0 while (@stack and ref $stack[-1]
      0        
2597             and List::Gen::isagen($stack[-1])) {
2598 0 0       0 if (my @next = $stack[-1]->next) {
2599 0         0 for (@next) {
2600 0 0 0     0 $_->reset if ref and List::Gen::isagen($_)
2601             }
2602 0         0 push @stack, CORE::reverse @next;
2603             } else {
2604 0         0 (pop @stack)->reset;
2605             }
2606             }
2607 0 0       0 @stack ? pop @stack : ()
2608             }
2609 0         0 }
2610             {
2611             my %threaded;
2612 51 50   51   2493 sub DESTROY {$_[0]->threads_stop if delete $threaded{$_[0]}}
2613            
2614             sub threads_start {
2615 0 0   0   0 $] < 5.013 or Carp::croak "threads not yet supported in perl 5.13+";
2616 0         0 $threaded{$_[0]} = 1;
2617 0         0 my $self = tied @{$_[0]};
  0         0  
2618 0 0       0 return if $$self{thread_queue};
2619 0   0     0 my $threads = $_[1] || 4;
2620 0         0 require threads;
2621 0         0 require Thread::Queue;
2622 0         0 $$self{$_} = Thread::Queue->new for qw(thread_queue thread_done);
2623 0         0 my $fetch = $self->can('FETCH');
2624 0         0 my $cached = $self->can('cached');
2625 0 0 0     0 if ($cached or $$self{thread_cached}) {
2626 0 0       0 if ($cached) {
2627 0         0 $cached = $cached->();
2628 0 0       0 unless (&threads::shared::is_shared($cached)) {
2629 0         0 my $type = Scalar::Util::reftype $cached;
2630 0 0       0 my @cache = $type eq 'HASH' ? %$cached : @$cached;
2631 0         0 &threads::shared::share($cached);
2632 0 0       0 ($type eq 'HASH' ? %$cached : @$cached) = @cache;
2633             }
2634             } else {
2635 0         0 my $real_fetch = $fetch;
2636 0         0 my %cache;
2637 0         0 &threads::shared::share(\%cache);
2638             $fetch = sub {
2639 0 0   0   0 exists $cache{$_[1]}
2640             ? $cache{$_[1]}
2641             :($cache{$_[1]} = $real_fetch->(undef, $_[1]))
2642             }
2643 0         0 }
2644             }
2645 0         0 @{$$self{thread_workers}} = map {
2646 0         0 threads->create(sub {
2647 0     0   0 while (my $job = $$self{thread_queue}->dequeue) {
2648 0 0       0 last if $job eq 'stop';
2649 0         0 $$self{thread_done}->enqueue(
2650 0         0 [$$job[0], sub {\@_}->(map $fetch->(undef, $_) => @{$$job[1]})]
  0         0  
2651             )
2652             }
2653             })
2654 0         0 } 1 .. $threads;
2655 0         0 $_[0];
2656             }
2657             sub threads_stop {
2658 0     0   0 my $self = tied @{$_[0]};
  0         0  
2659 0 0       0 if ($$self{thread_queue}) {
2660 0         0 $$self{thread_queue}->enqueue('stop') for @{$$self{thread_workers}};
  0         0  
2661 0         0 for (@{$$self{thread_workers}}) {
  0         0  
2662 0         0 $_->join;
2663             }
2664 0         0 delete $$self{"thread_$_"} for qw(queue done workers cache cached);
2665             }
2666 0         0 delete $threaded{$_[0]};
2667 0         0 $_[0]
2668             }
2669             }
2670             sub threads_slice {
2671 0     0   0 my $gen = shift;
2672 0         0 my $self = tied @$gen;
2673 0 0       0 $gen->threads_start unless $$self{thread_queue};
2674 0         0 my $threads = @{$$self{thread_workers}};
  0         0  
2675 0   0     0 my $step = $$self{thread_blocksize} || int(@_/$threads + 1);
2676 0         0 my $part = 0;
2677             List::Gen::mapn {
2678 0     0   0 $$self{thread_queue}->enqueue([$part++, \@_]);
2679 0         0 } $step => @_;
2680 0         0 my @result;
2681 0         0 for (1 .. $part) {
2682 0         0 my $got = $$self{thread_done}->dequeue;
2683 0         0 $result[$$got[0]] = $$got[1];
2684             }
2685 0 0       0 wantarray ? map @$_ => @result
2686             : $l2g->(map @$_ => @result)
2687             }
2688             sub threads_all {
2689 0     0   0 my $gen = shift;
2690 0         0 $gen->threads_slice(0 .. $gen->size - 1)
2691             }
2692             sub threads_cached {
2693 0     0   0 my $gen = shift;
2694 0         0 my $self = tied @$gen;
2695 0 0       0 Carp::carp "can not cache started threads" if $$self{thread_workers};
2696 0         0 $$self{thread_cached} = 1;
2697 0 0       0 $gen->threads_start(@_) if @_;
2698 0         0 $gen;
2699             }
2700             sub threads_blocksize {
2701 0     0   0 my $gen = shift;
2702 0         0 my $self = tied @$gen;
2703 0         0 my $size = int shift;
2704 0 0       0 Carp::croak "minimum block size is 1" if $size < 1;
2705 0         0 $$self{thread_blocksize} = $size;
2706 0         0 $gen;
2707             }
2708             }
2709            
2710             sub isagen (;$) {
2711 117 100 66 117 0 1349 @_ ? (ref $_[0] and substr(ref $_[0], 0, 14) eq 'List::Gen::era' and $_[0])
      33        
2712             : (ref $_ and substr(ref $_, 0, 14) eq 'List::Gen::era' and $_)
2713             }
2714             sub tiegen {
2715 129     129 0 237 my @ret;
2716 129         177 my $class = shift;
2717 129 0       160 eval {tie @ret => 'List::Gen::'.$class, @_}
  129 50       619  
2718             or croak "error compiling $class, ",
2719             $@ =~ /^(.+) at .+?List-Gen.*$/s ? $1 : $@;
2720            
2721 129 50       286 if (DEBUG) {
2722 0         0 my $src = tied @ret;
2723 0         0 (my $type = ref $src) =~ s/::_\d+$//;
2724 0         0 my @needs = do {
2725 0         0 my %exempt = (
2726             source => [qw(Range Capture Iterate Iterate_Multi Empty)],
2727             mutable => [qw(Gen Sequence Zip Flip Recursive Slice Mutable)],
2728             );
2729 0         0 $exempt{$_} = {map {;"List::Gen::$_" => 1} @{$exempt{$_}}} for keys %exempt;
  0         0  
  0         0  
2730 0 0 0 0   0 grep {$$src{$_} ? 0 : B::svref_2object($src->can($_) or sub {})->STASH->NAME ne $type}
  0 0 0     0  
  0         0  
2731             qw (FETCH fsize), ('source') x! $exempt{source}{$type},
2732             !$exempt{mutable}{$type} && $src->mutable ? qw(apply set_size _when_done tail_size) : ()
2733             };
2734 0 0       0 if (@needs) {
2735 0         0 $List::Gen::report{"$type needs @needs"}++;
2736             }
2737             }
2738 129 50       259 croak '$List::Gen::LIST is no longer supported' if $LIST;
2739 129         372 List::Gen::erator->new(\@ret)
2740             }
2741 10 50   10   82161 END {if (DEBUG) {warn "$_\n" for keys %List::Gen::report}}
  0         0  
2742            
2743             sub done;
2744             sub done_if ($@);
2745             sub done_unless ($@);
2746             sub catch_done ();
2747             sub mutable;
2748            
2749             sub clone {
2750 0     0 0 0 tiegen Clone => @_
2751             }
2752             generator Clone => sub {
2753 0     0   0 my $src = tied @{$_[1]};
  0         0  
2754 0         0 bless {%$src, self => [$_[1]]} => ref $src
2755             };
2756            
2757 0     0 0 0 sub empty () {tiegen 'Empty'}
2758             generator Empty => sub {
2759             curse {
2760 0     0   0 FETCH => sub () { },
2761             fsize => sub () {0},
2762             } => shift
2763 0     0   0 };
2764            
2765            
2766             =head2 source generators
2767            
2768             =over 4
2769            
2770             =item range C< SIZE >
2771            
2772             returns a generator from C< 0 > to C< SIZE - 1 >
2773            
2774             my $range = range 10;
2775            
2776             say $range->str; # 0 1 2 3 4 5 6 7 8 9
2777             say $range->size; # 10
2778            
2779             =item range C< START STOP [STEP] >
2780            
2781             returns a generator for values from C< START > to C< STOP > by C< STEP >,
2782             inclusive.
2783            
2784             C< STEP > defaults to 1 but can be fractional and negative. depending on your
2785             choice of C< STEP >, the last value returned may not always be C< STOP >.
2786            
2787             range(0, 3, 0.4) will return (0, 0.4, 0.8, 1.2, 1.6, 2, 2.4, 2.8)
2788            
2789             print "$_ " for @{range 0, 1, 0.1};
2790             # 0 0.1 0.2 0.3 0.4 0.5 0.6 0.7 0.8 0.9 1
2791            
2792             print "$_ " for @{range 5, 0, -1};
2793             # 5 4 3 2 1 0
2794            
2795             my $nums = range 0, 1_000_000, 2;
2796             print "@$nums[10, 100, 1000]";
2797             # gets the tenth, hundredth, and thousandth numbers in the range
2798             # without calculating any other values
2799            
2800             C also accepts character strings instead of numbers. it will behave
2801             the same way as perl's internal C< .. > operator, except it will be lazy.
2802            
2803             say range('a', 'z')->str; # 'a b c d e f g ... x y z'
2804            
2805             range('a', 'zzz', 2)->say; # 'a c e g i k m ... zzu zzw zzy'
2806            
2807             say ->str; # 'A B C D E ... ZX ZY ZZ'
2808            
2809             <1..>->zip()->say(10); # '1 a 2 b 3 c 4 d 5 e'
2810            
2811             to specify an infinite range, you can pass C< range > an infinite value
2812             (C< 9**9**9 > works well), or the glob C< ** >, or the string C< '*' >
2813            
2814             range(1, 9**9**9) ~~ range(1, **) ~~ range(1, '*') ~~ <1..*> ~~ <1..>
2815            
2816             ranges only store their endpoints, and ranges of all sizes take up the same
2817             amount of memory.
2818            
2819             =cut
2820            
2821             sub range ($;$$) {
2822 63 50 33 63 1 346 splice @_, 1, 1, 9**9**9
      66        
2823             if @_ > 1 and $_[1] eq '*'
2824             || \$_[1] == \**;
2825 63         122 for (@_) {
2826             defined
2827 124 100 66     711 and /^[a-z]+$/i
      100        
2828             and not looks_like_number $_
2829             and goto &arange
2830             }
2831 57 100       231 tiegen Range => @_ == 1 ? (0, $_[0] - 1) : @_
2832             }
2833             generator Range => sub {
2834 57     57   131 my ($class, $low, $high, $step, $size) = (@_, 1);
2835             $size = $high < 9**9**9
2836 57 100       132 ? do {
2837 31 50       77 $size = $step > 0 ? $high - $low : $low - $high;
2838 31         69 $size = 1 + $size / abs $step;
2839 31 50       62 $size > 0 ? int $size : 0
2840             } : $high;
2841            
2842 57 50       223 $size = 0 unless $low < 9**9**9;
2843             curse {
2844             FETCH => sub {
2845 125 50   125   497 $_[1] < $size
2846             ? $low + $step * $_[1]
2847 0         0 : croak "range index $_[1] out of bounds [0 .. @{[$size - 1]}]"
2848             },
2849 81     81   424 fsize => sub {$size},
2850 45     45   131 range => sub {$low, $step, $size},
2851 57         605 } => $class
2852             };
2853            
2854             {my %map; @map{0..25} = 'a'..'z';
2855             my @cache = 'a'..'zz';
2856             sub num2alpha {
2857 24 50   24 0 40 my $num = @_ ? $_[0] : $_;
2858 24 50       44 return '-'.num2alpha(-$num) if $num < 0;
2859 24 50       96 return $cache[$num] if $num < 702;
2860 0         0 my @str;
2861 0         0 while ($num > -1) {
2862 0         0 unshift @str, $map{$num % 26};
2863 0         0 $num = int($num / 26) - 1;
2864             }
2865 0         0 join '' => @str
2866             }}
2867            
2868             {my %map; @map{'a'..'z'} = 0..25;
2869             sub alpha2num {
2870 9     9 0 11 my $str = shift;
2871 9 50       15 return -alpha2num($1) if $str =~ /^-(.+)/;
2872 9         10 my ($num, $scale);
2873 9         27 for (split //, reverse $str) {
2874 9         28 $num += ($map{$_} + !!$scale) * 26**$scale++
2875             }
2876             $num
2877 9         24 }}
2878            
2879             sub arange {
2880 6 50   6 0 21 my ($low, $high, $step) = (@_ == 1 ? 'a' : (), @_, 1);
2881 6         13 my $uc = $low =~ /^[A-Z]+$/;
2882 6         11 for ($low, $high) {
2883 12 100 66     54 $_ = alpha2num lc if /^[a-z]+$/i and not looks_like_number $_
2884             }
2885 6 50       17 if ($step =~ /^[a-z]+$/i) {
2886 0         0 $step = 1 + alpha2num lc $step;
2887             }
2888 6 50   0   22 &gen($uc ? sub {uc &num2alpha} : \&num2alpha, $low, $high, $step)
  0         0  
2889             }
2890            
2891            
2892             =item gen C< {CODE} GENERATOR >
2893            
2894             =item gen C< {CODE} ARRAYREF >
2895            
2896             =item gen C< {CODE} SIZE >
2897            
2898             =item gen C< {CODE} [START STOP [STEP]] >
2899            
2900             =item gen C< {CODE} GLOBSTRING >
2901            
2902             C< gen > is the equivalent of C< map > for generators. it returns a generator
2903             that will apply the C< CODE > block to its source when accessed. C< gen > takes
2904             a generator, array ref, glob-string, or suitable arguments for C< range > as its
2905             source. with no arguments, C< gen > uses the range C< 0 .. infinity >.
2906            
2907             my @result = map {slow($_)} @source; # slow() called @source times
2908             my $result = gen {slow($_)} \@source; # slow() not called
2909            
2910             my ($x, $y) = @$result[4, 7]; # slow() called twice
2911            
2912             my $lazy = gen {slow($_)} range 1, 1_000_000_000;
2913             same: gen {slow($_)} 1, 1_000_000_000;
2914            
2915             print $$lazy[1_000_000]; # slow() only called once
2916            
2917             C< gen {...} list LIST > is a replacement for C< [ map {...} LIST ] >.
2918            
2919             C< gen > provides the functionality of the identical C<< ->gen(...) >> and
2920             C<< ->map(...) >> methods.
2921            
2922             note that while effort has gone into making generators as fast as possible there
2923             is overhead involved with lazy generation. simply replacing all calls to
2924             C< map > with C< gen > will almost certainly slow down your code. use these
2925             functions in situations where the time / memory required to completely generate
2926             the list is unacceptable.
2927            
2928             C< gen > and other similarly argumented functions in this package can also
2929             accept a string suitable for the C<< >> syntax:
2930            
2931             my $square_of_nats = gen {$_**2} '1..';
2932             my $square_of_fibs = gen {$_**2} '0, 1, *+*'; # no need for '...' with '*'
2933            
2934             which is the same as the following if C< glob > is imported:
2935            
2936             my $square_of_nats = gen {$_**2} <1..>;
2937             my $square_of_fibs = gen {$_**2} <0, 1, *+* ...>; # still need dots here
2938            
2939             =cut
2940            
2941             sub gen (&;$$$) {
2942 37     37 1 1358 tiegen Gen => shift, tied @{&dwim}
  37         65  
2943             }
2944            
2945             my $canglob = qr/\.{2,3}|,.*\*/;
2946 0 0   0 0 0 sub canglob (;$) {(@_ ? $_[0] : $_) =~ $canglob}
2947            
2948             sub dwim {
2949 46 100   46 1 112 @_ or @_ = (0 => 9**9**9);
2950             $#_ and &range
2951 46 0 66     483 or ref $_[0] and do {
    100 66        
      66        
      66        
      33        
      66        
      66        
      33        
2952 10 50       27 $_[0] = ${$_[0]}->() if ref $_[0] eq 'List::Gen::Thunk';
  0         0  
2953 10 50 0     23 isagen $_[0]
2954             or ref $_[0] eq 'ARRAY' and &makegen
2955             }
2956             or $_[0] and $_[0] =~ $canglob
2957             and isagen &glob($_[0] =~ /\.{2,3}/ ? $_[0] : "$_[0]...")
2958             or looks_like_number $_[0]
2959             and range int $_[0]
2960             or croak "invalid argument for generator: '$_[0]'"
2961             }
2962             generator Gen => sub {
2963 36     36   75 my ($class, $code, $source) = @_;
2964 36         232 my ($fetch, $fsize) = $source->closures;
2965             curse {
2966 40     40   102 FETCH => do {
2967 36 50       447 if ($source->can('range')) {
    0          
2968 36         84 my ($low, $step, $size) = $source->range;
2969             sub {
2970 278 50   278   704 local *_ = $_[1] < $size
2971             ? \($low + $step * $_[1])
2972             : &$fetch;
2973 278         502 $code->()
2974             }
2975 36         277 }
2976             elsif ($source->can('capture')) {
2977 0         0 my $cap = $source->capture;
2978 0     0   0 sub {local *_ = \$$cap[$_[1]]; $code->()}
  0         0  
2979 0         0 }
2980             else {
2981 0     0   0 sub {local *_ = \$fetch->(undef, $_[1]); $code->()}
  0         0  
2982 0         0 }
2983             },
2984             fsize => $fsize,
2985             source => sub {$source},
2986 36         54 } => $class
2987             };
2988            
2989            
2990             =item makegen C< ARRAY >
2991            
2992             C< makegen > converts an array to a generator. this is normally not needed as
2993             most generator functions will call it automatically if passed an array reference
2994            
2995             C< makegen > considers the length of C< ARRAY > to be immutable. changing the
2996             length of an array after passing it to C< makegen > (or to C< gen > and like
2997             argumented subroutines) will result in undefined behavior. this is done for
2998             performance reasons. if you need a length mutable array, use the C< array >
2999             function. changing the value of a cell in the array is fine, and will be
3000             picked up by a generator (of course if the generator uses a cache, the value
3001             won't change after being cached).
3002            
3003             you can assign to the generator returned by C< makegen >, provided the
3004             assignment does not lengthen the array.
3005            
3006             my $gen = makegen @array;
3007            
3008             $$gen[3] = 'some value'; # now $array[3] is 'some value'
3009            
3010             =cut
3011            
3012             sub makegen (\@) {
3013 11     11 1 31 tiegen Capture => @_
3014             }
3015             generator Capture => sub {
3016 11     11   19 my ($class, $source) = @_;
3017 11         16 my $size = @$source;
3018 73     73   132 curse {
3019             FETCH => sub {$$source[ $_[1] ]},
3020 27     27   58 fsize => sub {$size},
3021 0     0   0 capture => sub {$source}
3022 11         117 } => $class
3023             },
3024             STORE => sub {
3025 0 0   0   0 $_[1] < $_[0]->fsize
3026             ? $_[0]->capture->[$_[1]] = $_[2]
3027             : croak "index $_[1] out of range 0 .. ".($_[0]->size - 1)
3028             };
3029            
3030            
3031             =item list C< LIST >
3032            
3033             C< list > converts a list to a generator. it is a thin wrapper around
3034             C< makegen > that simply passes its C< @_ > to C< makegen >. that means the
3035             values in the returned generator are aliases to C's arguments.
3036            
3037             list(2, 5, 8, 11)->map('*2')->say; # '4 10 16 22'
3038            
3039             is the same as writing:
3040            
3041             (gen {$_*2} cap 2, 5, 8, 11)->say;
3042            
3043             in the above example, C< list > can be used in place of C< cap > and has exactly
3044             the same functionality:
3045            
3046             (gen {$_*2} list 2, 5, 8, 11)->say;
3047            
3048             =cut
3049            
3050 0     0 1 0 sub list {makegen @_}
3051            
3052            
3053             =item array C< [ARRAY] >
3054            
3055             C< array > is similar to C< makegen > except the array is considered a mutable
3056             data source. because of this, certain optimizations are not possible, and the
3057             generator returned will be a bit slower than the one created by C< makegen > in
3058             most conditions (increasing as generator functions are stacked).
3059            
3060             it is ok to modify C< ARRAY > after creating the generator. it is also possible
3061             to use normal array modification functions such as C< push >, C< pop >,
3062             C< shift >, C< unshift >, and C< splice > on the generator. all changes will
3063             translate back to the source array.
3064            
3065             you can think of C< array > as converting an array to an array reference that
3066             is also a generator.
3067            
3068             my @src = 1..5;
3069             my $gen = array @src;
3070            
3071             push @$gen, 6;
3072            
3073             $$gen[6] = 7; # assignment is ok too
3074            
3075             say $gen->size; # 7
3076             say shift @$gen; # 1
3077             say $gen->size; # 6
3078             say $gen->str; # 2 3 4 5 6 7
3079             say "@src"; # 2 3 4 5 6 7
3080            
3081             my $array = array; # no args creates an empty array
3082            
3083             =cut
3084            
3085 0 0   0 1 0 sub array (;\@) {tiegen Array => @_ ? @_ : []}
3086             mutable_gen Array => sub {
3087 0     0   0 my ($class, $src) = @_;
3088 0     0   0 curse {
3089             FETCH => sub {$$src[$_[1]]},
3090 0     0   0 STORE => sub {$$src[$_[1]] = $_[2]},
3091 0     0   0 fsize => sub {scalar @$src},
3092 0     0   0 capture => sub {$src},
3093 0         0 } => $class
3094             },
3095 0     0   0 PUSH => sub {push @{$_[0]->capture}, @_[1..$#_]},
  0         0  
3096 0     0   0 UNSHIFT => sub {unshift @{$_[0]->capture}, @_[1..$#_]},
  0         0  
3097 0     0   0 POP => sub {pop @{$_[0]->capture}},
  0         0  
3098 0     0   0 SHIFT => sub {shift @{$_[0]->capture}},
  0         0  
3099             SPLICE => sub {
3100 0     0   0 my $cap = shift->capture;
3101 0 0       0 @_ == 0 ? splice @$cap :
    0          
    0          
3102             @_ == 1 ? splice @$cap, $_[0] :
3103             @_ == 2 ? splice @$cap, $_[0], $_[1] :
3104             splice @$cap, $_[0], $_[1], @_[2..$#_]
3105             },
3106 0     0   0 DELETE => sub {delete $_[0]->capture->[$_[1]]},
3107 0     0   0 STORESIZE => sub {$#{$_[0]->capture} = $_[1] - 1},
  0         0  
3108 0     0   0 CLEAR => sub { @{$_[0]->capture} = ()};
  0         0  
3109            
3110            
3111             =item file C<< FILE [OPTIONS] >>
3112            
3113             C< file > creates an C< array > generator from a file name or file handle
3114             using C< Tie::File >. C< OPTIONS > are passed to C< Tie::File >
3115            
3116             my $gen = file 'some_file.txt';
3117            
3118             my $uc_file = $gen->map('uc');
3119            
3120             my $with_line_numbers = <1..>->zip('"$a: $b"', $gen);
3121            
3122             =cut
3123            
3124             sub file {
3125 0     0 1 0 my $file = shift;
3126 0         0 my %args = (recsep => $/, @_);
3127 0         0 require Tie::File;
3128 0 0       0 tie my @array, 'Tie::File', $file, %args or die $!;
3129 0         0 array @array
3130             }
3131            
3132            
3133             =item repeat C<< SCALAR [SIZE] >>
3134            
3135             an infinite generator that returns C for every position. it is
3136             equivalent to C< gen {SCALAR} > but a little faster.
3137            
3138             =cut
3139            
3140             sub repeat {
3141 5     5 1 15 tiegen Repeat => @_
3142             }
3143             generator Repeat => sub {
3144 5     5   12 my ($class, $x, $size) = (@_, 9**9**9);
3145 0     0   0 curse {
3146             FETCH => sub () {$x},
3147 0     0   0 fsize => sub () {$size},
3148 5         74 } => $class
3149             };
3150            
3151            
3152             =item iterate C< {CODE} [LIMIT|GENERATOR] >
3153            
3154             C< iterate > returns a generator that is created iteratively. C< iterate >
3155             implicitly caches its values, this allows random access normally not
3156             possible with an iterative algorithm. LIMIT is an optional number of times to
3157             iterate. normally, inside the CODE block, C<$_> is set to the current iteration
3158             number. if passed a generator instead of a limit, C<$_> will be set to
3159             sequential values from that generator.
3160            
3161             my $fib = do {
3162             my ($x, $y) = (0, 1);
3163             iterate {
3164             my $return = $x;
3165             ($x, $y) = ($y, $x + $y);
3166             $return
3167             }
3168             };
3169            
3170             generators produced by C< iterate > have an extra method, C<< ->from(LIST) >>.
3171             the method must be called before values are accessed from the generator. the
3172             passed C< LIST > will be the first values returned by the generator. the method
3173             also changes the behavior of C< $_ > inside the block. C< $_ > will contain the
3174             previous value generated by the iterator. this allows C< iterate > to behave the
3175             same way as the like named haskell function.
3176            
3177             haskell: take 10 (iterate (2*) 1)
3178             perl: iterate{2*$_}->from(1)->take(10)
3179             <1, 2 * * ... 10>
3180             <1,2**...10>
3181            
3182             which all return C< [1, 2, 4, 8, 16, 32, 64, 128, 256, 512] >
3183            
3184             =cut
3185            
3186             sub iterate (&;$) {
3187 7 50   7 1 15 goto &iterate_stream if $STREAM;
3188 7         14 my ($code, $size) = (@_, 9**9**9);
3189 7 50 33     11 if (isagen($size) and $size->is_mutable) {
3190 0         0 goto &iterate_multi
3191             }
3192 7         18 tiegen Iterate => $code, $size
3193             }
3194             generator Iterate => sub {
3195 7     7   13 my ($class, $code, $size) = @_;
3196 7         10 my (@list, $from, $source);
3197 7 50       11 if (isagen($size)) {
3198 7         21 $source = tied(@$size)->can('FETCH');
3199 7         21 $size = $size->size;
3200             }
3201             curse {
3202             FETCH => sub {
3203 58 50   58   120 (my $i = $_[1]) >= $size
3204 0         0 and croak "index $_[1] out of bounds [0 .. @{[$size - 1]}]";
3205 58 50       109 if ($i > $#list) {
3206 58         97 for (@list .. $i) {
3207 58         54 $list[$_] = do {
3208 58 50       150 $from ? local *_ = $list[$_ - 1] :
    50          
3209             $source ? local *_ = \$source->(undef, $_) : ();
3210 58         88 \$code->()
3211             }
3212             }
3213             }
3214 58         80 ${$list[$i]}
  58         161  
3215             },
3216 7     7   19 fsize => sub { $size},
3217 0     0   0 cached => sub {\@list},
3218             from => sub {
3219 0 0 0 0   0 return $from if @_ == 2 and ref $_[1] eq 'List::Gen::From_Check';
3220            
3221 0 0 0     0 croak "can not call ->from on started iterator"
3222             if @list or $from++;
3223 0 0       0 push @list, @_ > 1 ? \@_[1..$#_] : \List::Gen::Iterate::Default->new;
3224             },
3225 7         93 } => $class
3226             },
3227 0     0   0 load => sub {push @{$_[0]->cached}, \@_[1..$#_]},
  0         0  
3228 0     0   0 purge => sub {croak 'can not purge iterative generator'};
3229            
3230             {package
3231             List::Gen::Iterate::Default;
3232 0     0   0 sub new {bless []}
3233 0         0 use overload fallback => 1,
3234 0 0   0   0 '""' => sub :lvalue {@{$_[0]} ? $_[0][0] : ($_[0][0] = '')},
3235 10 0   10   123 '0+' => sub :lvalue {@{$_[0]} ? $_[0][0] : ($_[0][0] = 0)};
  10     0   20  
  10         164  
  0         0  
  0         0  
3236             }
3237            
3238            
3239             =item iterate_stream C< {CODE} [LIMIT] >
3240            
3241             C< iterate_stream > is a version of C< iterate > that does not cache the
3242             generated values. because of this, access to the returned generator must be
3243             monotonically increasing (such as repeated calls to C<< $gen->next >>).
3244            
3245             =cut
3246            
3247             sub iterate_stream (&;$) {
3248 0     0 1 0 my ($code, $size) = (@_, 9**9**9);
3249 0 0 0     0 if (isagen($size) and $size->is_mutable) {
3250 0         0 goto &iterate_multi_stream
3251             }
3252 0         0 tiegen Iterate_Stream => $code, $size
3253             }
3254 10     10   11492 BEGIN {*iterateS = *iterate_stream}
3255             generator Iterate_Stream => sub {
3256 0     0   0 my ($class, $code, $size) = @_;
3257 0         0 my ($last, $from, $source);
3258 0         0 my $pos = 0;
3259 0 0       0 if (isagen($size)) {
3260 0         0 $source = tied(@$size)->can('FETCH');
3261 0         0 $size = $size->size;
3262             }
3263             curse {
3264             FETCH => sub {
3265 0 0   0   0 (my $i = $_[1]) >= $size
3266 0         0 and croak "index $_[1] out of bounds [0 .. @{[$size - 1]}]";
3267 0 0       0 $i < $pos and croak "non-monotone access of stream iterator, idx($i) < pos($pos)";
3268            
3269 0 0 0     0 $pos++, return $$last if $i == 0 and $from;
3270 0         0 local *_;
3271 0   0     0 while ($i >= $pos and $pos < $size) {
3272 0 0       0 *_ = $from ? $last
    0          
3273             : $source ? \$source->(undef, $pos)
3274             : \(0+$pos);
3275 0         0 $last = \$code->();
3276 0         0 $pos++;
3277             }
3278 0 0       0 $pos < $size ? $$last : ()
3279             },
3280 0     0   0 fsize => sub {$size},
3281 0     0   0 index => sub {\$pos},
3282             from => sub {
3283 0 0 0 0   0 croak "can not call ->from on started iterator"
3284             if $pos or $from++;
3285 0 0       0 $last = @_ > 1 ? \$_[1] : \List::Gen::Iterate::Default->new;
3286             },
3287 0         0 } => $class
3288             },
3289 0     0   0 purge => sub {croak 'can not purge iterative generator'};
3290            
3291            
3292             =item iterate_multi C< {CODE} [LIMIT] >
3293            
3294             the same as C, except CODE can return a list of any size. inside CODE,
3295             C<$_> is set to the position in the returned generator where the block's
3296             returned list will be placed.
3297            
3298             the returned generator from C< iterate_multi > can be modified with C,
3299             C, C, C, and C like a normal array. it is up to
3300             you to ensure that the iterative algorithm will still work after modifying the
3301             array.
3302            
3303             the C<< ->from(...) >> method can be called on the returned generator. see
3304             C< iterate > for the rules and effects of this.
3305            
3306             =cut
3307            
3308             sub iterate_multi (&;$) {
3309 2 50   2 1 7 goto &iterate_multi_stream if $STREAM;
3310 2         7 tiegen Iterate_Multi => @_, 9**9**9
3311 10     10   16660 } BEGIN {*iterateM = *iterate_multi}
3312             mutable_gen Iterate_Multi => sub {
3313 2     2   3 my ($class, $code, $size) = @_;
3314 2     0   8 my ($iter, $when_done ) = (0, sub {});
  0         0  
3315 2         4 my ($from, @list, @tails, $source, $mutable);
3316 2 50       6 if (isagen $size) {
3317 0         0 my $src = tied @$size;
3318 0         0 $source = $src->can('FETCH');
3319 0         0 $size = $src->fsize;
3320 0         0 $mutable = $src->mutable;
3321 0 0       0 $src->tail_size($size) if $mutable;
3322             }
3323             curse {
3324             FETCH => sub {
3325 58     58   94 my $i = $_[1];
3326 58         127 while ($i > $#list) {
3327 22 50       50 $iter++ >= $size
3328             and croak "too many iterations requested: ".
3329 0         0 "$iter. index $i out of bounds [0 .. @{[$size - 1]}]";
3330 22 50       93 local *_ = $from ? $list[-1] :
    50          
3331             $source ? \$source->(undef, scalar @list) :
3332             \scalar @list;
3333 22 50       56 eval {push @list, map {ref eq 'List::Gen::Thunk' ? \$$_->() : \$_} $code->(); 1}
  22         66  
  22         81  
3334 22 50 0     32 or catch_done and do {
3335 0 0       0 if (ref $@) {
3336 0 0       0 push @list, map {ref eq 'List::Gen::Thunk' ? \$$_->() : \$_} @{$@};
  0         0  
  0         0  
3337 0         0 $size = @list;
3338 0         0 $$_ = $size for @tails;
3339 0         0 $when_done->();
3340 0 0       0 return ${$list[$i < $#list ? $i : $#list]};
  0         0  
3341             } else {
3342 0         0 $iter--;
3343 0         0 $size = @list;
3344 0         0 $$_ = $size for @tails;
3345 0         0 $when_done->();
3346             return
3347 0         0 }
3348             }
3349             }
3350 58 50       156 if ($size < @list) {
    50          
3351 0         0 $size = @list;
3352 0         0 $$_ = $size for @tails;
3353             }
3354             elsif ($mutable) {
3355 0         0 $$_ = $size for @tails;
3356             }
3357 58         63 ${$list[$i]}
  58         567  
3358             },
3359 2     2   5 fsize => sub {$size},
3360 0     0   0 cached => sub {\@list},
3361             set_size => sub {
3362 0     0   0 $size = int $_[1];
3363 0         0 $$_ = $size for @tails;
3364 0 0       0 $when_done->() if $size == @list
3365             },
3366             _resize => sub {
3367 0 0   0   0 $size += $_[1] if $size < 9**9**9;
3368 0         0 $$_ = $size for @tails;
3369 0         0 $iter += $_[1];
3370             },
3371 0     0   0 _when_done => sub :lvalue {$when_done},
3372             from => sub {
3373 0 0 0 0   0 croak "can not call ->from on started iterator"
3374             if @list or $from++;
3375 0 0       0 push @list, @_ > 1 ? \@_[1..$#_] : \List::Gen::Iterate::Default->new;
3376             },
3377             tail_size => sub {
3378 2     2   7 push @tails, \$_[1]; weaken $tails[-1];
  2         9  
3379             },
3380 2         54 } => $class
3381             },
3382 0     0   0 purge => sub {Carp::croak 'can not purge iterative generator'},
3383 0     0   0 load => sub {push @{$_[0]->cached}, \@_[1..$#_]},
  0         0  
3384             PUSH => sub {
3385 0     0   0 my $self = shift;
3386 0         0 $self->_resize(0+@_);
3387 0         0 push @{$self->cached}, \(@_)
  0         0  
3388             },
3389             UNSHIFT => sub {
3390 0     0   0 my $self = shift;
3391 0         0 $self->_resize(0+@_);
3392 0         0 unshift @{$self->cached}, \(@_)
  0         0  
3393             },
3394             POP => sub {
3395 0     0   0 my $self = shift;
3396 0 0       0 return unless $self->fsize > 0;
3397 0         0 $self->_resize(-1);
3398 0         0 ${pop @{$self->cached}}
  0         0  
  0         0  
3399             },
3400             SHIFT => sub {
3401 0     0   0 my $self = shift;
3402 0 0       0 return unless $self->fsize > 0;
3403 0         0 $self->_resize(-1);
3404 0         0 ${shift @{$self->cached}}
  0         0  
  0         0  
3405             },
3406             SPLICE => sub {
3407 0     0   0 my $self = shift;
3408 0         0 my $list = $self->cached;
3409 0         0 my $size = $self->fsize;
3410 0 0       0 my @ret =
    0          
    0          
3411             @_ == 0 ? splice @$list :
3412             @_ == 1 ? splice @$list, shift :
3413             @_ == 2 ? splice @$list, shift, shift :
3414             splice @$list, shift, shift, \(@_) ;
3415 0         0 $self->_resize(@$list - $size);
3416 0         0 map {$$_} @ret
  0         0  
3417             };
3418            
3419            
3420             =item iterate_multi_stream C< {CODE} [LIMIT] >
3421            
3422             C< iterate_multi_stream > is a version of C< iterate_multi > that does not cache
3423             the generated values. because of this, access to the returned generator must be
3424             monotonically increasing (such as repeated calls to C<< $gen->next >>).
3425            
3426             keyword modification of a stream iterator (with C, C, ...) is not
3427             supported.
3428            
3429             =cut
3430            
3431             sub iterate_multi_stream (&;$) {
3432 0     0 1 0 tiegen Iterate_Multi_Stream => @_, 9**9**9
3433             }
3434 10     10   11856 BEGIN {*iterateMS = *iterate_multi_stream}
3435             mutable_gen Iterate_Multi_Stream => sub {
3436 0     0   0 my ($class, $code, $size) = @_;
3437 0     0   0 my ($pos, $when_done ) = (0, sub {});
  0         0  
3438 0         0 my ($from, @last, @tails, $source, $mutable);
3439 0 0       0 if (isagen $size) {
3440 0         0 $source = tied(@$size)->can('FETCH');
3441 0         0 $mutable = $size->is_mutable;
3442 0         0 $size = $size->size;
3443             }
3444             curse {
3445             FETCH => sub {
3446 0     0   0 my $i = $_[1];
3447 0 0       0 $i < $pos and croak "non-monotone access of iterate multi stream, idx($i) < pos($pos)";
3448 0         0 while ($i >= $pos) {
3449 0 0       0 $pos >= $size and croak "too many iterations requested: ".
3450 0         0 "$pos. index $i out of bounds [0 .. @{[$size - 1]}]";
3451 0 0 0     0 if ($i == $pos and @last) {
3452 0         0 $pos++;
3453             last
3454 0         0 }
3455 0 0       0 if (@last) {
3456 0         0 shift @last;
3457 0         0 $pos++;
3458 0         0 next;
3459             }
3460 0 0       0 local *_ = $from ? $from :
    0          
3461             $source ? \$source->(undef, $pos) :
3462             \$pos;
3463 0 0       0 eval {push @last, map {ref eq 'List::Gen::Thunk' ? \$$_->() : \$_} $code->(); 1}
  0         0  
  0         0  
3464 0 0 0     0 or catch_done and do {
3465 0 0       0 if (ref $@) {
3466 0 0       0 push @last, map {ref eq 'List::Gen::Thunk' ? \$$_->() : \$_} @{$@};
  0         0  
  0         0  
3467 0         0 $size = $pos;
3468 0         0 $$_ = $size for @tails;
3469 0         0 $when_done->();
3470 0         0 return ${shift @last};
  0         0  
3471             } else {
3472 0         0 $size = $pos;
3473 0         0 $$_ = $size for @tails;
3474 0         0 $when_done->();
3475             return
3476 0         0 }
3477             };
3478 0 0       0 $from = $last[-1] if $from;
3479 0         0 $pos++
3480             }
3481 0 0       0 if ($mutable) {
3482 0         0 $$_ = $size for @tails
3483             }
3484 0         0 ${shift @last};
  0         0  
3485             },
3486 0     0   0 fsize => sub {$size},
3487 0     0   0 index => sub {\$pos},
3488             set_size => sub {
3489 0     0   0 $size = int $_[1];
3490 0         0 $$_ = $size for @tails;
3491 0         0 $when_done->();
3492             },
3493 0     0   0 _when_done => sub :lvalue {$when_done},
3494             from => sub {
3495 0 0 0 0   0 croak "can not call ->from on started iterator"
3496             if @last or $from;
3497 0 0       0 push @last, @_ > 1 ? \@_[1..$#_] : \List::Gen::Iterate::Default->new;
3498 0         0 $from = $last[-1];
3499             },
3500             tail_size => sub {
3501 0     0   0 push @tails, \$_[1]; weaken $tails[-1];
  0         0  
3502             },
3503 0         0 } => $class
3504             },
3505 0     0   0 purge => sub {Carp::croak 'can not purge iterative generator'};
3506            
3507            
3508             =item gather C< {CODE} [LIMIT] >
3509            
3510             C< gather > returns a generator that is created iteratively. rather than
3511             returning a value, you call C< take($return_value) > within the C< CODE >
3512             block. note that since perl5 does not have continuations, C< take(...) > does
3513             not pause execution of the block. rather, it stores the return value, the
3514             block finishes, and then the generator returns the stored value.
3515            
3516             you can not import the C< take(...) > function from this module.
3517             C< take(...) > will be installed automatically into your namespace during
3518             the execution of the C< CODE > block. because of this, you must always call
3519             C< take(...) > with parenthesis. C< take > returns its argument unchanged.
3520            
3521             gather implicitly caches its values, this allows random access normally not
3522             possible with an iterative algorithm. the algorithm in C< iterate > is a
3523             bit cleaner here, but C< gather > is slower than C< iterate >, so benchmark
3524             if speed is a concern
3525            
3526             my $fib = do {
3527             my ($x, $y) = (0, 1);
3528             gather {
3529             ($x, $y) = ($y, take($x) + $y)
3530             }
3531             };
3532            
3533             a non-cached version C< gather_stream > is also available, see C< iterate_stream >
3534            
3535             =cut
3536            
3537             sub gather (&;$) {
3538 0     0 1 0 my $code = shift;
3539 0         0 my $take = $code->$cv_local('take');
3540             unshift @_, sub {
3541 0     0   0 my $ret;
3542 10     10   99 no warnings 'redefine';
  10         20  
  10         2017  
3543 0         0 local *$take = sub {$ret = $_[0]};
  0         0  
3544 0         0 $code->();
3545 0         0 $ret
3546 0         0 };
3547 0         0 goto &iterate
3548             }
3549             sub gather_stream (&;$) {
3550 0     0 0 0 local *iterate = *iterate_stream;
3551 0         0 &gather
3552             }
3553 10     10   1172 BEGIN {*gatherS = *gather_stream}
3554            
3555            
3556             =item gather_multi C< {CODE} [LIMIT] >
3557            
3558             the same as C< gather > except you can C< take(...) > multiple times, and each
3559             can take a list. C< gather_multi_stream > is also available.
3560            
3561             =cut
3562            
3563             sub gather_multi (&;$) {
3564 0     0 1 0 my $code = shift;
3565 0         0 my $take = $code->$cv_local('take');
3566             unshift @_, sub {
3567 0     0   0 my @ret;
3568 10     10   76 no warnings 'redefine';
  10         26  
  10         2483  
3569 0 0       0 local *$take = sub {push @ret, @_; wantarray ? @_ : pop};
  0         0  
  0         0  
3570 0         0 eval {$code->(); 1}
  0         0  
  0         0  
3571 0 0 0     0 or catch_done and ref $@ and push @ret, @{$@};
      0        
3572             @ret
3573 0         0 };
  0         0  
3574 0         0 goto &iterate_multi
3575             }
3576             sub gather_multi_stream (&;$) {
3577 0     0 0 0 local *iterate_multi = *iterate_multi_stream;
3578 0         0 &gather_multi
3579             }
3580             BEGIN {
3581 10     10   33 *gatherM = *gather_multi;
3582 10         5634 *gatherMS = *gather_multi_stream
3583             }
3584            
3585            
3586             =item stream C< {CODE} >
3587            
3588             in the C< CODE > block, calls to functions or methods with stream versions will
3589             be replaced by those versions. this applies also to functions that are called
3590             internally by C< List::Gen > (such as in the glob syntax). C< stream > returns
3591             what C< CODE > returns.
3592            
3593             say iterate{}->type; # List::Gen::Iterate
3594             say iterate_stream{}->type; # List::Gen::Iterate_Stream
3595             stream {
3596             say iterate{}->type; # List::Gen::Iterate_Stream
3597             };
3598             say stream{iterate{}}->type; # List::Gen::Iterate_Stream
3599             say stream{<1.. if even>}->type; # List::Gen::Filter_Stream
3600            
3601             placing code inside a C< stream > block is exactly the same as placing
3602             C< local $List::Gen::STREAM = 1; > at the top of a block.
3603            
3604             =cut
3605            
3606             sub stream (&) {
3607 0     0 1 0 local $STREAM = 1;
3608 0         0 $_[0]->()
3609             }
3610            
3611            
3612             =item glob C< STRING >
3613            
3614             =item
3615            
3616             by default, this module overrides perl's default C< glob > function. this is
3617             because the C< glob > function provides the behavior of the angle bracket
3618             delimited C<< <*.ext> >> operator, which is a nice place for inserting list
3619             comprehensions into perl's syntax. the override causes C< glob() > and the
3620             C<< <*.ext> >> operator to have a few special cases overridden, but any case
3621             that is not overridden will be passed to perl's internal C< glob > function
3622             (C<< my @files = <*.txt>; >> works as normal).
3623            
3624             =over 4
3625            
3626             =item * there are several types of overridden operations:
3627            
3628             range: < [prefix,] low .. [high] [by step] >
3629            
3630             iterate: < [prefix,] code ... [size] >
3631            
3632             list comprehension: < [code for] (range|iterate) [if code] [while code] >
3633            
3634             reduction: < \[op|name\] (range|iterate|list comprehension) >
3635            
3636             =item * range strings match the following pattern:
3637            
3638             (prefix,)? number .. number? ((by | += | -= | [-+]) number)?
3639            
3640             here are a few examples of valid ranges:
3641            
3642             <1 .. 10> ~~ range 1, 10
3643             <0 .. > ~~ range 0, 9**9**9
3644             <0 .. *> ~~ range 0, 9**9**9
3645             <1 .. 10 by 2> ~~ range 1, 10, 2
3646             <10 .. 1 -= 2> ~~ range 10, 1, -2
3647             ~~ range 'a', 'z'
3648             ~~ range 'A', 'ZZ'
3649             ~~ range 'a', 9**9**9
3650             ~~ range 'a', 9**9**9, 2
3651             <0, 0..> ~~ [0] + range 0, 9**9**9
3652             <'a','ab', 0..> ~~ ['a','ab'] + range 0, 9**9**9
3653             ~~ [qw(a ab)] + range 0, 9**9**9
3654            
3655             =item * iterate strings match the following pattern:
3656            
3657             (.+? ,)+ (.*[*].* | \{ .+ }) ... number?
3658            
3659             such as:
3660            
3661             my $fib = <0, 1, * + * ... *>;
3662            
3663             which means something like:
3664            
3665             my $fib = do {
3666             my @pre = (0, 1);
3667             my $self;
3668             $self = iterate {
3669             @pre ? shift @pre : $self->get($_ - 2) + $self->get($_ - 1)
3670             } 9**9**9
3671             };
3672            
3673             a few more examples:
3674            
3675             my $fib = <0, 1, {$^a + $^b} ... *>;
3676            
3677             my $fac = <1, * * _ ... *>;
3678            
3679             my $int = <0, * + 1 ... *>;
3680            
3681             my $fib = <0,1,*+*...>; # ending star is optional
3682            
3683             =item * list comprehension strings match:
3684            
3685             ( .+ (for | [:|]) )? (range | iterate) ( (if | unless | [?,]) .+ )?
3686             ( (while | until ) .+ )?
3687            
3688             examples:
3689            
3690             <**2: 1 .. 10> ~~ gen {$_**2} range 1, 10
3691             <**2: 1 .. 10 ? %2> ~~ gen {$_**2} filter {$_ % 2} range 1, 10
3692             ~~ gen {sin} range 0, 3.14, 0.01
3693             <1 .. 10 if % 2> ~~ filter {$_ % 2} range 1, 10
3694             ~~ gen {sin} filter {/5/} range 0, 10, 3
3695             <*3 for 0 .. 10 unless %3> ~~ gen {$_ * 3} filter {not $_ % 3} 0, 10
3696             <0 .. 100 while \< 10> ~~ While {$_ < 10} range 0, 100
3697             <*2 for 0.. if %2 while \<10> ~~ <0..>->grep('%2')->while('<10')->map('*2')
3698            
3699             there are three delimiter types available for basic list comprehensions:
3700            
3701             terse: <*2: 1.. ?%3>
3702             haskell: <*2| 1.., %3>
3703             verbose: <*2 for 1.. if %3>
3704            
3705             you can mix and match C<< <*2 for 1.., %3> >>, C<< <*2| 1.. ?%3> >>
3706            
3707             in the above examples, most of the code areas are using abbreviated syntax.
3708             here are a few equivalencies:
3709            
3710             <*2:1..?%3> ~~ <*2 for 1.. if %3> ~~ <\$_ * 2 for 1 .. * if \$_ % 3>
3711            
3712             <1.. if even> ~~ <1.. if not %2> ~~ <1..?!%2> ~~ <1.. if not _ % 2>
3713             ~~ <1.. unless %2> ~~ <1..* if not \$_ % 2>
3714            
3715             <1.. if %2> ~~ <1.. if _%2> ~~ <1..* ?odd> ~~ <1.. ? \$_ % 2>
3716            
3717             =item * reduction strings match:
3718            
3719             \[operator | function_name\] (range | iterate | list comp)
3720            
3721             examples:
3722            
3723             say <[+] 1..10>; # prints 55
3724            
3725             pre/post fixing the operator with '..' uses the C< scan > function instead of
3726             C< reduce >
3727            
3728             my $fac = <[..*] 1..>; # read as "a running product of one to infinity"
3729            
3730             my $sum = <[+]>; # no argument returns the reduction function
3731            
3732             say $sum->(1 .. 10); # 55
3733             say $sum->(<1..10>); # 55
3734            
3735             my $rev_cat = <[R.]>; # prefix the operator with `R` to reverse it
3736            
3737             say $rev_cat->(1 .. 9); # 987654321
3738            
3739             =item * all of these features can be used together:
3740            
3741             <[+..] *2 for 0 .. 100 by 2 unless %3 >
3742            
3743             which is the same as:
3744            
3745             range(0, 100, 2)->grep('not %3')->map('*2')->scan('+')
3746            
3747             when multiple features are used together, the following construction order is
3748             used:
3749            
3750             1. prefix
3751             2. range or iterate
3752             3. if / unless (grep)
3753             4. while / until (while)
3754             5. for (map)
3755             6. reduce / scan
3756            
3757             ([prefix] + (range|iterate))->grep(...)->while(...)->map(...)->reduce(...)
3758            
3759             =item * bignums
3760            
3761             when run in perl 5.9.4+, glob strings will honor the lexical pragmas C< bignum >,
3762             C< bigint >, and C< bigrat >.
3763            
3764             *factorial = do {use bigint; <[..*] 1, 1..>->code};
3765            
3766             say factorial(25); # 15511210043330985984000000
3767            
3768             =item * special characters
3769            
3770             since the angle brackets (C<< < >> and C<< > >>) are used as delimiters of the
3771             glob string, they both must be escaped with C< \ > if used in the C<< <...> >>
3772             construct.
3773            
3774             <1..10 if \< 5>->say; # 1 2 3 4
3775            
3776             due to C<< <...> >> being a C< qq{} > string, in the code areas if you need to
3777             write C< $_ > write it without the sigil as C< _ >
3778            
3779             <1 .. 10 if _**2 \> 40>->say; # 7 8 9 10
3780            
3781             it can be escaped C< \$_ > as well.
3782            
3783             neither of these issues apply to calling glob directly with a single quoted
3784             string:
3785            
3786             glob('1..10 if $_ < 5')->say; # 1 2 3 4
3787            
3788             =back
3789            
3790             =cut
3791            
3792             my $get_pragma = do {
3793             my @pragmas;
3794             my $init = 1;
3795             sub {
3796             if ($init) {
3797             $init = 0;
3798             @pragmas = grep {$INC{"$_.pm"}} qw (bignum bigint bigrat);
3799             }
3800             return '' if @pragmas == 0 or $] < 5.009004;
3801             my $caller = 1;
3802             $caller++ while (substr caller $caller, 0 => 9) eq 'List::Gen';
3803             join '' => map {
3804             (($_->can('in_effect') or sub{})->($caller + 1)) ? "use $_; " : ''
3805             } @pragmas
3806             }
3807             };
3808            
3809             {
3810             my $number = qr{
3811             (?: - \s* )?
3812             (?:
3813             (?: \d[\d_]* | (?: \d*\.\d+ ) ) (?: e -? \d+ )?
3814             | [a-zA-Z]+?
3815             )
3816             }x;
3817             my $prefix = qr{
3818             (?:
3819             (?: $number | "[^"]+" | '[^']+' | [^,]+ ) \s*
3820             , \s*
3821             )+
3822             }x;
3823             my $build_iterate;
3824             my $glob = sub {glob $_[0]};
3825 10     10   10875 use subs 'glob';
  10         335  
  10         55  
3826             sub glob {
3827 40 50   40   1903 local *_ = @_ ? \"$_[0]" : \"$_";
3828 40         147 s/^\s+|\s+$//g;
3829 40         41 my $reduce;
3830 40         85 my $pkg = $external_package->(1);
3831 40 100       533 if (s{^
3832             \[
3833             ( (?: \\ | \.\.? | , ) (?! \] ) )?
3834             (?:
3835             (?: ( [Rr]{0,1} ) \s* ( $ops ) )
3836             | ( (?=[^Rr0-9_])\w | [a-zA-Z_]\w+ )
3837             )
3838             ( (?: \.\.? | , ) )?
3839             \]
3840             }{}x) {
3841 8   66     52 my ($rev, $op, $word, $scan) = ($2, $3, $4, $1 || $5);
3842 8 50       18 if ($op) {
3843 8 100       22 $op = 'R'.$op if $rev
3844             } else {
3845 0 0       0 if (my $sub = $pkg->can($word)) {
3846 0     0   0 $op = $rev ? sub {$sub->($b, $a)}
3847 0     0   0 : sub {$sub->($a, $b)}
3848 0 0       0 } else {
3849 0         0 croak "subroutine '&${pkg}::$word' not found"
3850             }
3851             }
3852 7     7   30 $reduce = $scan ? sub {$_[0]->scan ($op)}
3853 7     7   28 : sub {$_[0]->reduce($op)}
3854 8 100       58 }
3855 40         88 my $pragma = $get_pragma->();
3856 40 100       1178 if (my ($gen, $pre, $low, $high, $step, $iterate, $filter, $while) = m{^
3857             (?: \s* ( .+? ) \s*
3858             (?: [|:] | \b for \b)
3859             ){0,1} \s*
3860             (?: ( $prefix ) ){0,1} \s*
3861             (?:
3862             ( $number ) \s*
3863             \.\. (?!\.) \s*
3864             ( $number | -?(?:\*|) ) \s*
3865             (?:
3866             (?: \b by \b | [+]= | \+ | (?=-) ) \s*
3867             ( (?: -= \s* )? $number )
3868             )? \s*
3869             |
3870             (.*? \s* \.\.\. \s* (?:$number|\*)?) \s*
3871             )
3872             (?:
3873             (?: \b if \b | (?=\b unless \b) | [?,] ) \s*
3874             ( .+? ) \s*
3875             )?
3876             (
3877             \b (?: while | until ) \b \s*
3878             .+?
3879             )? \s*
3880             $}sxo) {
3881 32 50       108 $filter =~ s/^unless\b/not / if $filter;
3882 32 50 0     73 $while =~ s/^while\s*/not / or
3883             $while =~ s/^until\s*// if $while;
3884 32   50     121 $pre ||= '';
3885 32         37 my $ret;
3886 32 100       47 if ($iterate) {
3887 5         17 $ret = $build_iterate->($pre.$iterate, $pragma, $pkg);
3888 5         10 $pre = '';
3889             } else {
3890 27 100       112 $high = 9**9**9 if $high =~ /^\*?$/;
3891 27 50       98 if ($high eq '-*') {
3892 0         0 $high = -9**9**9;
3893 0   0     0 $step ||= -1;
3894             }
3895 27 50       58 $high = -9**9**9 if $high eq '-*';
3896 27   66     188 $_ and s/_//g, s/^-\s+/-/ for $low, $high, $step;
3897 27 50       62 $step =~ s/^-=\s*/-/ if $step;
3898 27   50     154 $ret = &range($low, $high, $step || 1);
3899             }
3900 32 50       73 if ($pre) {
3901 0         0 $pre =~ s/,\s*$//g;
3902 0         0 $pre = 'prefix'->$eval($pragma."do {[$pre]}");
3903 0 0       0 $ret = $pre + $ret if @$pre;
3904             }
3905 32         166 for ([filter => $filter], [until => $while], [gen => $gen]) {
3906 96 50       212 $$_[1] or next;
3907 0         0 my ($method, $code) = @$_;
3908 0         0 $code =~ s'\b(?:(?
3909 0         0 $ret = $ret->$method($code);
3910             }
3911 32 50       412 $reduce ? $reduce->($ret) : $ret
3912             }
3913             else {
3914             $reduce && !$_ ? sub {
3915 14   66 14   70 $reduce->(@_ == 1 && isagen $_[0] or &makegen(\@_))
3916 8 50 33     74 } : $glob->($_[0])
3917             }
3918             }
3919             $build_iterate = sub {
3920             (local $_, my ($pragma, $pkg)) = @_;
3921             if (my ($x, $n) = /^
3922             ( \w+ | '[^']*' | "[^"]*" )
3923             \s* \.{3} \s*
3924             (\*|\d*)
3925             $/x) {
3926             $n = '' if $n eq '*';
3927             $x =~ s/^('|")(.*)\1$/$2/s;
3928             return repeat($x, length $n ? $n : ())
3929             }
3930             s/$^/\$^/g;
3931             my ($pre, $block, $star, $end) = /^
3932             ($prefix)? \s*
3933             (?: \{ (.*\$\^\w.*) \}
3934             | (
3935             .*(?: \* | \b_\b ).*
3936             | $number
3937             | '(?:[^']|\\')*'
3938             | "(?:[^"]|\\")*"
3939             )
3940             ) \s*
3941             \.{3} \s*
3942             ([\d\*]+ | )
3943             $/xs
3944             or croak "parse error: $_";
3945            
3946             $end = '9**9**9' if $end eq '' or $end eq '*';
3947             $pre ||= '';
3948             my $self;
3949             if ($pre) {
3950             $pre =~ s/,\s*$//g;
3951             $pre = 'prefix '->$eval($pragma."[do {$pre}]");
3952             }
3953             my $i = 1;
3954             my $from;
3955             if ($block) {
3956             $block =~ s'\b(?:\$\^_|(?
3957             for (sort keys %{{$block =~ /((\$\^\w+))/g}}) {
3958             $block =~ s/\Q$_/\$fetch->(undef, \$_ - $i)/g;
3959             $i++;
3960             }
3961             $self = $block;
3962             }
3963             else {
3964             $star =~ s'\b(?
3965            
3966             $star =~ s/(?<=[\*\w\]\}\)])\s*\*\*(?=\s*\S)/{#exp#}/g;
3967            
3968             $i = $star =~ s{
3969             \* (?= \s* ( \*{1,2} \s* \S
3970             | [-+%.\/\)\]\};,]
3971             | $
3972             | \{\#.+?\#\}
3973             )
3974             )} '{*}'gx;
3975             $star =~ s/\{#exp#\}/**/g;
3976             if ($i == 1 and $star !~ /\$_(?:\b|$)/) {
3977             $star =~ s/\Q{*}\E(?=\W|$)/\$_/g;
3978             $star =~ s/\Q{*}/\$_ /g;
3979             $from = 1;
3980             } else {
3981             $star =~ s/\Q{*}/'$fetch->(undef, $_ - '.$i--.')'/ge
3982             }
3983             $self = $star
3984             }
3985             $self = "List::Gen::iterate {package $pkg; $pragma$self} $end";
3986            
3987             'iterate'->$say_eval($self) if $SAY_EVAL or DEBUG;
3988            
3989             my $say = $self =~ /(?:\b|^)say(?:\b|$)/
3990             ? "use feature 'say';"
3991             : '';
3992             my $fetch;
3993             $self = (eval $say.$self
3994             or Carp::croak "iterate error: $@\n$say$self\n");
3995            
3996             return $self->from(@$pre) if $from and $pre;
3997             $self->load(@$pre) if $pre and @$pre;
3998             $fetch = tied(@$self)->can('FETCH');
3999             weaken $fetch;
4000             $self
4001             }}
4002            
4003            
4004             =item List::Gen C< ... >
4005            
4006             the subroutine C< Gen > in the package C< List:: > is a dwimmy function that
4007             produces a generator from a variety of sources. since C< List::Gen > is a fully
4008             qualified name, it is available from all packages without the need to import it.
4009            
4010             if given only one argument, the following table describes what is done:
4011            
4012             array ref: List::Gen \@array ~~ makegen @array
4013             code ref: List::Gen sub {$_**2} ~~ <0..>->map(sub {$_**2})
4014             scalar ref: List::Gen \'*2' ~~ <0..>->map('*2')
4015             glob string: List::Gen '1.. by 2' ~~ <1.. by 2>
4016             glob string: List::Gen '0, 1, *+*' ~~ <0, 1, *+*...>
4017             file handle: List::Gen $fh ~~ file $fh
4018            
4019             if the argument does not match the table, or the method is given more than one
4020             argument, the list is converted to a generator with C< list(...) >
4021            
4022             List::Gen(1, 2, 3)->map('2**')->say; # 2 4 8
4023            
4024             since it results in longer code than any of the equivalent constructs, it is
4025             mostly for if you have not imported anything: C< use List::Gen (); >
4026            
4027             =cut
4028            
4029             sub List::Gen {
4030 1 50   1   2 do {
4031 1 50       4 if (@_ == 0) {'List::Gen'}
  1 0       16  
4032             elsif (@_ == 1) {
4033 0 0       0 if (ref $_[0]) {
  0 0       0  
    0          
4034 0 0       0 if (ref $_[0] eq 'ARRAY' ) {&makegen}
  0 0       0  
  0 0       0  
    0          
    0          
4035 0         0 elsif (ref $_[0] eq 'CODE' ) {&range(0, 9**9**9)->map($_[0])}
4036 0         0 elsif (ref $_[0] eq 'SCALAR') {&range(0, 9**9**9)->map(${$_[0]})}
  0         0  
4037 0         0 elsif (isagen $_[0] ) {$_[0]->copy}
4038             elsif (openhandle $_[0] ) {&file}
4039             }
4040 0         0 elsif ($_[0] =~ /.[.]{2,3}/) {&glob}
4041             elsif ($_[0] =~ /\*/) {&glob($_[0].'...')}
4042             }
4043             } or &list
4044             }
4045 10     10   30127 BEGIN {*List::Generator = *List::Gen}
4046            
4047            
4048             =item vecgen C< [BITS] [SIZE] [DATA] >
4049            
4050             C< vecgen > wraps a bit vector in a generator. BITS defaults to 8. SIZE
4051             defaults to infinite. DATA defaults to an empty string.
4052            
4053             cells of the generator can be assigned to using array dereferencing:
4054            
4055             my $vec = vecgen;
4056             $$vec[3] = 5;
4057            
4058             or with the C<< ->set(...) >> method:
4059            
4060             $vec->set(3, 5);
4061            
4062             =cut
4063            
4064             sub vecgen {
4065 0     0 1 0 tiegen Vec => @_
4066             }
4067             generator Vec => sub {
4068 0     0   0 my ($class, $bits, $size, $str) = @_;
4069 0   0     0 $str ||= '';
4070 0   0     0 $bits ||= 8;
4071 0   0     0 $size ||= 9**9**9;
4072 0     0   0 List::Gen::curse {
4073             FETCH => sub {vec $str, $_[1], $bits},
4074 0     0   0 fsize => sub {$size},
4075 0     0   0 map {$_ => sub {vec($str, $_[1], $bits) = $_[2]}} qw (STORE set)
  0         0  
  0         0  
4076             } => $class
4077             };
4078            
4079            
4080             =item primes
4081            
4082             utilizing the same mechanism as the C<< <1..>->grep('prime') >> construct, the
4083             C< primes > function returns an equivalent, but more efficiently constructed
4084             generator.
4085            
4086             prime numbers below 1e7 are tested with a sieve of eratosthenes and should be
4087             reasonably efficient. beyond that, simple trial division is used.
4088            
4089             C< primes > always returns the same generator.
4090            
4091             =cut
4092            
4093             {
4094             our $DEBUG_PRIME;
4095             BEGIN {
4096             *List::Gen::DEBUG_PRIME = sub () {0}
4097 10 50   10   4338 unless defined &List::Gen::DEBUG_PRIME;
4098             }
4099             my ($max, $prime, $primes_gen) = -1;
4100 0     0   0 sub _reset_prime {$max = -1; $primes_gen = $prime = ''}
  0         0  
4101             my $build = sub {
4102             return if $_[0] < $max;
4103             $max = $_[0] > 1000
4104             ? $_[0] : 1000;
4105             $max = min $max, 1e7;
4106             $prime = '001' . '10' x ($max/2);
4107             my ($n, $i) = 1;
4108             while (($n += 2) < $max) {
4109             if (substr $prime, $n, 1) { init: $i = $n;
4110             substr $prime, $i, 1, 0 while ($i += $n) < $max}}
4111             };
4112             sub primes () {
4113 0   0 0 1 0 $primes_gen ||= do {
4114 0         0 $build->(1000);
4115 0         0 my ($n, $lim, $i) = 2;
4116             &iterate(sub {
4117 0     0   0 if (List::Gen::DEBUG_PRIME and $DEBUG_PRIME) {
4118             return $n++ if $n == 2;
4119 10     10   175 no warnings;
  10         25  
  10         3550  
4120             goto trial_division
4121             }
4122 0 0       0 if ($n < 1e7) {
4123 0   0     0 $n > $max and $build->($n * 10)
4124             until substr $prime, $n++, 1;
4125 0         0 $n - 1
4126             }
4127             else {trial_division:
4128 0         0 while (1) {
4129 0 0       0 $n++, next unless $n & 1;
4130 0         0 ($i, $lim) = (3, 1 + int sqrt $n);
4131 0         0 while ($i < $lim) {
4132 0 0       0 $n % $i or $n++, next trial_division;
4133 0         0 $i += 2;
4134             }
4135 0         0 return $n++
4136             }
4137             }
4138             })
4139 0         0 }
4140             }
4141             $ops{prime} = sub ($) {
4142             my $n = @_ ? $_[0] : $_;
4143             return $n == 2 if not $n & 1 or $n < 2;
4144             if (List::Gen::DEBUG_PRIME and $DEBUG_PRIME) {
4145 10     10   60 no warnings;
  10         25  
  10         27338  
4146             goto trial_division
4147             }
4148             if ($n < 1e7) {
4149             $build->($n * 10) if $n > $max;
4150             substr $prime, $n, 1
4151             }
4152             else {trial_division:
4153             my ($i, $lim) = (1, 1 + int sqrt $n);
4154             $n % $i or return 0 while ($i += 2) < $lim;
4155             1
4156             }
4157             }
4158             }
4159            
4160            
4161             =back
4162            
4163             =head2 modifying generators
4164            
4165             =over 4
4166            
4167             =item slice C< SOURCE_GEN RANGE_GEN >
4168            
4169             C< slice > uses C< RANGE_GEN > to generate the indices used to take a lazy
4170             slice of C< SOURCE_GEN >.
4171            
4172             my $gen = gen {$_ ** 2};
4173            
4174             my $s1 = slice $gen, range 1, 9**9**9;
4175             my $s2 = slice $gen, <1..>;
4176             my $s3 = $gen->slice(<1..>);
4177             my $s4 = $gen->(<1..>);
4178            
4179             $s1 ~~ $s2 ~~ $s3 ~~ $s4 ~~ $gen->tail
4180            
4181             C< slice > will perform some optimizations if it detects that C< RANGE_GEN > is
4182             sufficiently simple (something like C< range $x, $y, 1 >). also, stacked simple
4183             slices will collapse into a single slice, which turns repeated tailing of a
4184             generator into a relatively efficient operation.
4185            
4186             $gen->(<1..>)->(<1..>)->(<1..>) ~~ $gen->(<3..>) ~~ $gen->tail->tail->tail
4187            
4188             =cut
4189            
4190             sub slice {
4191 9     9 1 18 tiegen Slice => @_
4192             }
4193             generator Slice => sub {
4194 9     9   12 my $class = $_[0];
4195 9         10 my $source = tied @{$_[1]};
  9         15  
4196 9         9 my $range = tied @{dwim(@_[2..$#_])};
  9         34  
4197 9         66 my $fetch = $source->can('FETCH');
4198 9 50       40 if (my $ranger = $range->can('range')) {
4199 9         14 my ($drop, $step, $take) = $ranger->();
4200 9 50       21 if ($step == 1) {
4201 9         75 while (my $slicer = $source->can('slice')) {
4202 0         0 my ($pdrop, $ptake) = $slicer->();
4203            
4204 0         0 $take = min $take, $ptake - $drop;
4205 0         0 $drop += $pdrop;
4206            
4207 0         0 $source = $source->source;
4208 0         0 $fetch = $source->can('FETCH');
4209             }
4210 9         20 $take = min $take, $source->fsize - $drop;
4211 9 50       23 $take > 0 or $take = 0;
4212 0     0   0 return curse {
4213             FETCH => ($drop == 0
4214             ? $fetch
4215             : sub {$fetch->(undef, $_[1] + $drop)}),
4216 9     9   18 $source->mutable ? do {
4217 0         0 my $size = $source->fsize;
4218 0         0 $source->tail_size($size);
4219 0     0   0 fsize => sub {min $take, $size - $drop},
4220 0     0   0 mutable => sub {1}
4221 0         0 } : (
4222             fsize => sub {$take}
4223 0     0   0 ),
4224             source => sub {$source},
4225 0     0   0 slice => sub {$drop, $take},
4226 9 50       72 } => $class
    50          
4227             }
4228             }
4229 0         0 my $index = $range->can('FETCH');
4230 0     0   0 curse {
4231             FETCH => sub {$fetch->(undef, $index->(undef, $_[1]))},
4232 0     0   0 source => sub {$source},
4233 0     0   0 $range->mutable ? (
4234             fsize => $range->can('fsize'),
4235             mutable => sub {1}
4236 0 0       0 ) : do {
4237 0         0 my $size = min $range->fsize, $source->fsize - $index->(undef, 0) - 1;
4238 0     0   0 fsize => sub {$size}
4239 0         0 },
4240             } => $class
4241             },
4242 9     9   14 mutable => sub {0};
4243            
4244            
4245             =item test C< {CODE} [ARGS_FOR_GEN] >
4246            
4247             C< test > attaches a code block to a generator. it takes arguments suitable for
4248             the C< gen > function. accessing an element of the returned generator will call
4249             the code block first with the element in C< $_ >, and if it returns true, the
4250             element is returned, otherwise an empty list (undef in scalar context) is
4251             returned.
4252            
4253             when accessing a slice of a tested generator, if you use the C<< ->(x .. y) >>
4254             syntax, the the empty lists will collapse and you may receive a shorter slice.
4255             an array dereference slice will always be the size you ask for, and will have
4256             undef in each failed slot
4257            
4258             the C<< $gen->nxt >> method is a version of C<< $gen->next >> that continues
4259             to call C<< ->next >> until a call returns a value, or the generator
4260             is exhausted. this makes the C<< ->nxt >> method the easiest way to iterate
4261             over only the passing values of a tested generator.
4262            
4263             =cut
4264            
4265             sub test (&;$$$) {
4266 0     0 1 0 my $code = shift;
4267 0 0   0   0 unshift @_, sub {$code->() ? $_ : ()};
  0         0  
4268 0         0 goto &gen
4269             }
4270            
4271            
4272             =item cache C< {CODE} >
4273            
4274             =item cache C< GENERATOR >
4275            
4276             =item cache C<< list => ... >>
4277            
4278             C< cache > will return a cached version of the generators returned by functions
4279             in this package. when passed a code reference, cache returns a memoized code ref
4280             (arguments joined with C< $; >). when in 'list' mode, the source is in list
4281             context, otherwise scalar context is used.
4282            
4283             my $gen = cache gen {slow($_)} \@source; # calls = 0
4284            
4285             print $gen->[123]; # calls += 1
4286             ...
4287             print @$gen[123, 456] # calls += 1
4288            
4289             =cut
4290            
4291             sub cache ($;$) {
4292 0     0 1 0 my $gen = pop;
4293 0         0 my $list = "@_" =~ /list/i;
4294 0 0       0 if (isagen $gen) {
    0          
4295 0         0 tiegen Cache => tied @$gen, $list
4296 0         0 } elsif (ref $gen eq 'CODE') {
4297 0         0 my %cache;
4298 0         0 my $sep = $;;
4299 0   0     0 $list
4300 0     0   0 ? sub {@{$cache{join $sep => @_} ||= cap &$gen}}
4301             : sub {
4302 0     0   0 my $arg = join $sep => @_;
4303 0 0       0 exists $cache{$arg}
4304             ? $cache{$arg}
4305             :($cache{$arg} = &$gen)
4306             }
4307 0 0       0 } else {croak 'cache takes generator or coderef'}
4308             }
4309             generator Cache => sub {
4310 0     0   0 my ($class, $source, $list) = @_;
4311 0         0 my ($fetch, $fsize, %cache) = $source->closures;
4312             curse {
4313             FETCH => (
4314             $list ? sub {
4315 0   0 0   0 @{$cache{$_[1]} ||= cap $fetch->(undef, $_[1])}
  0         0  
4316             } : sub {
4317 0 0   0   0 exists $cache{$_[1]}
4318             ? $cache{$_[1]}
4319             :($cache{$_[1]} = $fetch->(undef, $_[1]))
4320             }
4321 0     0   0 ),
4322             fsize => $fsize,
4323             source => sub {$source},
4324 0     0   0 cached => sub {\%cache},
4325 0 0       0 } => $class
4326             },
4327 0     0   0 purge => sub {%{$_[0]->cached} = ()};
  0         0  
4328            
4329            
4330             =item flip C< GENERATOR >
4331            
4332             C< flip > is C< reverse > for generators. the C<< ->apply >> method is called on
4333             C< GENERATOR >. C<< $gen->flip >> and C<< $gen->reverse >> do the same thing.
4334            
4335             flip gen {$_**2} 0, 10 ~~ gen {$_**2} 10, 0, -1
4336            
4337             =cut
4338            
4339             sub flip ($) {
4340 0 0   0 1 0 croak 'not generator' unless isagen $_[0];
4341 0         0 my $gen = tied @{$_[0]};
  0         0  
4342 0 0       0 $_[0]->apply if $gen->mutable;
4343 0         0 tiegen Flip => $gen
4344             }
4345             generator Flip => sub {
4346 0     0   0 my ($class, $source) = @_;
4347 0         0 my $size = $source->fsize;
4348 0         0 my $end = $size - 1;
4349 0         0 my $fetch = $source->can('FETCH');
4350 0     0   0 curse {
4351             FETCH => sub {$fetch->(undef, $end - $_[1])},
4352 0     0   0 fsize => $source->can('fsize'),
4353             source => sub {$source}
4354 0         0 } => $class
4355             };
4356            
4357            
4358             =item expand C< GENERATOR >
4359            
4360             =item expand C< SCALE GENERATOR >
4361            
4362             C< expand > scales a generator with elements that return equal sized lists. it
4363             can be passed a list length, or will automatically determine it from the length
4364             of the list returned by the first element of the generator. C< expand >
4365             implicitly caches its returned generator.
4366            
4367             my $multigen = gen {$_, $_/2, $_/4} 1, 10; # each element returns a list
4368            
4369             say join ' '=> $$multigen[0]; # 0.25 # only last element
4370             say join ' '=> &$multigen(0); # 1 0.5 0.25 # works
4371             say scalar @$multigen; # 10
4372             say $multigen->size; # 10
4373            
4374             my $expanded = expand $multigen;
4375            
4376             say join ' '=> @$expanded[0 .. 2]; # 1 0.5 0.25
4377             say join ' '=> &$expanded(0 .. 2); # 1 0.5 0.25
4378             say scalar @$expanded; # 30
4379             say $expanded->size; # 30
4380            
4381             my $expanded = expand gen {$_, $_/2, $_/4} 1, 10; # in one line
4382            
4383             C< expand > can also scale a generator that returns array references:
4384            
4385             my $refs = gen {[$_, $_.$_]} 3;
4386            
4387             say $refs->join(', '); # ARRAY(0x272514), ARRAY(0x272524), ARRAY(0x272544)
4388             say $refs->expand->join(', '); # 0, 00, 1, 11, 2, 22
4389            
4390             C< expand > in array ref mode is the same as calling the C<< ->deref >> method.
4391            
4392             =cut
4393            
4394             sub expand ($;$) {
4395 0     0 1 0 my $gen = pop;
4396 0         0 my ($scale, @first);
4397 0 0       0 croak "not generator" unless isagen $gen;
4398 0 0       0 if (@_) {
4399 0         0 $scale = shift;
4400             }
4401             else {
4402 0         0 $scale = @first = $gen->head;
4403 0 0 0     0 if (@first == 1 and ref $first[0] eq 'ARRAY') {
4404 0         0 return $gen->deref
4405             }
4406             }
4407 0         0 tiegen Expand => tied @$gen, $scale, @first
4408             }
4409             generator Expand => sub {
4410 0     0   0 my ($class, $source, $scale) = splice @_, 0, 3;
4411 0         0 my ($fetch, $fsize, %cache) = $source->closures;
4412 0 0       0 @cache{0 .. $#_} = @_ if @_;
4413 0         0 my ($src_i, $ret_i);
4414             curse {
4415             FETCH => sub {
4416 0 0   0   0 unless (exists $cache{$_[1]}) {
4417 0         0 $src_i = int ($_[1] / $scale);
4418 0         0 $ret_i = $src_i * $scale;
4419 0         0 @cache{$ret_i .. $ret_i + $scale - 1} = $fetch->(undef, $src_i);
4420             }
4421 0         0 $cache{$_[1]}
4422             },
4423 0     0   0 fsize => (
4424             $source->mutable
4425             ? sub {$scale * $fsize->()}
4426 0     0   0 : do {
4427 0         0 my $size = $scale * $fsize->();
4428 0     0   0 sub {$size}
4429 0         0 }
4430             ),
4431             source => sub {$source},
4432 0     0   0 cached => sub {\%cache},
4433 0     0   0 purge => sub {%cache = ()},
4434 0 0       0 } => $class
4435             };
4436            
4437            
4438             =item contract C< SCALE GENERATOR >
4439            
4440             C< contract > is the inverse of C< expand >
4441            
4442             also called C< collect >
4443            
4444             =cut
4445            
4446             sub contract ($$) {
4447 0     0 1 0 my ($scale, $gen) = @_;
4448 0 0       0 croak '$_[0] >= 1' if $scale < 1;
4449 0 0       0 croak 'not generator' unless isagen $gen;
4450 0     0   0 $scale == 1
4451             ? $gen
4452 0 0       0 : gen {&$gen($_ .. $_ + $scale - 1)} 0 => $gen->size - 1, $scale
4453             }
4454 10     10   3798 BEGIN {*collect = \&contract}
4455            
4456            
4457             =item scan C< {CODE} GENERATOR >
4458            
4459             =item scan C< {CODE} LIST >
4460            
4461             C< scan > is a C< reduce > that builds a list of all the intermediate values.
4462             C< scan > returns a generator, and is the function behind the C<< <[..+]> >>
4463             globstring reduction operator.
4464            
4465             (scan {$a * $b} <1, 1..>)->say(8); # 1 1 2 6 24 120 720 5040 40320
4466            
4467             say <[..*] 1, 1..>->str(8); # 1 1 2 6 24 120 720 5040 40320
4468            
4469             say <1, 1..>->scan('*')->str(8); # 1 1 2 6 24 120 720 5040 40320
4470            
4471             say <[..*]>->(1, 1 .. 7)->str; # 1 1 2 6 24 120 720 5040 40320
4472            
4473             you can even use the C<< ->code >> method to tersely define a factorial
4474             function:
4475            
4476             *factorial = <[..*] 1, 1..>->code;
4477            
4478             say factorial(5); # 120
4479            
4480             a stream version C< scan_stream > is also available.
4481            
4482             =cut
4483            
4484             sub scan (&@) {
4485 7 50   7 1 18 local *iterate = *iterate_stream if $STREAM;
4486 7         10 my $binop = shift;
4487 7   33     28 my $gen = (@_ == 1 && List::Gen::isagen($_[0]) or &makegen(\@_));
4488 7         13 my $last;
4489 7 50       15 if ($binop->$cv_wants_2_args) {
4490 7 100   58   37 iterate {$last = defined $last ? $binop->($last, $_) : $_} $gen
  58         682  
4491             } else {
4492 0         0 my ($a, $b) = $binop->$cv_ab_ref;
4493 0 0   0   0 iterate {$last = defined $last ? do {
4494 0         0 local (*$a, *$b) = \($last, $_);
4495 0         0 $binop->()
4496 0         0 } : $_} $gen
4497             }
4498             }
4499             sub scan_stream (&@) {
4500 0     0 0 0 local *iterate = *iterate_stream;
4501 0         0 &scan
4502             }
4503 10     10   4985 BEGIN {*scanS = *scan_stream}
4504            
4505            
4506             =item overlay C< GENERATOR PAIRS >
4507            
4508             overlay allows you to replace the values of specific generator cells. to set
4509             the values, either pass the overlay constructor a list of pairs in the form
4510             C<< index => value, ... >>, or assign values to the returned generator using
4511             normal array ref syntax
4512            
4513             my $fib; $fib = overlay gen {$$fib[$_ - 1] + $$fib[$_ - 2]};
4514             @$fib[0, 1] = (0, 1);
4515            
4516             # or
4517             my $fib; $fib = gen {$$fib[$_ - 1] + $$fib[$_ - 2]}
4518             ->overlay( 0 => 0, 1 => 1 );
4519            
4520             print "@$fib[0 .. 15]"; # '0 1 1 2 3 5 8 13 21 34 55 89 144 233 377 610'
4521            
4522             =cut
4523            
4524             sub overlay ($%) {
4525 0 0   0 1 0 isagen (my $source = shift)
4526             or croak '$_[0] to overlay must be a generator';
4527 0         0 tiegen Overlay => tied @$source, @_
4528             }
4529             generator Overlay => sub {
4530 0     0   0 my ($class, $source, %overlay) = @_;
4531 0         0 my ($fetch, $fsize) = $source->closures;
4532             curse {
4533             FETCH => sub {
4534 0 0   0   0 exists $overlay{$_[1]}
4535             ? $overlay{$_[1]}
4536             : $fetch->(undef, $_[1])
4537             },
4538 0     0   0 STORE => sub {$overlay{$_[1]} = $_[2]},
4539 0     0   0 fsize => $fsize,
4540             source => sub {$source}
4541 0         0 } => $class
4542             };
4543            
4544            
4545             =item recursive C< [NAME] GENERATOR >
4546            
4547             C< recursive > defines a subroutine named C< self(...) > or C< NAME(...) >
4548             during generator execution. when called with no arguments it returns the
4549             generator. when called with one or more numeric arguments, it fetches those
4550             indices from the generator. when called with a generator, it returns a lazy
4551             slice from the source generator. since the subroutine created by C< recursive >
4552             is installed at runtime, you must call the subroutine with parenthesis.
4553            
4554             my $fib = gen {self($_ - 1) + self($_ - 2)}
4555             ->overlay( 0 => 0, 1 => 1 )
4556             ->cache
4557             ->recursive;
4558            
4559             print "@$fib[0 .. 15]"; # '0 1 1 2 3 5 8 13 21 34 55 89 144 233 377 610'
4560            
4561             when used as a method, C<< $gen->recursive >> can be shortened to C<< $gen->rec >>.
4562            
4563             my $fib = ([0, 1] + iterate {sum fib($_, $_ + 1)})->rec('fib');
4564            
4565             print "@$fib[0 .. 15]"; # '0 1 1 2 3 5 8 13 21 34 55 89 144 233 377 610'
4566            
4567             of course the fibonacci sequence is better written with the glob syntax as
4568             C<< <0, 1, *+*...> >> which is compiled into something similar to the example
4569             with C< iterate > above.
4570            
4571             =cut
4572            
4573             sub recursive {
4574 0 0   0 1 0 isagen (my $source = pop)
4575             or croak '$_[0] to recursive must be a generator';
4576 0         0 tiegen Recursive => $source, tied @$source, scalar caller, @_;
4577             }
4578             generator Recursive => sub {
4579 0     0   0 my ($class, $gen, $source) = @_;
4580 0         0 my ($fetch, $fsize) = $source->closures;
4581 0         0 my $caller = do {
4582 10     10   90 no strict 'refs';
  10         21  
  10         1442  
4583 0 0       0 \*{$_[3].'::'.(@_ > 4 ? $_[4] : 'self')}
  0         0  
4584             };
4585 0         0 my $code = $gen->code;
4586 0 0   0   0 my $self = sub {@_ ? &$code : $gen};
  0         0  
4587             curse {
4588             FETCH => sub {
4589 10     10   59 no warnings 'redefine';
  10         26  
  10         9181  
4590 0     0   0 local *$caller = $self;
4591 0         0 $fetch->(undef, $_[1])
4592             },
4593 0     0   0 fsize => $fsize,
4594             source => sub {$source}
4595 0         0 } => $class
4596             };
4597            
4598            
4599             =back
4600            
4601             =head2 mutable generators
4602            
4603             =over 4
4604            
4605             =item filter C< {CODE} [ARGS_FOR_GEN] >
4606            
4607             C< filter > is a lazy version of C< grep > which attaches a code block to a
4608             generator. it returns a generator that will test elements with the code
4609             block on demand. C< filter > processes its argument list the same way C< gen >
4610             does.
4611            
4612             C< filter > provides the functionality of the identical C<< ->filter(...) >> and
4613             C<< ->grep(...) >> methods.
4614            
4615             normal generators, such as those produced by C< range > or C< gen >, have a
4616             fixed length, and that is used to allow random access within the range. however,
4617             there is no way to know how many elements will pass a filter. because of this,
4618             random access within the filter is not always C< O(1) >. C< filter > will
4619             attempt to be as lazy as possible, but to access the 10th element of a filter,
4620             the first 9 passing elements must be found first. depending on the coderef and
4621             the source, the filter may need to process significantly more elements from its
4622             source than just 10.
4623            
4624             in addition, since filters don't know their true size, entire filter arrays do
4625             not expand to the correct number of elements in list context. to correct this,
4626             call the C<< ->apply >> method which will test the filter on all of its source
4627             elements. after that, the filter will return a properly sized array. calling
4628             C<< ->apply >> on an infinite (or very large) range wouldn't be a good idea. if
4629             you are using C<< ->apply >> frequently, you should probably just be using
4630             C< grep >. you can call C<< ->apply >> on any stack of generator functions, it
4631             will start from the deepest filter and move up.
4632            
4633             the method C<< ->all >> will first call C<< ->apply >> on itself and then return
4634             the complete list
4635            
4636             filters implicitly cache their values. accessing any element below the highest
4637             element already accessed is C< O(1) >.
4638            
4639             accessing individual elements or slices works as you would expect.
4640            
4641             my $filter = filter {$_ % 2} 0, 100;
4642            
4643             say $#$filter; # incorrectly reports 100
4644            
4645             say "@$filter[5 .. 10]"; # reads the source range up to element 23
4646             # prints 11 13 15 17 19 21
4647            
4648             say $#$filter; # reports 88, closer but still wrong
4649            
4650             $filter->apply; # reads remaining elements from the source
4651            
4652             say $#$filter; # 49 as it should be
4653            
4654             note: C< filter > now reads one element past the last element accessed, this
4655             allows filters to behave properly when dereferenced in a foreach loop (without
4656             having to call C<< ->apply >>). if you prefer the old behavior, set
4657             C< $List::Gen::LOOKAHEAD = 0 > or use C< filter_ ... >
4658            
4659             =cut
4660            
4661             sub filter (&;$$$) {
4662 0 0   0 1 0 goto &filter_stream if $STREAM;
4663 0         0 tiegen Filter => shift, tied @{&dwim}
  0         0  
4664             }
4665             mutable_gen Filter => sub {
4666 0     0   0 my ($class, $check, $source) = @_;
4667 0         0 my ($fetch, $fsize) = $source->closures;
4668 0         0 my ($size, $src_size) = ($fsize->()) x 2;
4669 0 0       0 if ($source->mutable) {
4670 0         0 $source->tail_size($src_size)
4671             }
4672 0     0   0 my $when_done = sub {};
  0         0  
4673 0         0 my ($pos, @list, @tails) = 0;
4674 0   0     0 my $lookahead = $LOOKAHEAD || 0;
4675             curse {
4676             FETCH => sub {
4677 0     0   0 my $i = $_[1];
4678 0 0       0 unless ($i < $size) {
4679 0         0 croak "filter index '$i' out of range [0 .. ".($size - 1).']';
4680             }
4681 0         0 local *_;
4682 0         0 while ($#list < $i + $lookahead) {
4683 0 0       0 if ($pos < $src_size) {
4684 0         0 *_ = \$fetch->(undef, $pos);
4685 0 0 0     0 if ($pos < $src_size and $check->()) {
4686 0         0 push @list, \$_;
4687             }
4688 0         0 $pos++
4689             }
4690             else {
4691 0         0 $size = @list;
4692 0         0 $$_ = $size for @tails;
4693 0         0 $when_done->();
4694 0 0       0 $i <= $#list ? last : return
4695             }
4696             }
4697 0 0       0 $size = $pos < $src_size
4698             ? @list + ($src_size - $pos)
4699             : @list;
4700 0         0 $$_ = $size for @tails;
4701            
4702 0         0 ${ $list[$i] }
  0         0  
4703             },
4704 0     0   0 fsize => sub {$size},
4705 0     0   0 tail_size => sub {push @tails, \$_[1]; weaken $tails[-1]},
  0         0  
4706 0     0   0 source => sub {$source},
4707 0     0   0 _when_done => sub :lvalue {$when_done},
4708 0         0 } => $class
4709             };
4710            
4711             sub filter_ (&;$$$) {
4712 0     0 0 0 local $LOOKAHEAD;
4713 0         0 &filter
4714             }
4715            
4716            
4717             =item filter_stream C< {CODE} ... >
4718            
4719             as C< filter > runs, it builds up a cache of the elements that pass the filter.
4720             this enables efficient random access in the returned generator. sometimes this
4721             caching behavior causes certain algorithms to use too much memory.
4722             C< filter_stream > is a version of C< filter > that does not maintain a cache.
4723            
4724             normally, access to C< *_stream > iterators must be monotonically increasing
4725             since their source can only produce values in one direction. filtering is a
4726             reversible algorithm, and subsequently filter streams are able to rewind
4727             themselves to any previous index. however, unlike C< filter >, the
4728             C< filter_stream > generator must test previously tested elements to rewind.
4729             things probably wont end well if the test code is non-deterministic or if the
4730             source values are changing.
4731            
4732             when used as a method, it can be spelled C<< $gen->filter_stream(...) >> or
4733             C<< $gen->grep_stream(...) >>
4734            
4735             =cut
4736            
4737             sub filter_stream (&;$$$) {
4738 0     0 1 0 tiegen Filter_Stream => shift, tied @{&dwim}
  0         0  
4739             }
4740 10     10   11267 BEGIN {*filterS = *filter_stream}
4741            
4742             mutable_gen Filter_Stream => sub {
4743 0     0   0 my ($class, $code, $src) = @_;
4744 0     0   0 my ($when_done, @tails ) = sub {};
  0         0  
4745 0     0   0 my $rewind = sub {};
  0         0  
4746 0         0 my $idx = 0;
4747 0         0 my $fetch = $src->can('FETCH');
4748 0         0 my $size =
4749             my $src_size = $src->fsize;
4750 0 0       0 $src->tail_size($src_size) if $src->mutable;
4751 0         0 my @window;
4752 0         0 my $pos = 0;
4753 0         0 my $index = 0;
4754 0         0 my ($next, $prev) = do {
4755 10     10   77 no warnings 'exiting';
  10         22  
  10         17433  
4756             sub {
4757 0     0   0 while ($pos < $src_size) {
4758 0         0 *_ = \$fetch->(undef, $pos);
4759 0 0       0 $pos < $src_size or last;
4760 0         0 $pos++;
4761 0 0       0 if (&$code) {
4762 0         0 $idx++;
4763 0 0       0 $pos = $src_size if $pos > $src_size;
4764 0         0 return $_
4765             }
4766             }
4767 0         0 $pos = $src_size;
4768             last outer
4769 0         0 },
4770             sub {
4771 0     0   0 while ($pos > 0) {
4772 0         0 *_ = \$fetch->(undef, --$pos);
4773 0 0       0 if (&$code) {
4774 0         0 $idx--;
4775 0 0       0 $index = $idx = $pos = 0 if $pos < 0;
4776 0         0 return $_
4777             }
4778             }
4779 0         0 $index = $idx = $pos = 0;
4780             last outer
4781 0         0 }
4782 0         0 };
4783 0         0 my $last;
4784             curse {
4785             FETCH =>
4786             ($LOOKAHEAD and ! $src->can('index')
4787             || $src->isa($class))
4788             ? sub {
4789 0     0   0 my ($want, $ret) = $_[1];
4790 0         0 outer: {
4791 0         0 local *_;
4792 0 0       0 if ($idx > $want) {
4793 0         0 while ($idx > $want) {
4794 0         0 undef $ret;
4795 0         0 $ret = $prev->();
4796 0         0 $index--;
4797             }
4798             }
4799             else {
4800 0         0 my $end = $want + 1;
4801 0         0 while ($idx <= $end) {
4802 0         0 $ret = $last;
4803 0         0 undef $last;
4804 0         0 $last = $next->();
4805 0         0 $index++;
4806             }
4807             }
4808             }
4809 0         0 for ($src_size - $pos + $idx) {
4810 0 0       0 if ($size > $_) {
4811 0         0 $size = $_;
4812 0 0       0 $size = $idx if $pos == $src_size;
4813 0         0 $$_ = $size for @tails;
4814             }
4815             }
4816 0 0       0 defined $ret ? $ret : ()
4817             }
4818             : sub {
4819 0     0   0 my ($want, $ret) = $_[1];
4820 0         0 outer: {
4821 0         0 local *_;
4822 0 0       0 if ($idx > $want) {$ret = $prev->() while $idx > $want}
  0 0       0  
  0 0       0  
4823 0         0 elsif ($idx == $want) {$ret = $next->() }
4824             elsif ($idx < $want) {$ret = $next->() while $idx <= $want}
4825             }
4826 0         0 $index = $idx;
4827 0         0 for ($src_size - $pos + $idx) {
4828 0 0       0 if ($size > $_) {
4829 0         0 $size = $_;
4830 0         0 $$_ = $size for @tails;
4831             }
4832             }
4833 0 0       0 defined $ret ? $ret : ()
4834             },
4835 0     0   0 fsize => sub {$size},
4836 0     0   0 tail_size => sub {push @tails, \$_[1]; &weaken($tails[-1])},
  0         0  
4837 0     0   0 _when_done => sub :lvalue {$when_done},
4838 0     0   0 rewind => $rewind,
4839             index => sub {\$index},
4840 0 0 0     0 } => $class;
4841             };
4842            
4843            
4844             =item While C<< {CODE} GENERATOR >>
4845            
4846             =item Until C<< {CODE} GENERATOR >>
4847            
4848             C<< While / ->while(...) >> returns a new generator that will end when its
4849             passed in subroutine returns false. the C< until > pair ends when the subroutine
4850             returns true.
4851            
4852             if C< $List::Gen::LOOKAHEAD > is true (the default), each reads one element past
4853             its requested element, and saves this value only until the next call for
4854             efficiency, no other values are saved. each supports random access, but is
4855             optimized for sequential access.
4856            
4857             these functions have all of the caveats of C< filter >, should be considered
4858             experimental, and may change in future versions. the generator returned should
4859             only be dereferenced in a C< foreach > loop, otherwise, just like a C< filter >
4860             perl will expand it to the wrong size.
4861            
4862             the generator will return undef the first time an access is made and the check
4863             code indicates it is past the end.
4864            
4865             the generator will throw an error if accessed beyond its dynamically found limit
4866             subsequent times.
4867            
4868             my $pow = While {$_ < 20} gen {$_**2};
4869             <0..>->map('**2')->while('< 20')
4870            
4871             say for @$pow;
4872            
4873             prints:
4874            
4875             0
4876             1
4877             4
4878             9
4879             16
4880            
4881             in general, it is faster to write it this way:
4882            
4883             my $pow = gen {$_**2};
4884             $gen->do(sub {
4885             last if $_ > 20;
4886             say;
4887             });
4888            
4889             =cut
4890            
4891             sub While (&$) {
4892 0     0 1 0 my ($code, $source) = @_;
4893 0 0       0 isagen $source
4894             or croak '$_[1] to While must be a generator';
4895 0         0 tiegen While => tied @$source, $code
4896             }
4897             sub Until (&$) {
4898 0     0 1 0 my ($code, $source) = @_;
4899 0 0       0 isagen $source
4900             or croak '$_[1] to Until must be a generator';
4901 0     0   0 tiegen While => tied @$source, sub {not &$code}
4902 0         0 }
4903 0     0 0 0 sub while_ (&$) {local $LOOKAHEAD; &While}
  0         0  
4904 0     0 0 0 sub until_ (&$) {local $LOOKAHEAD; &Until}
  0         0  
4905            
4906             BEGIN {
4907 10     10   44 *take_while = *While;
4908 10         25662 *take_until = *Until;
4909             }
4910            
4911 0     0 0 0 sub drop_while (&$) {$_[1]->drop_while($_[0])}
4912 0     0 0 0 sub drop_until (&$) {$_[1]->drop_until($_[0])}
4913            
4914             mutable_gen While => sub {
4915 0     0   0 my ($class, $source, $check) = @_;
4916 0         0 my ($fetch, $fsize) = $source->closures;
4917 0         0 my ($size, $src_size) = ($fsize->()) x 2;
4918 0 0       0 if ($source->mutable) {
4919 0         0 $source->tail_size($src_size)
4920             }
4921 0         0 my $lookahead = $LOOKAHEAD;
4922 0         0 my (@next, @tails) = -1;
4923 0     0   0 my $when_done = sub {};
  0         0  
4924             my $done = sub {
4925 0     0   0 $size = $_[0];
4926 0         0 $$_ = $size for @tails;
4927 0         0 $when_done->();
4928 0         0 @next = -1;
4929             return
4930 0         0 };
  0         0  
4931             curse {
4932             FETCH => sub {
4933 0     0   0 my $i = $_[1];
4934 0 0       0 unless ($i < $size) {
4935 0         0 croak "while/until: index '$i' past end '".($size - 1)."'"
4936             }
4937 0 0       0 if ($i < $src_size) {
4938 0 0       0 local *_ = $i == $next[0] ? $next[1] : \$fetch->(undef, $i);
4939 0 0 0     0 return $done->($i) unless $i < $src_size and $check->();
4940            
4941 0 0 0     0 if ($lookahead and $i + 1 < $src_size) {
4942 0         0 local *_ = \$fetch->(undef, $i + 1);
4943 0 0 0     0 if ($i + 1 < $src_size and $check->()) {
4944 0         0 @next = ($i + 1, \$_)
4945             }
4946             else {
4947 0         0 $done->($i + 1)
4948             }
4949             }
4950 0         0 return $_
4951             }
4952             else {
4953 0         0 $done->($src_size)
4954             }
4955             },
4956 0     0   0 fsize => sub {$size},
4957 0     0   0 tail_size => sub {push @tails, \$_[1]; weaken $tails[-1]},
  0         0  
4958 0     0   0 source => sub {$source},
4959 0     0   0 _when_done => sub :lvalue {$when_done},
4960 0         0 } => $class
4961             };
4962            
4963            
4964             =item mutable C< GENERATOR >
4965            
4966             =item C<< $gen->mutable >>
4967            
4968             C< mutable > takes a single fixed size (immutable) generator, such as those
4969             produced by C< gen > and converts it into a variable size (mutable) generator,
4970             such as those returned by C< filter >.
4971            
4972             as with filter, it is important to not use full array dereferencing (C< @$gen >)
4973             with mutable generators, since perl will expand the generator to the wrong size.
4974             to access all of the elements, use the C<< $gen->all >> method, or call
4975             C<< $gen->apply >> before C< @$gen >. using a slice C< @$gen[5 .. 10] > is
4976             always ok, and does not require calling C<< ->apply >>.
4977            
4978             mutable generators respond to the C< List::Gen::Done > exception, which can be
4979             produced with either C< done >, C< done_if >, or C< done_unless >. when the
4980             exception is caught, it causes the generator to set its size, and it also
4981             triggers any C<< ->when_done >> actions.
4982            
4983             my $gen = mutable gen {done if $_ > 5; $_**2};
4984            
4985             say $gen->size; # inf
4986             say $gen->str; # 0 1 4 9 16 25
4987             say $gen->size; # 6
4988            
4989             generators returned from C< mutable > have a C<< ->set_size(int) >> method
4990             that will set the generator's size and then trigger any
4991             C<< ->when_done(sub{...}) >> methods.
4992            
4993             =cut
4994            
4995             sub mutable {
4996 0 0   0 1 0 tiegen Mutable => tied @{isagen $_[0] or croak "var takes a generator"}
  0         0  
4997             }
4998             generator Mutable => sub {
4999 0     0   0 my ($class, $source ) = @_;
5000 0         0 my ($fetch, $fsize ) = $source->closures;
5001 0     0   0 my ($when_done, $size) = sub {};
  0         0  
5002             curse {
5003             FETCH => sub {
5004 0 0 0 0   0 defined $size and $_[1] >= $size
5005 0         0 and croak "index $_[1] out of bounds [0 .. ${\($size - 1)}";
5006            
5007 0         0 my $ret = eval {cap($fetch->(undef, $_[1]))}
5008             or catch_done and ref $@ ? do {
5009 0         0 my $val = $@;
5010 0         0 $size = $_[1] + 1;
5011 0         0 $when_done->();
5012 0 0       0 return wantarray ? @$val : pop @$val
5013 0 0 0     0 } : do {
    0          
5014 0         0 $size = $_[1];
5015 0         0 $when_done->();
5016             return
5017 0         0 };
5018 0 0       0 wantarray ? @$ret : pop @$ret
5019             },
5020 0 0   0   0 fsize => $source->mutable
5021             ? sub {defined $size ? $size : $fsize->()}
5022 0 0   0   0 : sub {defined $size ? $size : ($size = $fsize->())},
5023 0     0   0 set_size => sub {$size = int $_[1]; $when_done->()},
  0         0  
5024 0     0   0 _when_done => sub :lvalue {$when_done},
5025 0     0   0 source => sub {$source},
5026 0 0       0 } => $class
5027             },
5028             when_done => sub {
5029 0     0   0 my ($self, @next) = @_;
5030 0         0 my $when_done = $self->_when_done;
5031 0 0       0 if (@next) {
  0         0  
5032             $self->_when_done = sub {
5033 0     0   0 $_->($self) for $when_done, @next;
5034             }
5035 0         0 } else {$when_done}
5036             },
5037             clear_done => sub {
5038 0     0   0 $_[0]->_when_done = sub {};
  0         0  
5039 0         0 $_[0]
5040             },
5041             mutable => sub () {1},
5042             apply => sub {
5043 0     0   0 my $self = shift;
5044 0         0 my $code = $self->can('FETCH');
5045 0         0 my ($i, $ok) = (0, 1);
5046 0     0   0 $self->when_done(sub{undef $ok});
  0         0  
5047 0         0 my $size = $self->fsize;
5048 0   0     0 $code->(undef, $i++) while $ok and $i < $size;
5049 0 0       0 $self->when_done->() if $ok;
5050 0         0 $self->clear_done
5051             };
5052            
5053            
5054             =item done C< [LAST_RETURN_VALUE] >
5055            
5056             throws an exception that will be caught by a mutable generator indicating that
5057             the generator should set its size. if a value is passed to done, that will be
5058             the final value returned by the generator, otherwise, the final value will be
5059             the value returned on the previous call.
5060            
5061             =cut
5062            
5063 0     0 1 0 sub done {die bless [@_] => 'List::Gen::Done'}
5064             sub catch_done () {
5065 0         0 ref $@
5066             ? ref $@ eq 'List::Gen::Done'
5067 0 0   0 0 0 ? @{$@} ? [@{$@}] : eval {1}
  0 0       0  
  0 0       0  
5068             : die $@
5069             : croak $@
5070             }
5071            
5072            
5073             =item done_if C< COND VALUE >
5074            
5075             =item done_unless C< COND VALUE >
5076            
5077             these are convenience functions for throwing C< done > exceptions. if the
5078             condition does not indicate C< done > then the function returns C< VALUE >
5079            
5080             =cut
5081            
5082 0 0   0 1 0 sub done_if ($@) { shift @_ ? &done : wantarray ? @_ : pop}
    0          
5083 0 0   0 1 0 sub done_unless ($@) {!shift @_ ? &done : wantarray ? @_ : pop}
    0          
5084            
5085            
5086             =item strict C< {CODE} >
5087            
5088             in the C< CODE > block, calls to functions or methods are subject to the
5089             following localizations:
5090            
5091             =over 4
5092            
5093             =item * C< local $List::Gen::LOOKAHEAD = 0; >
5094            
5095             the functions C< filter >, C< While > and their various forms normally stay an
5096             element ahead of the last requested element so that an array dereference in a
5097             C< foreach > loop ends properly. this localization disables this behavior, which
5098             might be needed for certain algorithms. it is therefore important to never
5099             write code like: C< for(@$strict_filtered){...} >, instead write
5100             C<< $strict_filtered->do(sub{...}) >> which is faster as well. the following
5101             code illustrates the difference in behavior:
5102            
5103             my $test = sub {
5104             my $loud = filter {print "$_, "; $_ % 2};
5105             print "($_:", $loud->next, '), ' for 0 .. 2;
5106             print $/;
5107             };
5108             print 'normal: '; $test->();
5109             print 'strict: '; strict {$test->()};
5110            
5111             normal: 0, 1, 2, 3, (0:1), 4, 5, (1:3), 6, 7, (2:5),
5112             strict: 0, 1, (0:1), 2, 3, (1:3), 4, 5, (2:5),
5113            
5114             =item * C< local $List::Gen::DWIM_CODE_STRINGS = 0; >
5115            
5116             in the dwim C<< $gen->(...) >> code deref syntax, if C< $DWIM_CODE_STRINGS > has
5117             been set to a true value, bare strings that look like code will be interpreted
5118             as code and passed to C< gen > (string refs to C< filter >). since this
5119             behavior is fun for golf, but potentially error prone, it is off by default.
5120             C< strict > turns it back off if it had been turned on.
5121            
5122             =back
5123            
5124             C< strict > returns what C< CODE > returns. C< strict > may have additional
5125             restrictions added to it in the future.
5126            
5127             =cut
5128            
5129             sub strict (&) {
5130 0     0 1 0 local $STRICT = 1;
5131 0         0 local $LOOKAHEAD = 0;
5132 0         0 local $DWIM_CODE_STRINGS = 0;
5133 0         0 $_[0]->()
5134             }
5135            
5136            
5137             =back
5138            
5139             =head2 combining generators
5140            
5141             =over 4
5142            
5143             =item sequence C< LIST >
5144            
5145             string generators, arrays, and scalars together.
5146            
5147             C< sequence > provides the functionality of the overloaded C< + > operator on
5148             generators:
5149            
5150             my $seq = <1 .. 10> + <20 .. 30> + <40 .. 50>;
5151            
5152             is exactly the same as:
5153            
5154             my $seq = sequence <1 .. 10>, <20 .. 30>, <40 .. 50>;
5155            
5156             you can even write things like:
5157            
5158             my $fib; $fib = [0, 1] + iterate {sum $fib->($_, $_ + 1)};
5159            
5160             say "@$fib[0 .. 10]"; # 0 1 1 2 3 5 8 13 21 34 55
5161            
5162             =cut
5163            
5164             {
5165             sub sequence {
5166 0     0 1 0 tiegen Sequence => @_
5167             }
5168             my %seq_const;
5169             BEGIN {
5170 10     10   92 %seq_const = (
5171             FETCH => 0,
5172             SIZE => 1, LOW => 1,
5173             MUTABLE => 2, HIGH => 2,
5174             );
5175 10   50     1120 eval "sub $_ () {$seq_const{$_}} 1" or die $@ for keys %seq_const
5176             }
5177             generator Sequence => sub {
5178 0     0   0 my $class = shift;
5179 0         0 my $size = 0;
5180 0     0   0 my @sequence = map {
5181 0 0 0     0 (isagen) ? @{(tied(@$_)->can('sequence') or sub {[$_]})->()}
  0 0       0  
  0         0  
5182             : ref eq 'ARRAY' ? makegen @$_ : &makegen([$_])
5183             } @_;
5184 0         0 my $mutable;
5185             my @source;
5186             my $build = sub {
5187 0     0   0 $mutable = first {$_->is_mutable} @sequence;
  0         0  
5188 0 0       0 @source = map {
5189 0         0 $mutable ? [tied(@$_)->closures, $_->is_mutable]
5190             : [tied(@$_)->{FETCH}, $size+0, $size += $_->size]
5191             } @sequence;
5192 0 0       0 $size = 9**9**9 if $mutable;
5193 0         0 };
5194 0         0 $build->();
5195             curse {
5196             FETCH => $mutable ? sub {
5197 0     0   0 my $i = $_[1];
5198 0 0       0 croak "sequence index $i out of bounds [0 .. @{[$size - 1]}]"
  0         0  
5199             if $i >= $size;
5200 0         0 my $depth = 0;
5201 0         0 for (@source) {
5202 0         0 my $cur_size = $$_[SIZE]->();
5203 0 0       0 if (($depth + $cur_size) > $i) {
5204 0 0       0 if ($$_[MUTABLE]) {
5205 0         0 my $got = \$$_[FETCH]->(undef, $i - $depth);
5206 0         0 $cur_size = $$_[SIZE]->();
5207 0 0       0 return $$got if ($depth + $cur_size) > $i;
5208             } else {
5209 0         0 return $$_[FETCH]->(undef, $i - $depth)
5210             }
5211             }
5212 0         0 $depth += $cur_size;
5213             }
5214 0         0 $size = $depth;
5215 0         0 return;
5216 0     0   0 } : do {
5217 0         0 my $pos = $#source >> 1;
5218 0         0 my $src = $source[$pos];
5219 0         0 my $i;
5220 0         0 my ($min, $max);
5221             sub {
5222 0     0   0 $i = $_[1];
5223 0 0       0 croak "sequence index $i out of bounds [0 .. @{[$size - 1]}]"
  0         0  
5224             if $i >= $size;
5225 0         0 $min = 0;
5226 0         0 $max = $#source;
5227 0         0 while ($min <= $max) {
5228 0 0       0 if ($$src[HIGH] <= $i) {$min = $pos + 1}
  0 0       0  
  0         0  
5229             elsif ($$src[LOW] > $i) {$max = $pos - 1}
5230             else {
5231 0         0 return $$src[FETCH]->(undef, $i - $$src[LOW])
5232             }
5233 0         0 $pos = ($min + $max) >> 1;
5234 0         0 $src = $source[$pos];
5235             }
5236 0         0 croak "sequence error at index: $i"
5237             }
5238 0         0 },
5239             fsize => sub {$size},
5240 0     0   0 sequence => sub {\@sequence},
5241 0     0   0 $mutable ? (mutable => sub {1}) : (),
5242             rebuild => $build,
5243 0 0       0 source => do {
    0          
5244 0         0 my @src = map tied @$_, @sequence;
5245 0     0   0 sub {\@src}
5246 0         0 },
5247             } => $class
5248 0     0   0 }, mutable => sub {0};
5249 10     10   1588 BEGIN {delete $List::Gen::{$_} for keys %seq_const}
5250             }
5251            
5252            
5253             =item zipgen C< LIST >
5254            
5255             C< zipgen > is a lazy version of C< zip >. it takes any combination of
5256             generators and array refs and returns a generator. it is called automatically
5257             when C< zip > is used in scalar context.
5258            
5259             C< zipgen > can be spelled C< genzip >
5260            
5261             =cut
5262            
5263             sub zipgen {
5264 2 50   2 1 6 tiegen Zip => map tied @{isagen or makegen @$_} => @_
  4         10  
5265             }
5266 10     10   63358 BEGIN {*genzip = *zipgen}
5267             generator Zip => sub {
5268 2     2   6 my ($class, @src) = @_;
5269 2         33 my @fetch = map $_->can('FETCH') => @src;
5270 2         14 my @size = map $_->can('fsize') => @src;
5271 2   50     16 my @mutable = map $_->mutable || 0 => @src;
5272 2 50       6 if (grep {$_} @mutable) {
  4         10  
5273 0         0 my ($size, @cache, $cached);
5274             my $set_size = sub {
5275 0     0   0 @cache = ();
5276 0         0 $cached = -1;
5277 0         0 $size = @src * min(map $_->() => @size);
5278 0         0 };
5279 0         0 $set_size->();
5280             curse {
5281             FETCH => sub {
5282 0 0   0   0 croak "zipgen index $_[1] out of range [0 .. ".($size-1)."]"
5283             if $_[1] >= $size;
5284            
5285 0         0 my ($src, $i) = (($_[1] % @src), int ($_[1] / @src));
5286            
5287 0 0       0 unless ($cached == $i) {
5288 0         0 @cache = ();
5289 0         0 $cached = $i;
5290 0         0 for my $sid (0 .. $#src) {
5291 0 0       0 if ($mutable[$sid]) {
5292 0 0       0 if ($i < $size[$sid]()) {
5293 0         0 $cache[$sid] = \$fetch[$sid](undef, $i);
5294 0 0       0 if ($i >= $size[$sid]()) {
5295 0         0 $set_size->();
5296             return
5297 0         0 }
5298             } else {
5299 0         0 $set_size->();
5300             return
5301 0         0 }
5302             } else {
5303 0         0 $cache[$sid] = \$fetch[$sid](undef, $i);
5304             }
5305             }
5306             }
5307 0         0 ${$cache[$src]}
  0         0  
5308             },
5309 0     0   0 fsize => sub {$size},
5310 0     0   0 source => sub {\@src},
5311 0     0   0 mutable => sub {1},
5312 0         0 apply => $set_size,
5313             } => $class;
5314             } else {
5315 2         8 my $size = @src * min(map $_->() => @size);
5316             curse {
5317             FETCH => sub {
5318 12     12   36 $fetch[$_[1] % @src](undef, int ($_[1] / @src))
5319             },
5320 2     2   5 fsize => sub {$size},
5321 2     2   6 source => sub {\@src}
5322 2         26 } => $class
5323             }
5324             };
5325            
5326            
5327             =item unzip C< LIST >
5328            
5329             C< unzip > is the opposite of C< zip src1, src2 >. unzip returns 2 generators,
5330             the first returning src1, the second, src2. if C< LIST > is a single element,
5331             and is a generator, that generator will be unzipped.
5332            
5333             =cut
5334            
5335             sub unzip;
5336             *unzip = &unzipn(2);
5337            
5338            
5339             =item unzipn C< NUMBER LIST >
5340            
5341             C is the n-dimentional precursor of C< unzip >. assuming a zipped list
5342             produced by C< zip > with C< n > elements, C< unzip n list> returns C< n > lists
5343             corresponding to the lists originally passed to C< zip >. if C< LIST > is a
5344             single element, and is a generator, that generator will be unzipped. if only
5345             passed 1 argument, C< unzipn > will return a curried version of itself:
5346            
5347             *unzip3 = unzipn 3;
5348            
5349             my $zip3 = zip <1..>, <2..>, <3..>;
5350            
5351             my ($x, $y, $z) = unzip3($zip3);
5352            
5353             # $x == <1..>, $y == <2..>, $z == <3..>;
5354            
5355             =cut
5356            
5357             sub unzipn ($@) {
5358 10 50   10 1 51 return \&unzipn unless @_;
5359 10         32 my $n = shift;
5360 10 50   0   146 return sub {&unzipn($n, @_)} unless @_;
  0         0  
5361 0 0 0     0 if (@_ == 1 and ref $_[0] and isagen $_[0]) {
      0        
5362 0         0 my $gen = $_[0];
5363 0 0       0 if ($gen->is_mutable) {
5364 0         0 my @lists;
5365             $gen->when_done(sub {
5366 0     0   0 my $size = int ($gen->size / $n);
5367 0         0 $_->set_size($size) for @lists;
5368 0         0 @lists = ()
5369 0         0 });
5370 0         0 @lists = map {
5371 0         0 my $i = $_;
5372             mutable gen {
5373 0     0   0 my $idx = $_ * $n + $i;
5374 0         0 my $ret;
5375 0 0       0 done if $gen->size <= $idx;
5376 0 0       0 done if not eval {$ret = \$gen->get($idx); 1};
  0         0  
  0         0  
5377 0 0       0 done if $gen->size <= $idx;
5378 0         0 $$ret
5379             }
5380 0         0 } 0 .. $n - 1
5381             }
5382             else {
5383 0         0 my $size = int($gen->size/$n);
5384 0         0 my $extra = $gen->size - $size*$n;
5385 0         0 map {
5386 0         0 my $i = $_;
5387 0     0   0 gen {$gen->get($i + $n * $_)} $size + ($extra --> 0)
  0         0  
5388             } 0 .. $n - 1
5389             }
5390             } else {
5391 0         0 my $cap = \@_;
5392 0         0 my $size = int(@_/$n);
5393 0         0 my $extra = @_ - $size*$n;
5394 0         0 map {
5395 0         0 my $i = $_;
5396 0     0   0 gen {$$cap[$i + $n * $_]} $size + ($extra --> 0)
  0         0  
5397             } 0 .. $n - 1;
5398             }
5399             }
5400            
5401            
5402             =item zipgenmax C< LIST >
5403            
5404             C< zipgenmax > is a lazy version of C< zipmax >. it takes any combination of
5405             generators and array refs and returns a generator.
5406            
5407             =cut
5408            
5409             sub zipgenmax {
5410 0 0   0 1 0 my @src = map tied @{isagen or makegen @$_} => @_;
  0         0  
5411 0         0 my @fetch = map $_->can('FETCH') => @src;
5412 0         0 my @size = map $_->can('fsize') => @src;
5413 0 0   0   0 if (first {$_->mutable} @src) {
  0         0  
5414             mutable gen {
5415 0     0   0 my ($src, $i) = (($_ % @src), int ($_ / @src));
5416 0 0       0 my $ret = $i < $size[$src]() ? $fetch[$src](undef, $i) : undef;
5417 0 0       0 done if $i >= max(map $_->() => @size);
5418 0         0 $ret
5419 0         0 } 0 => @src * max(map $_->() => @size) - 1
5420             } else {
5421 0         0 @size = map $_->() => @size;
5422             gen {
5423 0     0   0 my ($src, $i) = (($_ % @src), int ($_ / @src));
5424 0 0       0 $i < $size[$src] ? $fetch[$src](undef, $i) : undef
5425 0         0 } 0 => @src * max(@size) - 1
5426             }
5427             }
5428            
5429            
5430             =item zipwith C< {CODE} LIST>
5431            
5432             C takes a code block and a list. the C is zipped together and
5433             each sub-list is passed to C when requested. C produces a
5434             generator with the same length as its shortest source list.
5435            
5436             my $triples = zipwith {\@_} <1..>, <20..>, <300..>;
5437            
5438             say "@$_" for @$triples[0 .. 3];
5439            
5440             1 20 300 # the first element of each list
5441             2 21 301 # the second
5442             3 22 302 # the third
5443             4 23 303 # the fourth
5444            
5445             =cut
5446            
5447             sub zipwith (&@) {
5448 4     4 1 7 my $code = shift;
5449 4         8 my $src = \@_;
5450 4         6 my $mutable;
5451 4   33     10 isagen or $_ = makegen @$_ for @$src;
5452 4   33     32 $mutable ||= (not defined or $_->is_mutable) for @$src;
      33        
5453 4 50       10 if ($mutable) {
5454 0         0 my @size;
5455             mutable gen {
5456 0     0   0 my $i = $_;
5457 0         0 my $last;
5458 0 0       0 unless (@size) {
5459 0         0 for (map {tied @$_} @$src) {
  0         0  
5460 0         0 push @size, $_->fsize;
5461 0 0       0 $_->tail_size($size[-1]) if $_->mutable;
5462             }
5463             }
5464 0   0     0 $_ <= $i and done for @size;
5465 0         0 my $arg = cap map $$src[$_]->get($i) => 0 .. $#$src;
5466            
5467 0         0 for (@size) {
5468 0 0       0 done if $_ <= $i;
5469 0 0       0 $last++ if $_ == $i + 1;
5470             }
5471 0         0 my $ret = cap $code->(@$arg);
5472 0 0       0 done @$ret if $last;
5473 0 0       0 wantarray ? @$ret : pop @$ret
5474             }
5475 0         0 } else {
5476 4         29 my @fetch = map tied(@$_)->can('FETCH'), @$src;
5477             gen {
5478 15     15   19 my $i = $_;
5479 15         34 $code->(map $_->(undef, $i), @fetch)
5480 4         38 } min map $_->size, @$src;
5481             }
5482             }
5483            
5484            
5485             =item zipwithab C<<< {AB_CODE} $gen1, $gen2 >>>
5486            
5487             The zipwithab function takes a function which uses C< $a > and C< $b >, as well
5488             as two lists and returns a list analogous to zipwith.
5489            
5490             =cut
5491            
5492             sub zipwithab (&@) {
5493 0     0 1 0 my $code = shift;
5494 0         0 my $src = \@_;
5495 0         0 my ($a, $b) = $code->$cv_ab_ref;
5496 0         0 my $mutable;
5497 0   0     0 $mutable ||= (not defined or $_->is_mutable) for @$src;
      0        
5498 0 0       0 if ($mutable) {
5499 0         0 my @size;
5500             mutable gen {
5501 0 0   0   0 unless (@size) {
5502 0         0 for (map {tied @$_} @$src) {
  0         0  
5503 0         0 push @size, $_->fsize;
5504 0 0       0 $_->tail_size($size[-1]) if $_->mutable
5505             }
5506             }
5507 0         0 my $i = $_;
5508 0 0       0 done if first {$_ <= $i} @size;
  0         0  
5509 0         0 local *$a = \$$src[0]->get($i);
5510 0         0 local *$b = \$$src[1]->get($i);
5511 0 0       0 done if first {$_ <= $i} @size;
  0         0  
5512 0         0 $code->()
5513             }
5514 0         0 } else {
5515 0         0 my ($fetch_a, $fetch_b) = map tied(@$_)->can('FETCH'), @$src;
5516             gen {
5517 0     0   0 local *$a = \$fetch_a->(undef, $_);
5518 0         0 local *$b = \$fetch_b->(undef, $_);
5519 0         0 $code->()
5520 0         0 } min map $_->size, @$src
5521             }
5522             }
5523            
5524            
5525             =item zipwithmax C< {CODE} LIST >
5526            
5527             C< zipwithmax > is a version of C< zipwith > that has the ending conditions of
5528             C< zipgenmax >.
5529            
5530             =cut
5531            
5532             sub zipwithmax (&@) {
5533 0     0 1 0 my $code = shift;
5534 0         0 $code->$sv2cv;
5535 0 0       0 my @src = map tied @{isagen or makegen @$_} => @_;
  0         0  
5536 0         0 my @fetch = map $_->can('FETCH') => @src;
5537 0         0 my @size = map $_->can('fsize') => @src;
5538 0 0   0   0 if (first {$_->mutable} @src) {
  0         0  
5539             mutable gen {
5540 0     0   0 my $i = int ($_ / @src);
5541 0 0       0 my @ret = map {$i < $size[$_]() ? $fetch[$_](undef, $i) : undef} 0 .. $#src;
  0         0  
5542 0 0       0 done if $i >= max(map $_->() => @size);
5543 0         0 $code->(@ret)
5544 0         0 } 0 => max(map $_->() => @size) - 1
5545             } else {
5546 0         0 @size = map $_->() => @size;
5547             gen {
5548 0     0   0 my $i = int ($_ / @src);
5549 0 0       0 $code->(map {$i < $size[$_] ? $fetch[$_](undef, $i) : undef} 0 .. $#src)
  0         0  
5550 0         0 } 0 => max(@size) - 1
5551             }
5552             }
5553            
5554            
5555             =item transpose C< MULTI_DIMENSIONAL_ARRAY >
5556            
5557             =item transpose C< LIST >
5558            
5559             C< transpose > computes the 90 degree rotation of its arguments, which must be
5560             a single multidimensional array or generator, or a list of 1+ dimensional
5561             structures.
5562            
5563             say transpose([[1, 2, 3]])->perl; # [[1], [2], [3]]
5564            
5565             say transpose([[1, 1], [2, 2], [3, 3]])->perl; # [[1, 2, 3], [1, 2, 3]]
5566            
5567             say transpose(<1..>, <2..>, <3..>)->take(5)->perl;
5568             # [[1, 2, 3], [2, 3, 4], [3, 4, 5], [4, 5, 6], [5, 6, 7]]
5569            
5570             =cut
5571            
5572             sub transpose {
5573 0 0   0 1 0 my $src = @_ == 1 ? shift : \@_;
5574 0 0       0 return empty unless @$src;
5575 0 0 0     0 if (isagen $$src[0] and $$src[0]->is_mutable) {
5576             iterate_multi {
5577 0     0   0 my $i = $_;
5578 0   0     0 $i < $_->size or done for @$src;
5579 0         0 $_->get($i) for @$src;
5580 0   0     0 $i < $_->size or done for @$src;
5581             $i + 1 < $_->size or do {
5582 0 0       0 done mutable gen {$i < @$_ ? $$_[$i] : done} $src
  0         0  
5583 0   0     0 } for @$src;
5584 0 0       0 mutable gen {$i < @$_ ? $$_[$i] : done} $src
  0         0  
5585             }
5586 0         0 } else {
5587             iterate {
5588 0     0   0 my $i = $_;
5589 0         0 gen {$$_[$i]} $src
  0         0  
5590 0         0 } 0+@{$$src[0]}
  0         0  
5591             }
5592             }
5593            
5594            
5595             =item cartesian C< {CODE} LIST >
5596            
5597             C< cartesian > computes the cartesian product of any number of array refs or
5598             generators, each which can be any size. returns a generator
5599            
5600             my $product = cartesian {$_[0] . $_[1]} [qw/a b/], [1, 2];
5601            
5602             @$product == qw( a1 a2 b1 b2 );
5603            
5604             =cut
5605            
5606             sub cartesian (&@) {
5607 0     0 1 0 my $code = shift;
5608 0         0 my @src = @_;
5609 0         0 my @size = map {0+@$_} @src;
  0         0  
5610 0         0 my $size = 1;
5611 0   0     0 my @cycle = map {$size / $_}
  0         0  
5612 0         0 map {$size *= $size[$_] || 1} 0 .. $#src;
5613             gen {
5614 0     0   0 my $i = $_;
5615 0 0       0 $code->(map {
5616 0         0 $size[$_] ? $src[$_][ $i / $cycle[$_] % $size[$_] ] : ()
5617             } 0 .. $#src)
5618 0         0 } 0 => $size - 1
5619             }
5620            
5621            
5622             =back
5623            
5624             =head2 misc functions
5625            
5626             =over 4
5627            
5628             =item mapkey C< {CODE} KEY LIST >
5629            
5630             this function is syntactic sugar for the following idiom
5631            
5632             my @cartesian_product =
5633             map {
5634             my $first = $_;
5635             map {
5636             my $second = $_;
5637             map {
5638             $first . $second . $_
5639             } 1 .. 3
5640             } qw/x y z/
5641             } qw/a b c/;
5642            
5643             my @cartesian_product =
5644             mapkey {
5645             mapkey {
5646             mapkey {
5647             $_{first} . $_{second} . $_{third}
5648             } third => 1 .. 3
5649             } second => qw/x y z/
5650             } first => qw/a b c/;
5651            
5652             =cut
5653            
5654             sub mapkey (&$@) {
5655 0     0 1 0 my ($code, $key) = splice @_, 0, 2;
5656 0         0 local $_{$key};
5657 0         0 map {
5658 0         0 $_{$key} = $_;
5659 0         0 $code->()
5660             } @_
5661             }
5662            
5663            
5664             =item mapab C< {CODE} PAIRS >
5665            
5666             this function works like the builtin C< map > but consumes a list in pairs,
5667             rather than one element at a time. inside the C< CODE > block, the variables
5668             C< $a > and C< $b > are aliased to the elements of the list. if C< mapab > is
5669             called in void context, the C< CODE > block will be executed in void context
5670             for efficiency. if C< mapab > is passed an uneven length list, in the final
5671             iteration, C< $b > will be C< undef >
5672            
5673             my %hash = (a => 1, b => 2, c => 3);
5674            
5675             my %reverse = mapab {$b, $a} %hash;
5676            
5677             =cut
5678            
5679             sub mapab (&%) {
5680 0     0 1 0 my ($code, @ret) = shift;
5681 0         0 my $want = defined wantarray;
5682 0         0 my ($a, $b) = $code->$cv_ab_ref;
5683 0         0 local (*$a, *$b);
5684 0         0 while (@_) {
5685 0 0       0 if (@_ == 1) {
5686 0         0 *$a = \shift;
5687 0         0 *$b = \undef;
5688             } else {
5689 0         0 (*$a, *$b) = \splice @_, 0, 2
5690             }
5691 0 0       0 if ($want) {push @ret => $code->()}
  0         0  
  0         0  
5692             else {$code->()}
5693             }
5694             @ret
5695 0         0 }
5696            
5697            
5698             =item slide C< {CODE} WINDOW LIST >
5699            
5700             slides a C< WINDOW > sized slice over C< LIST >, calling C< CODE > for each
5701             slice and collecting the result
5702            
5703             as the window reaches the end, the passed in slice will shrink
5704            
5705             print slide {"@_\n"} 2 => 1 .. 4
5706             # 1 2
5707             # 2 3
5708             # 3 4
5709             # 4 # only one element here
5710            
5711             =cut
5712            
5713             sub slide (&$@) {
5714 0     0 1 0 my ($code, $window) = splice @_, 0, 2;
5715 0         0 $window--;
5716 0         0 map $code->(@_[$_ .. min $_+$window, $#_]) => 0 .. $#_
5717             }
5718            
5719            
5720             =item remove C< {CODE} ARRAY|HASH >
5721            
5722             C< remove > removes and returns elements from its source when C< CODE >
5723             returns true. in the code block, if the source is an array, C< $_ > is aliased
5724             to its elements. if the source is a hash, C< $_ > is aliased to its keys (and
5725             a list of the removed C<< key => value >> pairs are returned).
5726            
5727             my @array = (1, 7, 6, 3, 8, 4);
5728             my @removed = remove {$_ > 5} @array;
5729            
5730             say "@array"; # 1 3 4
5731             say "@removed"; # 7 6 8
5732            
5733             in list context, C< remove > returns the list of removed elements/pairs.
5734             in scalar context, it returns the number of removals. C< remove > will not
5735             build a return list in void context for efficiency.
5736            
5737             =cut
5738            
5739             sub remove (&\[@%]) {
5740 0     0 1 0 my ($code, $src) = @_;
5741 0         0 my ($want, @ret) = defined wantarray;
5742 0         0 local *_;
5743 0 0       0 if (reftype $src eq 'ARRAY') {
5744 0         0 my $i = 0;
5745 0         0 while ($i < @$src) {
5746 0         0 *_ = \$$src[$i];
5747 0 0       0 &$code ? $want ? push @ret, splice @$src, $i, 1
    0          
5748             : splice @$src, $i, 1
5749             : $i++
5750             }
5751             }
5752             else {
5753 0         0 for (keys %$src) {
5754 0 0       0 if (&$code) {
5755 0 0       0 $want ? push @ret, $_ => delete $$src{$_}
5756             : delete $$src{$_}
5757             }
5758             }
5759             }
5760             wantarray
5761             ? @ret
5762 0 0       0 : reftype $src eq 'HASH'
    0          
5763             ? @ret / 2
5764             : @ret
5765             }
5766            
5767            
5768             =item d C< [SCALAR] >
5769            
5770             =item deref C< [SCALAR] >
5771            
5772             dereference a C< SCALAR >, C< ARRAY >, or C< HASH > reference. any other value
5773             is returned unchanged
5774            
5775             print join " " => map deref, 1, [2, 3, 4], \5, {6 => 7}, 8, 9, 10;
5776             # prints 1 2 3 4 5 6 7 8 9 10
5777            
5778             =cut
5779            
5780             sub d (;$) {
5781 280 50   280 1 780 local *_ = \$_[0] if @_;
5782 280         774 my $type = reftype $_;
5783 280 0       1015 $type ?
    0          
    0          
    50          
5784             $type eq 'ARRAY' ? @$_ :
5785             $type eq 'HASH' ? %$_ :
5786             $type eq 'SCALAR' ? $$_ : $_
5787             : $_
5788             }
5789 10     10   3022 BEGIN {*deref = \&d}
5790            
5791            
5792             =item curse C< HASHREF PACKAGE >
5793            
5794             many of the functions in this package utilize closure objects to avoid the speed
5795             penalty of dereferencing fields in their object during each access. C< curse >
5796             is similar to C< bless > for these objects and while a blessing makes a
5797             reference into a member of an existing package, a curse conjures a new package
5798             to do the reference's bidding
5799            
5800             package Closure::Object;
5801             sub new {
5802             my ($class, $name, $value) = @_;
5803             curse {
5804             get => sub {$value},
5805             set => sub {$value = $_[1]},
5806             name => sub {$name},
5807             } => $class
5808             }
5809            
5810             C<< Closure::Object >> is functionally equivalent to the following normal perl
5811             object, but with faster method calls since there are no hash lookups or other
5812             dereferences (around 40-50% faster for short getter/setter type methods)
5813            
5814             package Normal::Object;
5815             sub new {
5816             my ($class, $name, $value) = @_;
5817             bless {
5818             name => $name,
5819             value => $value,
5820             } => $class
5821             }
5822             sub get {$_[0]{value}}
5823             sub set {$_[0]{value} = $_[1]}
5824             sub name {$_[0]{name}}
5825            
5826             the trade off is in creation time / memory, since any good curse requires
5827             drawing at least a few pentagrams in the blood of an innocent package.
5828            
5829             the returned object is blessed into the conjured package, which inherits from
5830             the provided C< PACKAGE >. always use C<< $obj->isa(...) >> rather than
5831             C< ref $obj eq ... > due to this. the conjured package name matches
5832             C<< /${PACKAGE}::_\d+/ >>
5833            
5834             special keys:
5835            
5836             -bless => $reference # returned instead of HASHREF
5837             -overload => [fallback => 1, '""' => sub {...}]
5838            
5839             when fast just isn't fast enough, since most cursed methods don't need to be
5840             passed their object, the fastest way to call the method is:
5841            
5842             my $obj = Closure::Object->new('tim', 3);
5843             my $set = $obj->{set}; # fetch the closure
5844             # or $obj->can('set')
5845            
5846             $set->(undef, $_) for 1 .. 1_000_000; # call without first arg
5847            
5848             which is around 70% faster than pre-caching a method from a normal object for
5849             short getter/setter methods, and is the method used internally in this module.
5850            
5851             =back
5852            
5853             =head1 SEE ALSO
5854            
5855             =over 4
5856            
5857             =item * see L for usage tips.
5858            
5859             =item * see L for performance tips.
5860            
5861             =item * see L for an experimental implementation of
5862             haskell's lazy list behavior.
5863            
5864             =item * see L for the tools used to create
5865             L.
5866            
5867             =item * see L for some of perl's operators implemented
5868             as lazy haskell like functions.
5869            
5870             =item * see L for most of perl's builtin functions
5871             implemented as lazy haskell like functions.
5872            
5873             =item * see L for a source filter that adds perl6's meta
5874             operators to use with generators, rather than the default overloaded operators
5875            
5876             =back
5877            
5878             =head1 CAVEATS
5879            
5880             version 0.90 added C< glob > to the default export list (which gives you
5881             syntactic ranges C<< <1 .. 10> >> and list comprehensions.). version 0.90 also
5882             adds many new features and bug-fixes, as usual, if anything is broken, please
5883             send in a bug report. the ending conditions of C< zip > and C< zipgen > have
5884             changed, see the documentation above. C< test > has been removed from the
5885             default export list. setting C< $List::Gen::LIST > true to enable list context
5886             generators is no longer supported and will now throw an error. C< list > has
5887             been added to the default export list. C< genzip > has been renamed C< zipgen >
5888            
5889             version 0.70 comes with a bunch of new features, if anything is broken, please
5890             let me know. see C< filter > for a minor behavior change
5891            
5892             versions 0.50 and 0.60 break some of the syntax from previous versions,
5893             for the better.
5894            
5895             =over 4
5896            
5897             =item code generation
5898            
5899             a number of the syntactic shortcuts that List::Gen provides will construct and
5900             then evaluate code behind the scenes. Normally this is transparent, but if you
5901             are trying to debug a problem, hidden code is never a good thing. You can
5902             lexically enable the printing of evaled code with:
5903            
5904             local $List::Gen::SAY_EVAL = 1;
5905            
5906             my $fib = <0, 1, *+*...>;
5907            
5908             # eval: ' @pre = (0, 1)' at (file.pl) line ##
5909             # eval: 'List::Gen::iterate { if (@pre) {shift @pre}
5910             # else { $fetch->(undef, $_ - 2) + $fetch->(undef, $_ - 1) }
5911             # } 9**9**9' at (file.pl) line ##
5912            
5913             my $gen = <1..10>->map('$_*2 + 1')->grep('some_predicate');
5914            
5915             # eval: 'sub ($) {$_*2 + 1}' at (file.pl) line ##
5916             # eval: 'sub ($) {some_predicate($_)}' at (file.pl) line ##
5917            
5918             a given code string is only evaluated once and is then cached, so you will not
5919             see any additional output when using the same code strings in multiple places.
5920             in some cases (like the iterate example above) the code is closing over external
5921             variables (C< @pre > and C< $fetch >) so you will not be able to see everything,
5922             but C< $SAY_EVAL > should be a helpful debugging aid.
5923            
5924             any time that code evaluation fails, an immediate fatal error is thrown. the
5925             value of C< $SAY_EVAL > does not matter in that case.
5926            
5927             =item captures of compile time constructed lists
5928            
5929             the C< cap > function and its twin operator C< &\ > are faster than the
5930             C< [...] > construct because they do not copy their arguments. this is why the
5931             elements of the captures remain aliased to their arguments. this is normally
5932             fine, but it has an interesting effect with compile time constructed constant
5933             lists:
5934            
5935             my $max = 1000;
5936             my $range = & \(1 .. $max); # 57% faster than [1 .. $max]
5937             my $nums = & \(1 .. 1000); # 366% faster than [1 .. 1000], but cheating
5938            
5939             the first example shows the expected speed increase due to not copying the
5940             values into a new empty array reference. the second example is much faster at
5941             runtime than the C< [...] > syntax, but this speed is deceptive. the reason is
5942             that the list being passed in as an argument is generated by the compiler before
5943             runtime begins. so all perl has to do is place the values on the stack, and
5944             call the function.
5945            
5946             normally this is fine, but there is one catch to be aware of, and that is that
5947             a capture of a compile time constant list in a loop or subroutine (or any
5948             structure that can execute the same segment of code repeatedly) will always
5949             return a reference to an array of the same elements.
5950            
5951             # two instances give two separate arrays
5952             my ($a, $b) = (&\(1 .. 3), &\(1 .. 3));
5953             $_ += 10 for @$a;
5954             say "@$a : @$b"; # 11 12 13 : 1 2 3
5955            
5956             # here the one instance returns the same elements twice
5957             my ($x, $y) = map &\(1 .. 3), 1 .. 2;
5958             $_ += 10 for @$x;
5959             say "@$x : @$y"; # 11 12 13 : 11 12 13
5960            
5961             this only applies to compile time constructed constant lists, anything
5962             containing a variable or non constant function call will give you separate
5963             array elements, as shown below:
5964            
5965             my ($low, $high) = (1, 3);
5966             my ($x, $y) = map &\($low .. $high), 1 .. 2; # non constant list
5967             $_ += 10 for @$x;
5968             say "@$x : @$y"; # 11 12 13 : 1 2 3
5969            
5970             =back
5971            
5972             =head1 AUTHOR
5973            
5974             Eric Strom, C<< >>
5975            
5976             =head1 BUGS
5977            
5978             overloading has gotten fairly complicated and is probably in need of a rewrite.
5979             if any edge cases do not work, please send in a bug report.
5980            
5981             both threaded methods (C<< $gen->threads_slice(...) >>) and function composition
5982             with overloaded operators (made with C) do not work
5983             properly in versions of perl before 5.10. patches welcome
5984            
5985             report any bugs / feature requests to C, or through
5986             the web interface at L.
5987            
5988             comments / feedback / patches are also welcome.
5989            
5990             =head1 COPYRIGHT & LICENSE
5991            
5992             copyright 2009-2011 Eric Strom.
5993            
5994             this program is free software; you can redistribute it and/or modify it under
5995             the terms of either: the GNU General Public License as published by the Free
5996             Software Foundation; or the Artistic License.
5997            
5998             see http://dev.perl.org/licenses/ for more information.
5999            
6000             =cut
6001            
6002             __PACKAGE__ if 'first require';