File Coverage

blib/lib/PerlX/Maybe.pm
Criterion Covered Total %
statement 62 75 82.6
branch 25 30 83.3
condition 3 6 50.0
subroutine 12 14 85.7
pod 2 2 100.0
total 104 127 81.8


line stmt bran cond sub pod time code
1 5     5   340268 use 5.006;
  5         56  
2 5     5   25 use strict;
  5         9  
  5         123  
3 5     5   25 use warnings;
  5         17  
  5         682  
4              
5             package PerlX::Maybe;
6              
7             BEGIN {
8 5     5   17 our $AUTHORITY = 'cpan:TOBYINK';
9 5         9 our $VERSION = '1.201';
10            
11 5         23 our @EXPORT = qw/ maybe /;
12 5         18 our @EXPORT_OK = qw/ maybe provided provided_deref provided_deref_with_maybe/;
13 5         257 our %EXPORT_TAGS = (all => \@EXPORT_OK, default => \@EXPORT);
14             }
15              
16             sub import
17             {
18 5 100 33 5   65 if (@_ == 1)
    50          
19             {
20 2         5 my $caller = caller;
21 5     5   40 no strict 'refs';
  5         9  
  5         649  
22 2         4 *{"$caller\::maybe"} = \&maybe;
  2         11  
23 2         1457 return;
24             }
25             elsif (grep ref||/^-/, @_)
26             {
27 0         0 require Exporter::Tiny;
28 0         0 our @ISA = qw/ Exporter::Tiny /;
29 5     5   53 no warnings 'redefine';
  5         9  
  5         691  
30 0         0 *import = \&Exporter::Tiny::import;
31 0         0 *unimport = \&Exporter::Tiny::unimport;
32 0         0 goto \&Exporter::Tiny::import;
33             }
34 3         41 require Exporter;
35 3         5127 goto \&Exporter::import;
36             }
37              
38             sub unimport
39             {
40 0     0   0 require Exporter::Tiny;
41 0         0 our @ISA = qw/ Exporter::Tiny /;
42 5     5   34 no warnings 'redefine';
  5         10  
  5         2901  
43 0         0 *import = \&Exporter::Tiny::import;
44 0         0 *unimport = \&Exporter::Tiny::unimport;
45 0         0 goto \&Exporter::Tiny::unimport;
46             }
47              
48             sub _croak
49             {
50 0     0   0 require Carp;
51 0         0 goto \&Carp::croak;
52             }
53              
54             unless (($ENV{PERLX_MAYBE_IMPLEMENTATION}||'') =~ /pp/i)
55             {
56 5     5   2324 eval q{ use PerlX::Maybe::XS 0.003 ':all' };
  5         3196  
  5         672  
57             }
58              
59             __PACKAGE__->can('maybe') ? eval <<'END_XS' : eval <<'END_PP';
60              
61             sub IMPLEMENTATION () { "XS" }
62              
63             END_XS
64              
65             sub IMPLEMENTATION () { "PP" }
66              
67             sub maybe ($$@)
68             {
69             if (defined $_[0] and defined $_[1])
70             {
71             @_
72             }
73             else
74             {
75             (scalar @_ > 1) ? @_[2 .. $#_] : qw()
76             }
77             }
78              
79             sub provided ($$$@)
80             {
81             if (shift)
82             {
83             @_
84             }
85             else
86             {
87             (scalar @_ > 1) ? @_[2 .. $#_] : qw()
88             }
89             }
90              
91             END_PP
92              
93             sub provided_deref ($$@)
94             {
95 18     18 1 133 unshift @_, 0;
96 18         49 goto \&_provided_magic;
97             }
98              
99             sub provided_deref_with_maybe ($$@)
100             {
101 18     18 1 132 unshift @_, 1;
102 18         41 goto \&_provided_magic;
103             }
104              
105             sub _provided_magic ($$$@)
106             {
107 36     36   57 my $m = shift; # maybe, clean up private keys
108            
109 36 100       64 if (shift)
110             {
111 24         65 my $r = shift;
112 24         52 my $t = ref $r;
113 24 50       44 _croak "Not a reference, $r" unless $t;
114            
115 24         30 my @vals;
116 24 100       59 if ($t eq 'ARRAY')
    100          
    100          
    50          
117             {
118 8 100       49 return (@$r, @_) unless $m;
119 4         8 @vals = @$r;
120             }
121            
122             elsif ($t eq 'CODE')
123             {
124 2 100       8 return ($r->(), @_) unless $m;
125 1         3 @vals = $r->();
126             }
127              
128             elsif ($t eq 'HASH')
129             {
130 8 100       32 return (%$r, @_) unless $m;
131 4         11 @vals = %$r;
132             }
133            
134 6         26 elsif (do { require Scalar::Util; Scalar::Util::blessed($r) })
  6         27  
135             {
136 6         11 my %vals = eval { %$r };
  6         24  
137 6 50       16 _croak "Can not unwrap $r into a hash" if $@;
138 6 100       23 return (%vals, @_) unless $m;
139            
140 3         24 delete $vals{$_} for grep /^_/, keys %vals;
141 3         11 @vals = %vals;
142             }
143              
144             else
145             {
146 0         0 _croak "Can not dereference, $r ... yet";
147             }
148            
149 12         23 my @return;
150 12         27 for (my $i = 0; $i < @vals; $i+=2) {
151 11 100 66     55 push @return, $vals[$i], $vals[$i+1] if defined $vals[$i] && defined $vals[$i+1];
152             }
153            
154 12         59 return (@return, @_);
155             }
156             else
157             {
158 12 50       96 (scalar @_ > 0) ? @_[1 .. $#_] : qw()
159             }
160             }
161              
162             __FILE__
163             __END__