File Coverage

blib/lib/Sub/Operable.pm
Criterion Covered Total %
statement 68 72 94.4
branch 11 20 55.0
condition n/a
subroutine 18 18 100.0
pod 0 4 0.0
total 97 114 85.0


line stmt bran cond sub pod time code
1 4     4   275532 use 5.008009;
  4         45  
2 4     4   23 use strict;
  4         8  
  4         105  
3 4     4   21 use warnings;
  4         6  
  4         166  
4 4     4   4907 use overload ();
  4         4019  
  4         454  
5              
6             package Sub::Operable;
7              
8             our $AUTHORITY = 'cpan:TOBYINK';
9             our $VERSION = '0.002';
10              
11 4         635 use constant PREFIX_OPS => map split(/ /, $overload::ops{$_}), qw(
12             unary
13             func
14 4     4   35 );
  4         10  
15              
16 4         1002 use constant INFIX_OPS => map split(/ /, $overload::ops{$_}), qw(
17             with_assign
18             num_comparison
19             3way_comparison
20             str_comparison
21             binary
22             matching
23 4     4   31 );
  4         8  
24              
25             'overload'->import(
26             (map {
27             my $op = $_;
28             $op => sub {
29 3 50   3   2582 my $next = $_[0]->can('do_prefix_op') or die;
30 3         15 splice(@_, 1, 0, $op); goto $next;
  3         9  
31             }
32             } PREFIX_OPS),
33             (map {
34             my $op = $_;
35             $op => sub {
36 9 50   9   1884 my $next = $_[0]->can('do_infix_op') or die;
37 9         34 splice(@_, 1, 0, $op); goto $next;
  9         29  
38             }
39             } INFIX_OPS),
40             );
41              
42 4     4   1829 use isa __PACKAGE__;
  4         17885  
  4         24  
43              
44 4     4   2270 use Exporter::Shiny qw( isa_Sub_Operable subop );
  4         16641  
  4         28  
45              
46             sub new {
47 28     28 0 178 my ( $class, $coderef ) = ( shift, @_ );
48 28         73 my $wrapped = $class->build_wrapped_coderef( $coderef );
49 28         134 bless $wrapped, $class;
50             }
51              
52             sub build_wrapped_coderef {
53 28     28 0 76 my ( $class, $orig ) = ( shift, @_ );
54             return sub {
55 66     66   5012 my $has_subops = grep isa_Sub_Operable($_), @_;
56 66 100       126 if ( $has_subops ) {
57 8         18 my @args = @_;
58             my $new = sub {
59 14     4   30 my @inner_args = @_;
60 14         25 @_ = ();
61 14         25 foreach my $arg ( @args ) {
62 14 50       51 push @_, isa_Sub_Operable($arg) ? $arg->(@inner_args) : $arg;
63             }
64 14         65 local *_ = \$_[0];
65 14         28 &$orig;
66 8         40 };
67 8         25 return $class->new($new);
68             }
69             else {
70 58         97 local *_ = \$_[0];
71 58         409 &$orig;
72             }
73 28         108 };
74             }
75              
76             sub do_infix_op {
77 9     9 0 28 my ( $x, $op, $y, $swap ) = @_;
78 9         16 my $class = ref($x);
79 9 50       25 ( $x, $y ) = ( $y, $x ) if $swap;
80            
81 9         31 my $code;
82            
83 9 50       48 if ( isa_Sub_Operable $x ) {
84 9 100       26 if ( isa_Sub_Operable $y ) {
85 6         29 $code = sprintf( 'sub { $x->(@_) %s $y->(@_) }', $op );
86             }
87             else {
88 3         14 $code = sprintf( 'sub { $x->(@_) %s $y }', $op );
89             }
90             }
91             else {
92 0 0       0 if ( isa_Sub_Operable $y ) {
93 0         0 $code = sprintf( 'sub { $x %s $y->(@_) }', $op );
94             }
95             else {
96 0         0 $code = sprintf( 'sub { $x %s $y }', $op );
97             }
98             }
99            
100 9         766 $class->new( scalar eval $code );
101             }
102              
103             sub do_prefix_op {
104 3     3 0 11 my ( $x, $op ) = @_;
105 3         6 my $class = ref($x);
106            
107 3 50       12 if ( $op eq 'neg' ) {
108 3         7 $op = '-';
109             }
110            
111 3         5 my $code;
112            
113 3 50       15 if ( isa_Sub_Operable $x ) {
114 3         15 $code = sprintf( 'sub { %s $x->(@_) }', $op );
115             }
116             else {
117 0         0 $code = sprintf( 'sub { %s $x }', $op );
118             }
119            
120 3         255 my $coderef = eval $code;
121 3         14 $class->new( $coderef );
122             }
123              
124             sub _generate_subop {
125 3     3   620 my ( $class ) = ( shift );
126 3     6   39 return sub (&) { $class->new(@_) };
  6         304  
127             }
128              
129             1;
130              
131             __END__