line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
######################################################################## |
2
|
|
|
|
|
|
|
# Object::Trampoline |
3
|
|
|
|
|
|
|
# delay construction of objects until they are needed. |
4
|
|
|
|
|
|
|
# |
5
|
|
|
|
|
|
|
# the only purpose for the top two classes is having an autoload |
6
|
|
|
|
|
|
|
# that blesses things into O::T::Bounce. |
7
|
|
|
|
|
|
|
######################################################################## |
8
|
|
|
|
|
|
|
######################################################################## |
9
|
|
|
|
|
|
|
# housekeeping |
10
|
|
|
|
|
|
|
######################################################################## |
11
|
|
|
|
|
|
|
|
12
|
|
|
|
|
|
|
package Object::Trampoline; |
13
|
4
|
|
|
4
|
|
3677
|
use v5.12; |
|
4
|
|
|
|
|
11
|
|
|
4
|
|
|
|
|
152
|
|
14
|
|
|
|
|
|
|
|
15
|
4
|
|
|
4
|
|
19
|
use Carp; |
|
4
|
|
|
|
|
4
|
|
|
4
|
|
|
|
|
1320
|
|
16
|
|
|
|
|
|
|
|
17
|
|
|
|
|
|
|
######################################################################## |
18
|
|
|
|
|
|
|
# package variables |
19
|
|
|
|
|
|
|
######################################################################## |
20
|
|
|
|
|
|
|
|
21
|
|
|
|
|
|
|
our $VERSION = '1.41'; |
22
|
|
|
|
|
|
|
$VERSION = eval $VERSION; |
23
|
|
|
|
|
|
|
|
24
|
|
|
|
|
|
|
# minimal sanity check for valid class name, used in both |
25
|
|
|
|
|
|
|
# O::T and O::T::U. |
26
|
|
|
|
|
|
|
|
27
|
|
|
|
|
|
|
my $pkg_rx = qr{^ [_A-Za-z](?:\w*) (?:::\w+)* $}x; |
28
|
|
|
|
|
|
|
|
29
|
|
|
|
|
|
|
######################################################################## |
30
|
|
|
|
|
|
|
# AUTOLOAD is the only public interface |
31
|
|
|
|
|
|
|
######################################################################## |
32
|
|
|
|
|
|
|
######################################################################## |
33
|
|
|
|
|
|
|
# |
34
|
|
|
|
|
|
|
# start by grabbing the destination class and its arguments |
35
|
|
|
|
|
|
|
# off the stack. the constructor name is whatever is |
36
|
|
|
|
|
|
|
# being autoloaded. |
37
|
|
|
|
|
|
|
# |
38
|
|
|
|
|
|
|
# there may not be any arguments... either way i need |
39
|
|
|
|
|
|
|
# to make a lexical copy of the stack for use in the |
40
|
|
|
|
|
|
|
# closure. |
41
|
|
|
|
|
|
|
# |
42
|
|
|
|
|
|
|
# the closure delays actual contstruction until it is |
43
|
|
|
|
|
|
|
# dereferenced in O::T::Bounce::AUTOLOAD. |
44
|
|
|
|
|
|
|
# |
45
|
|
|
|
|
|
|
# $sub is syntatic sugar but is inexpensive enough to |
46
|
|
|
|
|
|
|
# construct. |
47
|
|
|
|
|
|
|
# |
48
|
|
|
|
|
|
|
# Note: there are no DESTROY blocks in the constructing |
49
|
|
|
|
|
|
|
# classes since no objects ever live there: they begin |
50
|
|
|
|
|
|
|
# life in O::T::Bounce. |
51
|
|
|
|
|
|
|
|
52
|
|
|
|
|
|
|
our $AUTOLOAD = ''; |
53
|
|
|
|
|
|
|
|
54
|
|
|
|
|
|
|
AUTOLOAD |
55
|
|
|
|
|
|
|
{ |
56
|
|
|
|
|
|
|
# discard this class: once here it is used up. |
57
|
|
|
|
|
|
|
# lacking a prototype is fatal; anything else becomes |
58
|
|
|
|
|
|
|
# a run-time error. |
59
|
|
|
|
|
|
|
|
60
|
10
|
|
|
10
|
|
1777
|
my ( undef, $proto, @argz ) = @_; |
61
|
|
|
|
|
|
|
|
62
|
10
|
100
|
|
|
|
29
|
$proto |
63
|
|
|
|
|
|
|
or croak "Object::Trampoline: false prototype."; |
64
|
|
|
|
|
|
|
|
65
|
7
|
|
|
|
|
21
|
my $method = ( split /::/, "$AUTOLOAD" )[ -1 ]; |
66
|
|
|
|
|
|
|
|
67
|
7
|
|
|
7
|
|
25
|
my $sub = sub { $proto->$method( @argz ) }; |
|
7
|
|
|
|
|
29
|
|
68
|
|
|
|
|
|
|
|
69
|
7
|
|
|
|
|
25
|
bless $sub, 'Object::Trampoline::Bounce' |
70
|
|
|
|
|
|
|
} |
71
|
|
|
|
|
|
|
|
72
|
|
|
|
|
|
|
######################################################################## |
73
|
|
|
|
|
|
|
# same gizmo as O::T except that the class is use-ed before the |
74
|
|
|
|
|
|
|
# constructor is called. |
75
|
|
|
|
|
|
|
######################################################################## |
76
|
|
|
|
|
|
|
# housekeeping |
77
|
|
|
|
|
|
|
######################################################################## |
78
|
|
|
|
|
|
|
|
79
|
|
|
|
|
|
|
package Object::Trampoline::Use; |
80
|
4
|
|
|
4
|
|
61
|
use v5.12; |
|
4
|
|
|
|
|
12
|
|
|
4
|
|
|
|
|
161
|
|
81
|
|
|
|
|
|
|
|
82
|
4
|
|
|
4
|
|
20
|
use Carp; |
|
4
|
|
|
|
|
6
|
|
|
4
|
|
|
|
|
1496
|
|
83
|
|
|
|
|
|
|
|
84
|
|
|
|
|
|
|
######################################################################## |
85
|
|
|
|
|
|
|
# package variables |
86
|
|
|
|
|
|
|
######################################################################## |
87
|
|
|
|
|
|
|
|
88
|
|
|
|
|
|
|
*VERSION = \$Object::Trampoline::VERSION; |
89
|
|
|
|
|
|
|
|
90
|
|
|
|
|
|
|
our $AUTOLOAD = ''; |
91
|
|
|
|
|
|
|
|
92
|
|
|
|
|
|
|
######################################################################## |
93
|
|
|
|
|
|
|
# AUTOLOAD is the only public interface |
94
|
|
|
|
|
|
|
######################################################################## |
95
|
|
|
|
|
|
|
|
96
|
|
|
|
|
|
|
AUTOLOAD |
97
|
|
|
|
|
|
|
{ |
98
|
|
|
|
|
|
|
# this version does slightly more work since it |
99
|
|
|
|
|
|
|
# has to put using the module into the caller's |
100
|
|
|
|
|
|
|
# class before calling the constructor. |
101
|
|
|
|
|
|
|
# |
102
|
|
|
|
|
|
|
# the eval is unavoidable since use requires the |
103
|
|
|
|
|
|
|
# module's package name as a bareword. |
104
|
|
|
|
|
|
|
|
105
|
4
|
|
|
4
|
|
1619
|
my ( undef, $proto, @argz ) = @_; |
106
|
|
|
|
|
|
|
|
107
|
4
|
100
|
|
|
|
15
|
$proto |
108
|
|
|
|
|
|
|
or croak "Object::Trampoline::Use: false prototype."; |
109
|
|
|
|
|
|
|
|
110
|
|
|
|
|
|
|
# sanity check: the prototype is words glued together with |
111
|
|
|
|
|
|
|
# double-colons. not perfect but worthwhile since most |
112
|
|
|
|
|
|
|
# injection attempts will at least require a path or space. |
113
|
|
|
|
|
|
|
|
114
|
1
|
|
|
|
|
4
|
for( split '::' => $proto ) |
115
|
|
|
|
|
|
|
{ |
116
|
1
|
50
|
|
|
|
8
|
/\W/ and croak |
117
|
|
|
|
|
|
|
"Botched trampoline_use: '$_' invalid module name"; |
118
|
|
|
|
|
|
|
} |
119
|
|
|
|
|
|
|
|
120
|
|
|
|
|
|
|
# Note: add a sanity pre-check w/ warning for non-existant |
121
|
|
|
|
|
|
|
# module. |
122
|
|
|
|
|
|
|
|
123
|
1
|
|
|
|
|
5
|
my $method = ( split /::/, $AUTOLOAD )[ -1 ]; |
124
|
1
|
|
|
|
|
2
|
my $caller = caller; |
125
|
|
|
|
|
|
|
|
126
|
1
|
|
|
|
|
4
|
my $init |
127
|
|
|
|
|
|
|
= qq |
128
|
|
|
|
|
|
|
{ |
129
|
|
|
|
|
|
|
package $caller; |
130
|
|
|
|
|
|
|
use $proto |
131
|
|
|
|
|
|
|
}; |
132
|
|
|
|
|
|
|
|
133
|
|
|
|
|
|
|
my $sub = |
134
|
|
|
|
|
|
|
sub |
135
|
|
|
|
|
|
|
{ |
136
|
1
|
50
|
|
1
|
|
90
|
eval "$init" |
|
1
|
|
|
1
|
|
274
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
137
|
|
|
|
|
|
|
or croak "Failed: $init\n$@"; |
138
|
|
|
|
|
|
|
|
139
|
0
|
|
|
|
|
0
|
$proto->$method( @argz ) |
140
|
1
|
|
|
|
|
5
|
}; |
141
|
|
|
|
|
|
|
|
142
|
1
|
|
|
|
|
4
|
bless $sub, 'Object::Trampoline::Bounce' |
143
|
|
|
|
|
|
|
} |
144
|
|
|
|
|
|
|
|
145
|
|
|
|
|
|
|
######################################################################## |
146
|
|
|
|
|
|
|
# where the object ends up. All this does is possibly use the package |
147
|
|
|
|
|
|
|
# then construct the object and dispatch the call to whatever the |
148
|
|
|
|
|
|
|
# caller was looking for -- which may fail if the package doesn't |
149
|
|
|
|
|
|
|
# implement the method. |
150
|
|
|
|
|
|
|
# |
151
|
|
|
|
|
|
|
# $_[0] = $_[0]->() replaces the trampoline argument |
152
|
|
|
|
|
|
|
# with the real thing by calling its constructor -- call |
153
|
|
|
|
|
|
|
# by reference is a Very Good Thing. |
154
|
|
|
|
|
|
|
# |
155
|
|
|
|
|
|
|
# after that it can be shifted off and used to access |
156
|
|
|
|
|
|
|
# the method. note that this is necessary in order |
157
|
|
|
|
|
|
|
# to allow for classes which implement their methods |
158
|
|
|
|
|
|
|
# via AUTOLOAD (which will defeat using $obj->can( $name )). |
159
|
|
|
|
|
|
|
# |
160
|
|
|
|
|
|
|
# note that it's up to the caller to deal with any exceptions |
161
|
|
|
|
|
|
|
# that come out of calling the method. |
162
|
|
|
|
|
|
|
# |
163
|
|
|
|
|
|
|
# goto is a more effecient way to get there if the class |
164
|
|
|
|
|
|
|
# has an explicit method for handling the call; otherwise |
165
|
|
|
|
|
|
|
# use the name to dispatch the call. |
166
|
|
|
|
|
|
|
|
167
|
|
|
|
|
|
|
package Object::Trampoline::Bounce; |
168
|
|
|
|
|
|
|
|
169
|
4
|
|
|
4
|
|
46
|
use v5.12; |
|
4
|
|
|
|
|
13
|
|
|
4
|
|
|
|
|
169
|
|
170
|
|
|
|
|
|
|
|
171
|
4
|
|
|
4
|
|
21
|
use Carp; |
|
4
|
|
|
|
|
6
|
|
|
4
|
|
|
|
|
282
|
|
172
|
|
|
|
|
|
|
|
173
|
4
|
|
|
4
|
|
26
|
use Scalar::Util qw( blessed ); |
|
4
|
|
|
|
|
4
|
|
|
4
|
|
|
|
|
482
|
|
174
|
4
|
|
|
4
|
|
2671
|
use Symbol qw( qualify_to_ref ); |
|
4
|
|
|
|
|
3790
|
|
|
4
|
|
|
|
|
1385
|
|
175
|
|
|
|
|
|
|
|
176
|
|
|
|
|
|
|
*VERSION = \$Object::Trampoline::VERSION; |
177
|
|
|
|
|
|
|
|
178
|
|
|
|
|
|
|
our $AUTOLOAD = ''; |
179
|
|
|
|
|
|
|
|
180
|
|
|
|
|
|
|
AUTOLOAD |
181
|
|
|
|
|
|
|
{ |
182
|
|
|
|
|
|
|
# caller gets back any execption as-is. |
183
|
|
|
|
|
|
|
|
184
|
8
|
50
|
|
8
|
|
966
|
$_[0] = $_[0]->() |
185
|
|
|
|
|
|
|
or croak "Failed constructor"; |
186
|
|
|
|
|
|
|
|
187
|
7
|
50
|
|
|
|
112
|
my $class = blessed $_[0] |
188
|
|
|
|
|
|
|
or croak "Failed constructor: '$_[0]' not blessed"; |
189
|
|
|
|
|
|
|
|
190
|
7
|
|
|
|
|
16
|
my $method = ( split /::/, $AUTOLOAD )[ -1 ]; |
191
|
|
|
|
|
|
|
|
192
|
7
|
50
|
|
|
|
44
|
if( my $sub = $class->can( $method ) ) |
193
|
|
|
|
|
|
|
{ |
194
|
7
|
|
|
|
|
31
|
goto &$sub |
195
|
|
|
|
|
|
|
} |
196
|
|
|
|
|
|
|
else |
197
|
|
|
|
|
|
|
{ |
198
|
|
|
|
|
|
|
# deal with autoloaded methods, or die trying... |
199
|
|
|
|
|
|
|
|
200
|
0
|
|
|
|
|
0
|
my $obj = shift; |
201
|
|
|
|
|
|
|
|
202
|
0
|
|
|
|
|
0
|
$obj->$method( @_ ) |
203
|
|
|
|
|
|
|
} |
204
|
|
|
|
|
|
|
} |
205
|
|
|
|
|
|
|
|
206
|
|
|
|
|
|
|
# re-route methods from UNIVERSAL through the bounce. |
207
|
|
|
|
|
|
|
|
208
|
|
|
|
|
|
|
for my $name ( keys %{ $::{ 'UNIVERSAL::' } } ) |
209
|
|
|
|
|
|
|
{ |
210
|
|
|
|
|
|
|
*{ qualify_to_ref $name } |
211
|
|
|
|
|
|
|
= sub |
212
|
|
|
|
|
|
|
{ |
213
|
4
|
|
|
4
|
|
18
|
$AUTOLOAD = $name; |
214
|
|
|
|
|
|
|
|
215
|
4
|
|
|
|
|
11
|
goto &AUTOLOAD |
216
|
|
|
|
|
|
|
}; |
217
|
|
|
|
|
|
|
} |
218
|
|
|
|
|
|
|
|
219
|
|
|
|
|
|
|
# stub destroy dodges AUTOLOAD for unused trampolines. |
220
|
|
|
|
|
|
|
|
221
|
0
|
|
|
0
|
|
0
|
DESTROY {} |
222
|
|
|
|
|
|
|
|
223
|
|
|
|
|
|
|
# keep require happy |
224
|
|
|
|
|
|
|
|
225
|
|
|
|
|
|
|
1 |
226
|
|
|
|
|
|
|
|
227
|
|
|
|
|
|
|
__END__ |