File Coverage

blib/lib/Callback.pm
Criterion Covered Total %
statement 49 54 90.7
branch 15 20 75.0
condition 2 3 66.6
subroutine 5 6 83.3
pod 0 4 0.0
total 71 87 81.6


line stmt bran cond sub pod time code
1              
2             package Callback;
3              
4             require Exporter;
5             require UNIVERSAL;
6              
7             $VERSION = $VERSION = 1.07;
8             @ISA = (Exporter);
9             @EXPORT_OK = qw(@callbackTrace);
10              
11 4     4   3261 use strict;
  4         6  
  4         3849  
12              
13             sub new
14             {
15 16     16 0 30529 my ($package,$func,@args) = @_;
16 16         67 my ($p, $file, $line) = caller(0);
17 16         29 my @method;
18 16 100 66     115 if (ref $func ne 'CODE' && UNIVERSAL::isa($func, "UNIVERSAL")) {
19 10 100       75 if ($func->isa('Callback')) {
20 2 100       7 return $func unless @args;
21 1         5 my $new = bless { %$func }, $package;
22 1         2 push(@{$new->{ARGS}}, @args);
  1         2  
23 1         3 return $new;
24             } else {
25 8         21 my $method = shift @args;
26 8         15 my $obj = $func;
27 8         45 $func = $obj->can($method);
28 8 100       33 unless (defined $func) {
29 1         12 require Carp;
30 1         315 Carp::croak("Can't locate method '$method' for object $obj");
31             }
32 7         16 unshift(@args, $obj);
33 7         20 @method = (METHOD => $method); # For Storable hooks
34             }
35             }
36 13         85 my $x = {
37             FUNC => $func,
38             ARGS => [@args],
39             CALLER => "$file:$line",
40             @method
41             };
42 13         50 return bless $x, $package;
43             }
44              
45             sub call
46             {
47 15     15 0 59 my ($this, @args) = @_;
48 15         22 my ($ret, @ret);
49              
50 15         56 unshift(@Callback::callbackTrace, $this->{CALLER});
51 15 50       29 if (wantarray) {
52 0         0 @ret = eval {&{$this->{FUNC}}(@{$this->{ARGS}},@args)};
  0         0  
  0         0  
  0         0  
53             } else {
54 15         19 $ret = eval {&{$this->{FUNC}}(@{$this->{ARGS}},@args)};
  15         12  
  15         50  
  15         29  
55             }
56 15         100 shift(@Callback::callbackTrace);
57 15 50       34 die $@ if $@;
58 15 50       29 return @ret if wantarray;
59 15         29 return $ret;
60             }
61              
62             sub DELETE
63 0     0   0 {
64             }
65              
66             #
67             # Storable hooks
68             #
69             # We cannot serialize something containing a pure CODE ref, which is the
70             # case if there's no METHOD attribute in the object.
71             #
72             # However, when Callback is a method call, we can remove the FUNC attribute
73             # and serialize the object: the function address will be recomputed at
74             # retrieve time.
75             #
76              
77             sub STORABLE_freeze {
78 2     2 0 70 my ($self, $cloning) = @_;
79 2 50       12 return if $cloning;
80              
81 2         9 my %copy = %$self;
82 2 100       13 die "cannot store $self since it contains CODE references\n"
83             unless exists $copy{METHOD};
84              
85 1         3 delete $copy{FUNC};
86 1         114 return ("", \%copy);
87             }
88              
89             sub STORABLE_thaw {
90 1     1 0 44 my ($self, $cloning, $x, $copy) = @_;
91              
92 1         5 %$self = %$copy;
93              
94 1         3 my $method = $self->{METHOD};
95 1         2 my $obj = $self->{ARGS}->[0];
96 1         5 my $func = $obj->can($method);
97 1 50       4 die("cannot restore $self: can't locate method '$method' on object $obj")
98             unless defined $func;
99              
100 1         1 $self->{FUNC} = $func;
101 1         15 return;
102             }
103              
104             1;
105