File Coverage

blib/lib/MDK/Common/Func.pm
Criterion Covered Total %
statement 9 112 8.0
branch 0 30 0.0
condition 0 12 0.0
subroutine 3 25 12.0
pod 19 21 90.4
total 31 200 15.5


line stmt bran cond sub pod time code
1             package MDK::Common::Func;
2              
3             =head1 NAME
4              
5             MDK::Common::Func - miscellaneous functions
6              
7             =head1 SYNOPSIS
8              
9             use MDK::Common::Func qw(:all);
10              
11             =head1 EXPORTS
12              
13             =over
14              
15             =item may_apply(CODE REF, SCALAR)
16              
17             C is C<$f ? $f-E($v) : $v>
18              
19             =item may_apply(CODE REF, SCALAR, SCALAR)
20              
21             C is C<$f ? $f-E($v) : $otherwise>
22              
23             =item if_(BOOL, LIST)
24              
25             special constructs to workaround a missing perl feature:
26             C is C<$b ? ("a", "b") : ()>
27              
28             example of use: C which is not the
29             same as C
30              
31             =item if__(SCALAR, LIST)
32              
33             if_ alike. Test if the value is defined
34              
35             =item fold_left { CODE } LIST
36              
37             if you don't know fold_left (aka foldl), don't use it ;p
38              
39             fold_left { $::a + $::b } 1, 3, 6
40              
41             gives 10 (aka 1+3+6)
42              
43             =item mapn { CODE } ARRAY REF, ARRAY REF, ...
44              
45             map lists in parallel:
46              
47             mapn { $_[0] + $_[1] } [1, 2], [2, 4] # gives 3, 6
48             mapn { $_[0] + $_[1] + $_[2] } [1, 2], [2, 4], [3, 6] gives 6, 12
49              
50             =item mapn_ { CODE } ARRAY REF, ARRAY REF, ...
51              
52             mapn alike. The difference is what to do when the lists have not the same
53             length: mapn takes the minimum common elements, mapn_ takes the maximum list
54             length and extend the lists with undef values
55              
56             =item find { CODE } LIST
57              
58             returns the first element where CODE returns true (or returns undef)
59              
60             find { /foo/ } "fo", "fob", "foobar", "foobir"
61              
62             gives "foobar"
63              
64             =item any { CODE } LIST
65              
66             returns 1 if CODE returns true for an element in LIST (otherwise returns 0)
67              
68             any { /foo/ } "fo", "fob", "foobar", "foobir"
69              
70             gives 1
71              
72             =item every { CODE } LIST
73              
74             returns 1 if CODE returns true for B element in LIST (otherwise returns 0)
75              
76             every { /foo/ } "fo", "fob", "foobar", "foobir"
77              
78             gives 0
79              
80             =item map_index { CODE } LIST
81              
82             just like C, but set C<$::i> to the current index in the list:
83              
84             map_index { "$::i $_" } "a", "b"
85              
86             gives "0 a", "1 b"
87              
88             =item each_index { CODE } LIST
89              
90             just like C, but doesn't return anything
91              
92             each_index { print "$::i $_\n" } "a", "b"
93              
94             prints "0 a", "1 b"
95              
96             =item grep_index { CODE } LIST
97              
98             just like C, but set C<$::i> to the current index in the list:
99              
100             grep_index { $::i == $_ } 0, 2, 2, 3
101              
102             gives (0, 2, 3)
103              
104             =item find_index { CODE } LIST
105              
106             returns the index of the first element where CODE returns true (or throws an exception)
107              
108             find_index { /foo/ } "fo", "fob", "foobar", "foobir"
109              
110             gives 2
111              
112             =item map_each { CODE } HASH
113              
114             returns the list of results of CODE applied with $::a (key) and $::b (value)
115              
116             map_each { "$::a is $::b" } 1=>2, 3=>4
117              
118             gives "1 is 2", "3 is 4"
119              
120             =item grep_each { CODE } HASH
121              
122             returns the hash key/value for which CODE applied with $::a (key) and $::b
123             (value) is true:
124              
125             grep_each { $::b == 2 } 1=>2, 3=>4, 4=>2
126              
127             gives 1=>2, 4=>2
128              
129             =item partition { CODE } LIST
130              
131             alike C, but returns both the list of matching elements and non matching elements
132              
133             my ($greater, $lower) = partition { $_ > 3 } 4, 2, 8, 0, 1
134              
135             gives $greater = [ 4, 8 ] and $lower = [ 2, 0, 1 ]
136              
137             =item before_leaving { CODE }
138              
139             the code will be executed when the current block is finished
140              
141             # create $tmp_file
142             my $b = before_leaving { unlink $tmp_file };
143             # some code that may throw an exception, the "before_leaving" ensures the
144             # $tmp_file will be removed
145              
146             =item cdie(SCALAR)
147              
148             aka I. If a C is catched, the execution continues
149             B the cdie, not where it was catched (as happens with die & eval)
150              
151             If a C is not catched, it mutates in real exception that can be catched
152             with C
153              
154             cdie is useful when you want to warn about something weird, but when you can
155             go on. In that case, you cdie "something weird happened", and the caller
156             decide wether to go on or not. Especially nice for libraries.
157              
158             =item catch_cdie { CODE1 } sub { CODE2 }
159              
160             If a C occurs while executing CODE1, CODE2 is executed. If CODE2
161             returns true, the C is catched.
162              
163             =back
164              
165             =head1 SEE ALSO
166              
167             L
168              
169             =cut
170              
171 1     1   6 use MDK::Common::Math;
  1         2  
  1         34  
172              
173              
174 1     1   4 use Exporter;
  1         2  
  1         834  
175             our @ISA = qw(Exporter);
176             our @EXPORT_OK = qw(may_apply if_ if__ fold_left mapn mapn_ find any every map_index each_index grep_index find_index map_each grep_each partition before_leaving catch_cdie cdie);
177             our %EXPORT_TAGS = (all => [ @EXPORT_OK ]);
178              
179              
180 0 0   0 1   sub may_apply { $_[0] ? $_[0]->($_[1]) : (@_ > 2 ? $_[2] : $_[1]) }
    0          
181              
182             # prototype is needed for things like: if_(/foo/, bar => 'boo')
183             sub if_($@) {
184 0     0 1   my $b = shift;
185 0 0         $b or return ();
186 0 0 0       wantarray() || @_ <= 1 or die("if_ called in scalar context with more than one argument :\nargs=" . join(", ", @_) . "\ncaller=" . join(":", caller()));
187 0 0         wantarray() ? @_ : $_[0];
188             }
189             sub if__($@) {
190 0     0 1   my $b = shift;
191 0 0         defined $b or return ();
192 0 0 0       wantarray() || @_ <= 1 or die("if__ called in scalar context with more than one argument :\nargs=" . join(", ", @_) . "\ncaller=" . join(":", caller()));
193 0 0         wantarray() ? @_ : $_[0];
194             }
195              
196             sub fold_left(&@) {
197 0     0 1   my ($f, $initial, @l) = @_;
198 0           local ($::a, $::b);
199 0           $::a = $initial;
200 0           foreach (@l) { $::b = $_; $::a = &$f() }
  0            
  0            
201 0           $::a;
202             }
203              
204             sub smapn {
205 0     0 0   my $f = shift;
206 0           my $n = shift;
207 0           my @r;
208 0           for (my $i = 0; $i < $n; $i++) { push @r, &$f(map { $_->[$i] } @_) }
  0            
  0            
209 0           @r;
210             }
211             sub mapn(&@) {
212 0     0 1   my $f = shift;
213 0           smapn($f, MDK::Common::Math::min(map { scalar @$_ } @_), @_);
  0            
214             }
215             sub mapn_(&@) {
216 0     0 1   my $f = shift;
217 0           smapn($f, MDK::Common::Math::max(map { scalar @$_ } @_), @_);
  0            
218             }
219              
220             sub find(&@) {
221 0     0 1   my $f = shift;
222 0   0       $f->($_) and return $_ foreach @_;
223 0           undef;
224             }
225             sub any(&@) {
226 0     0 1   my $f = shift;
227 0   0       $f->($_) and return 1 foreach @_;
228 0           0;
229             }
230             sub every(&@) {
231 0     0 1   my $f = shift;
232 0   0       $f->($_) or return 0 foreach @_;
233 0           1;
234             }
235              
236             sub map_index(&@) {
237 0     0 1   my $f = shift;
238 0           my @v; local $::i = 0;
  0            
239 0           map { @v = $f->(); $::i++; @v } @_;
  0            
  0            
  0            
240             }
241             sub each_index(&@) {
242 0     0 1   my $f = shift;
243 0           local $::i = 0;
244 0           foreach (@_) {
245 0           $f->();
246 0           $::i++;
247             }
248             }
249             sub grep_index(&@) {
250 0     0 1   my $f = shift;
251 0           my $v; local $::i = 0;
  0            
252 0           grep { $v = $f->(); $::i++; $v } @_;
  0            
  0            
  0            
253             }
254             sub find_index(&@) {
255 0     0 1   my $f = shift;
256 0           local $_;
257 0           for (my $i = 0; $i < @_; $i++) {
258 0           $_ = $_[$i];
259 0 0         &$f and return $i;
260             }
261 0           die "find_index failed in @_";
262             }
263             sub map_each(&%) {
264 0     0 1   my ($f, %h) = @_;
265 0           my @l;
266 0           local ($::a, $::b);
267 0           while (($::a, $::b) = each %h) { push @l, &$f($::a, $::b) }
  0            
268 0           @l;
269             }
270             sub grep_each(&%) {
271 0     0 1   my ($f, %h) = @_;
272 0           my %l;
273 0           local ($::a, $::b);
274 0 0         while (($::a, $::b) = each %h) { $l{$::a} = $::b if &$f($::a, $::b) }
  0            
275 0           %l;
276             }
277             sub partition(&@) {
278 0     0 1   my $f = shift;
279 0           my (@a, @b);
280 0           foreach (@_) {
281 0 0         $f->($_) ? push(@a, $_) : push(@b, $_);
282             }
283 0           \@a, \@b;
284             }
285              
286             sub add_f4before_leaving {
287 0     0 0   my ($f, $b, $name) = @_;
288              
289 0           $MDK::Common::Func::before_leaving::_list->{$b}{$name} = $f;
290 0 0         if (!$MDK::Common::Func::before_leaving::_added{$name}) {
291 0           $MDK::Common::Func::before_leaving::_added{$name} = 1;
292 1     1   6 no strict 'refs';
  1         2  
  1         215  
293 0           *{"MDK::Common::Func::before_leaving::$name"} = sub {
294 0 0   0     my $f = $MDK::Common::Func::before_leaving::_list->{$_[0]}{$name} or die '';
295 0 0         $name eq 'DESTROY' and delete $MDK::Common::Func::before_leaving::_list->{$_[0]};
296 0           &$f;
297 0           };
298             }
299             }
300              
301             #- ! the functions are not called in the order wanted, in case of multiple before_leaving :(
302             sub before_leaving(&) {
303 0     0 1   my ($f) = @_;
304 0           my $b = bless {}, 'MDK::Common::Func::before_leaving';
305 0           add_f4before_leaving($f, $b, 'DESTROY');
306 0           $b;
307             }
308              
309             sub catch_cdie(&&) {
310 0     0 1   my ($f, $catch) = @_;
311              
312 0           local @MDK::Common::Func::cdie_catches;
313 0           unshift @MDK::Common::Func::cdie_catches, $catch;
314 0           &$f();
315             }
316              
317             sub cdie {
318 0     0 1   my ($err) = @_;
319 0           foreach (@MDK::Common::Func::cdie_catches) {
320 0           $@ = $err;
321 0 0         if (my $v = $_->(\$err)) {
322 0           return $v;
323             }
324             }
325 0           die $err;
326             }
327              
328             1;
329