File Coverage

blib/lib/Iterator/Merger.pm
Criterion Covered Total %
statement 140 171 81.8
branch 37 54 68.5
condition 12 29 41.3
subroutine 33 37 89.1
pod 2 2 100.0
total 224 293 76.4


line stmt bran cond sub pod time code
1             # build and eval the code to efficiently merge several iterators in one iterator
2             package Iterator::Merger;
3 2     2   2926 use strict;
  2         5  
  2         60  
4 2     2   11 use warnings;
  2         3  
  2         63  
5 2     2   12 use Carp;
  2         4  
  2         124  
6 2     2   12 use base 'Exporter';
  2         3  
  2         243  
7              
8             our $VERSION = '0.61';
9              
10 2     2   16 use constant DEBUG => 0;
  2         3  
  2         263  
11              
12             our @EXPORT_OK = qw(
13             imerge
14             imerge_num
15             imerge_raw
16             );
17              
18             our %EXPORT_TAGS = (
19             all => \@EXPORT_OK
20             );
21              
22 2     2   16 use constant HAS_ARRAY_HEAP => eval "use Array::Heap;1";
  2     2   2  
  2         158  
  2         1139  
  2         1050  
  2         157  
23              
24             our $Max_generate;
25              
26             unless (defined $Max_generate) {
27             $Max_generate = HAS_ARRAY_HEAP ? 9 : 12; # 10 => ~30KiB to eval (doubles each increment)
28             }
29              
30             my %Generator_cache;
31              
32 104084 100 100 104084   4474361 *imerge_raw = eval q!
  21238 50 100     442330  
  21266 100 66     57191  
  1470 50       2946  
  2363 100       66347  
  0         0  
  0         0  
  225         303296  
  213         681  
  16         37  
  16         111  
  197         540  
  1668         3386  
  0         0  
  0         0  
  197         457  
  1668         3251  
  196         425  
  196         1140  
33             # try to use the defined-or operator
34             sub {
35             my @ites = @_ or return sub {};
36             if (@ites==1) {
37             my $ite = shift;
38             return ref($ite) eq 'GLOB' ? sub {scalar <$ite>} : sub {scalar &$ite};
39             }
40             for (@ites) {
41             if (ref($_) eq 'GLOB') {
42             my $fh = $_;
43             $_ = sub {<$fh>}
44             }
45             }
46             croak "arguments must be CODE references or filehandles" if grep {ref($_) ne 'CODE'} @ites;
47             my $ite = shift(@ites);
48             sub {
49             &$ite // do {
50             { # block for redo
51             $ite = shift(@ites) || return;
52             &$ite // redo
53             }
54             }
55             }
56             }
57             ! || eval q!
58             # default to use defined() and a temporary variable
59             sub {
60             my @ites = @_ or return sub {};
61             if (@ites==1) {
62             my $ite = shift;
63             return ref($ite) eq 'GLOB' ? sub {scalar <$ite>} : sub {scalar &$ite};
64             }
65             for (@ites) {
66             if (ref($_) eq 'GLOB') {
67             my $fh = $_;
68             $_ = sub {<$fh>}
69             }
70             }
71             croak "arguments must be CODE references or filehandles" if grep {ref($_) ne 'CODE'} @ites;
72             my $ite = shift(@ites);
73             sub {
74             my $next = &ite;
75             until (defined $next) {
76             $ite = shift(@ites) || return;
77             $next = &$ite;
78             }
79             $next
80             }
81             }
82             ! || die $@;
83              
84             sub imerge {
85 225     225 1 349860 _imerge(1, \@_)
86             }
87              
88             sub imerge_num {
89 225     225 1 761804 _imerge(0, \@_)
90             }
91              
92             sub _imerge {
93 450     450   1446 my ($lex, $iterators) = @_;
94 450         981 my $nb = @$iterators;
95            
96 450 100       994 croak "arguments must be CODE references or filehandles" if grep {ref($_) !~ /^CODE$|^GLOB$/} @$iterators;
  3368         10542  
97            
98 448 100       2646 if ($nb==0) {
    100          
    100          
99 24     2424   149 return sub {undef};
  2424         18264  
100             }
101             elsif ($nb==1) {
102             #return $iterators->[0];
103             # ensure scalar context
104 32         76 my $ite = $iterators->[0];
105 32 50   4367   224 return ref($ite) eq 'GLOB' ? sub {scalar <$ite>} : sub {scalar &$ite};
  0         0  
  4367         48314  
106             }
107             elsif ($nb <= $Max_generate) {
108 224         457 DEBUG && warn "generate";
109 224 50       506 if ($nb == grep {ref($_) eq 'GLOB'} @$iterators) {
  1232         2505  
110             # only globs
111 0   0     0 my $code = $Generator_cache{$nb, $lex, 1} ||= _merger_generator($nb, $lex, 1);
112 0         0 return $code->(@$iterators);
113             } else {
114 224         710 for (@$iterators) {
115 1232 50       2708 if (ref($_) eq 'GLOB') {
116 0         0 my $fh = $_;
117 0     0   0 $_ = sub {<$fh>}
118 0         0 }
119             }
120 224   66     1647 my $code = $Generator_cache{$nb, $lex, 0} ||= _merger_generator($nb, $lex, 0);
121 224         6655 return $code->(@$iterators);
122             }
123             }
124             else {
125             # no generation, giveup on some ultimate optim: lets turn all GLOBs to CODEs...
126 168         450 for (@$iterators) {
127 2100 50       3965 if (ref($_) eq 'GLOB') {
128 0         0 my $fh = $_;
129 0     0   0 $_ = sub {<$fh>}
130 0         0 }
131             }
132 168         310 if (HAS_ARRAY_HEAP) {
133 168         241 DEBUG && warn "heap";
134             # general case, use a heap
135 168         304 my @heap;
136             # cannot take references to *_heap_lex and *_heap functions,
137             # due to prototype problems...
138 168 100       418 if ($lex) {
139 84         161 for my $ite (@$iterators) {
140 1050         1764 my $val = &$ite;
141 1050 100       6511 Array::Heap::push_heap_lex(@heap, [$val, $ite]) if defined $val;
142             }
143             return sub {
144 61925   100 61925   757788 my $data = Array::Heap::pop_heap_lex(@heap) || return undef;
145 53441         78025 my $min = $data->[0];
146 53441 100       83013 if ( defined($data->[0] = $data->[1]->()) ) {
147 52409         265220 Array::Heap::push_heap_lex(@heap, $data);
148             }
149             $min
150 84         702 };
  53441         104205  
151             }
152             else {
153 84         157 for my $ite (@$iterators) {
154 1050         1761 my $val = &$ite;
155 1050 100       6392 Array::Heap::push_heap(@heap, [$val, $ite]) if defined $val;
156             }
157             return sub {
158 62183   100 62183   723353 my $data = Array::Heap::pop_heap(@heap) || return undef;
159 53699         75853 my $min = $data->[0];
160 53699 100       83460 if ( defined($data->[0] = $data->[1]->()) ) {
161 52667         253384 Array::Heap::push_heap(@heap, $data);
162             }
163             $min
164 84         641 };
  53699         92271  
165             }
166             }
167             else {
168             DEBUG && warn "brutal";
169             # no heap available, lets be dirty
170             my @values = map {scalar &$_} @$iterators;
171             # warn "values: ", join(", ", map {length($_)?1:0} @values), "\n";
172             if ($lex) {
173             return sub {
174 0     0   0 my $i=-1;
175 0         0 my $min;
176             my $min_i;
177 0         0 for (@values) {
178 0         0 ++$i;
179 0 0 0     0 if (defined and ((not defined $min) or ($_ lt $min))) {
      0        
180 0         0 $min = $_;
181 0         0 $min_i = $i;
182             }
183             }
184 0 0       0 $values[$min_i] = $iterators->[$min_i]->() if defined $min_i;
185             # warn "value is ", (length($min)?1:0), " from $min_i";
186 0         0 $min
187             };
188             }
189             else {
190             return sub {
191 0     0   0 my $i=-1;
192 0         0 my $min;
193             my $min_i;
194 0         0 for (@values) {
195 0         0 ++$i;
196 0 0 0     0 if (defined and ((not defined $min) or ($_ < $min))) {
      0        
197 0         0 $min = $_;
198 0         0 $min_i = $i;
199             }
200             }
201 0 0       0 $values[$min_i] = $iterators->[$min_i]->() if defined $min_i;
202 0         0 $min
203             };
204             }
205             }
206             }
207             }
208              
209             sub _merger_generator {
210 16     16   62 my ($nb, $lex, $globs) = @_;
211 16         47 my $str = "no warnings;sub{";
212 16         59 $str .= "my(". join(',', map {"\$i$_"} 1..$nb). ")=\@_;";
  88         233  
213 16 50       191 $str .= $globs ? "my\$n$_=<\$i$_>;" : "my\$n$_=&\$i$_;" for 1..$nb;
214 16         69 $str .= "my\$r;sub{";
215 16 100       72 my $cmp = $lex ? ' lt' : '<';
216 16         74 $str .= _cmp($cmp, $globs, 1..$nb);
217 16         77 $str .= ";\$r}}";
218              
219             # $str =~ s/;/;\n/g;
220             # $str =~ s/\$/ \$/g;
221             # $str =~ s/{/ {\n/g;
222             # $str =~ s/}/ }\n/g;
223             # warn "\n\n$str\n\n";
224            
225 16 50   1   1549 eval($str) || die "$@ in $str"
  1     1   12  
  1     1   2  
  1     1   154  
  1     1   12  
  1     1   2  
  1     1   189  
  1     1   10  
  1     1   2  
  1     1   243  
  1     1   11  
  1     1   3  
  1     1   375  
  1     1   10  
  1     1   3  
  1     1   543  
  1         10  
  1         2  
  1         943  
  1         11  
  1         3  
  1         1721  
  1         11  
  1         2  
  1         3206  
  1         10  
  1         2  
  1         168  
  1         10  
  1         2  
  1         212  
  1         10  
  1         2  
  1         254  
  1         9  
  1         3  
  1         349  
  1         10  
  1         3  
  1         574  
  1         14  
  1         2  
  1         922  
  1         10  
  1         3  
  1         1669  
  1         10  
  1         2  
  1         3388  
226             }
227              
228             # recursive comparison expression building
229             sub _cmp {
230 2024     2024   3649 my ($cmp, $globs, $i, $j) = splice(@_, 0, 4);
231 2024 50       6117 return $globs ? "(\$r=\$n$i,\$n$i=<\$i$i>)" : "(\$r=\$n$i,\$n$i=&\$i$i)" unless defined $j;
    100          
232 1004         2284 "(!defined\$n$j||defined\$n$i&&\$n$i$cmp\$n$j)?". _cmp($cmp, $globs, $i, @_). ":". _cmp($cmp, $globs, $j, @_)
233             }
234              
235             1