line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package Class::LazyObject; |
2
|
8
|
|
|
8
|
|
500649
|
use strict; |
|
8
|
|
|
|
|
24
|
|
|
8
|
|
|
|
|
288
|
|
3
|
8
|
|
|
8
|
|
46
|
use warnings; |
|
8
|
|
|
|
|
19
|
|
|
8
|
|
|
|
|
1534
|
|
4
|
|
|
|
|
|
|
|
5
|
8
|
|
|
8
|
|
48
|
use Carp qw(); |
|
8
|
|
|
|
|
19
|
|
|
8
|
|
|
|
|
297
|
|
6
|
|
|
|
|
|
|
|
7
|
|
|
|
|
|
|
BEGIN { |
8
|
8
|
|
|
8
|
|
40
|
use vars '$VERSION'; |
|
8
|
|
|
|
|
16
|
|
|
8
|
|
|
|
|
693
|
|
9
|
8
|
|
|
8
|
|
182
|
$VERSION = '0.10_1'; |
10
|
|
|
|
|
|
|
} |
11
|
|
|
|
|
|
|
|
12
|
8
|
|
|
8
|
|
42
|
use vars '$AUTOLOAD'; |
|
8
|
|
|
|
|
51
|
|
|
8
|
|
|
|
|
644
|
|
13
|
|
|
|
|
|
|
|
14
|
|
|
|
|
|
|
#We want to inflate calls to methods defined in UNIVERSAL, but we implicitly inherit from UNIVERSAL. |
15
|
|
|
|
|
|
|
#As long as we predeclare the methods here, they will override those in UNIVERSAL, but since they are never defined, AUTOLOAD will be called: |
16
|
8
|
|
|
8
|
|
11476
|
use subs grep {defined UNIVERSAL::can(__PACKAGE__, $_)} keys %UNIVERSAL::; |
|
8
|
|
|
|
|
366
|
|
|
8
|
|
|
|
|
35
|
|
|
32
|
|
|
|
|
274
|
|
17
|
|
|
|
|
|
|
|
18
|
|
|
|
|
|
|
sub AUTOLOAD |
19
|
|
|
|
|
|
|
{ |
20
|
134
|
|
|
134
|
|
74771
|
my $self = $_[0]; #don't shift it, since we will need to access this directly later. |
21
|
|
|
|
|
|
|
|
22
|
134
|
|
|
|
|
775
|
$AUTOLOAD =~ /.*::(\w+)/; |
23
|
134
|
|
|
|
|
486
|
my $method = $1; |
24
|
|
|
|
|
|
|
|
25
|
134
|
|
66
|
|
|
793
|
my $class_method = (ref($self) || $self).'::Methods';#call all class methods on this. |
26
|
|
|
|
|
|
|
|
27
|
134
|
100
|
|
|
|
2045
|
unless (UNIVERSAL::can($class_method, 'inherit')) {#If a class inherits from a class that inherits from Class::LazyObject, it may not have called inherit and therefore won't have ::Methods installed. |
28
|
|
|
|
|
|
|
#One approach might be to call inherit for it, but we're just going to search for an ancestor with a ::Methods that can inherit. |
29
|
36
|
|
66
|
|
|
245
|
my @parent_classes = (Class::ISA::super_path( ref($self)||$self ), 'UNIVERSAL'); |
30
|
36
|
|
|
|
|
2463
|
foreach my $parent_class (@parent_classes){ #We probably want the equivalent of first from Scalar::MoreUtil but this is good for now |
31
|
36
|
|
|
|
|
411
|
$class_method = $parent_class.'::Methods'; |
32
|
36
|
50
|
|
|
|
313
|
last if UNIVERSAL::can($class_method, 'inherit'); |
33
|
|
|
|
|
|
|
} |
34
|
|
|
|
|
|
|
} |
35
|
|
|
|
|
|
|
|
36
|
134
|
100
|
66
|
|
|
651
|
if (($method eq 'new') && !ref($self)) |
37
|
|
|
|
|
|
|
{ |
38
|
|
|
|
|
|
|
#new was called on a class, rather than an object, so we should actually construct ourselves, rather than passing this to whatever we're proxying. |
39
|
56
|
|
|
|
|
248
|
return $class_method->new(@_); |
40
|
|
|
|
|
|
|
} |
41
|
|
|
|
|
|
|
|
42
|
78
|
100
|
|
|
|
515
|
ref($self) or return $class_method->$method(@_[ 1 .. $#_ ]); #If this was called as a class method, pass it on to ::Methods but don't pass OUR package name. |
43
|
|
|
|
|
|
|
|
44
|
70
|
50
|
|
|
|
323
|
print "Lazy...\n" if $class_method->get_classdata('debug'); |
45
|
|
|
|
|
|
|
|
46
|
70
|
|
|
|
|
1523
|
my $object; #this is the object we will eventually replace ourselves with. |
47
|
|
|
|
|
|
|
|
48
|
70
|
100
|
66
|
|
|
309
|
if ( ref($$self) && UNIVERSAL::isa($$self, $class_method->get_classdata('class')) ) |
49
|
|
|
|
|
|
|
{ |
50
|
14
|
|
|
|
|
400
|
$object = $$self; |
51
|
|
|
|
|
|
|
} |
52
|
|
|
|
|
|
|
else |
53
|
|
|
|
|
|
|
{ |
54
|
56
|
|
|
|
|
191
|
$object = $class_method->get_classdata('inflate')->($class_method->get_classdata('class'), $$self); |
55
|
56
|
|
|
|
|
1024
|
$$self = $object; #don't create this again. |
56
|
|
|
|
|
|
|
} |
57
|
|
|
|
|
|
|
|
58
|
70
|
|
|
|
|
123
|
$_[0] = $object; #replace ourselves with the object. |
59
|
|
|
|
|
|
|
|
60
|
|
|
|
|
|
|
goto ( |
61
|
70
|
|
66
|
|
|
947
|
UNIVERSAL::can($_[0], $method) || |
62
|
|
|
|
|
|
|
$class_method->_prepareAUTOLOADRef($_[0], ref($_[0]).'::'.$method) || #UNIVERSAL::can can't detect if a method is AUTOLOADed, so we have to. |
63
|
|
|
|
|
|
|
Carp::croak(sprintf qq{Can\'t locate object method "%s" via package "%s" }, $method, ref $_[0] )#Error message stolen from Class::WhiteHole |
64
|
|
|
|
|
|
|
); |
65
|
|
|
|
|
|
|
} |
66
|
|
|
|
|
|
|
|
67
|
|
|
|
|
|
|
sub DESTROY #You won't AUTOLOAD this! Muahahaha! |
68
|
|
|
|
|
|
|
{ |
69
|
56
|
|
|
56
|
|
6031
|
undef; #This is here because certain perl versions can't handle completely emtpy subs. |
70
|
|
|
|
|
|
|
} |
71
|
|
|
|
|
|
|
|
72
|
|
|
|
|
|
|
|
73
|
|
|
|
|
|
|
#class method to see whether something is lazy? |
74
|
|
|
|
|
|
|
#class methods for original isa and can |
75
|
|
|
|
|
|
|
|
76
|
|
|
|
|
|
|
#--------- |
77
|
|
|
|
|
|
|
package Class::LazyObject::Methods; |
78
|
|
|
|
|
|
|
#stick all of our class methods here so we don't pollute Class::LazyObject's namespace. |
79
|
|
|
|
|
|
|
#everything in this class should be called as class methods, NOT object methods. |
80
|
|
|
|
|
|
|
|
81
|
8
|
|
|
8
|
|
19015
|
use Carp::Clan '^Class::LazyObject(::|$)'; |
|
8
|
|
|
|
|
57950
|
|
|
8
|
|
|
|
|
71
|
|
82
|
8
|
|
|
8
|
|
33229
|
use Class::Data::TIN qw(get_classdata); |
|
8
|
|
|
|
|
153202
|
|
|
8
|
|
|
|
|
954
|
|
83
|
8
|
|
|
8
|
|
11689
|
use Class::ISA; |
|
8
|
|
|
|
|
46698
|
|
|
8
|
|
|
|
|
872
|
|
84
|
|
|
|
|
|
|
|
85
|
|
|
|
|
|
|
sub _findAUTOLOADPackage |
86
|
|
|
|
|
|
|
{ |
87
|
|
|
|
|
|
|
#Takes 1 argument, either an object or the name of a package. |
88
|
|
|
|
|
|
|
#Returns the name of the package containing the sub AUTOLOAD that would be called when $first_arg->AUTOLOAD was called |
89
|
|
|
|
|
|
|
#In other words, it traverses the inheritance hierarchy the same way Perl does until it finds an AUTOLOAD, and returns the name of the package containing the AUTOLOAD. |
90
|
|
|
|
|
|
|
#Returns undef if AUTOLOAD is not in the inheritance hierarchy. |
91
|
|
|
|
|
|
|
|
92
|
24
|
|
|
24
|
|
31
|
shift;#Don't care about our package name. |
93
|
|
|
|
|
|
|
|
94
|
24
|
|
|
|
|
32
|
my $object_or_package = shift; |
95
|
24
|
|
33
|
|
|
66
|
my $orig_class = ref($object_or_package) || $object_or_package; |
96
|
|
|
|
|
|
|
|
97
|
24
|
50
|
|
|
|
114
|
return undef unless UNIVERSAL::can($orig_class, 'AUTOLOAD'); |
98
|
|
|
|
|
|
|
|
99
|
24
|
|
|
|
|
97
|
my @classes = (Class::ISA::self_and_super_path($orig_class), 'UNIVERSAL'); |
100
|
|
|
|
|
|
|
|
101
|
24
|
|
|
|
|
608
|
my $package; |
102
|
24
|
|
|
|
|
117
|
foreach my $class (@classes) |
103
|
|
|
|
|
|
|
{ |
104
|
8
|
|
|
8
|
|
72
|
no strict 'refs';#Symbol table munging ahead |
|
8
|
|
|
|
|
17
|
|
|
8
|
|
|
|
|
1104
|
|
105
|
32
|
|
|
|
|
46
|
$package = $class; |
106
|
32
|
100
|
|
|
|
46
|
last if defined(*{$package.'::AUTOLOAD';}{CODE}); |
|
32
|
|
|
|
|
204
|
|
107
|
|
|
|
|
|
|
} |
108
|
|
|
|
|
|
|
|
109
|
24
|
|
|
|
|
68
|
return $package; |
110
|
|
|
|
|
|
|
} |
111
|
|
|
|
|
|
|
|
112
|
|
|
|
|
|
|
sub _prepareAUTOLOADRef |
113
|
|
|
|
|
|
|
{ |
114
|
|
|
|
|
|
|
#Takes 2 arguments: |
115
|
|
|
|
|
|
|
# either an object or the name of a package |
116
|
|
|
|
|
|
|
# the fully qualified method name to make AUTOLOAD think it was called as a result of |
117
|
|
|
|
|
|
|
#Sets the appropriate package's $AUTOLOAD so that when the AUTOLOAD method is called on the first argument, it will think it was called as a result of a call to the method specified by the second argument. |
118
|
|
|
|
|
|
|
#Returns the result of (UNIVERSAL::can($first_arg, 'AUTOLOAD')); |
119
|
|
|
|
|
|
|
|
120
|
28
|
|
|
28
|
|
51
|
my $class = shift; |
121
|
|
|
|
|
|
|
|
122
|
28
|
|
|
|
|
53
|
my ($object, $method) = @_; |
123
|
|
|
|
|
|
|
|
124
|
28
|
100
|
|
|
|
127
|
if (UNIVERSAL::can($object, 'AUTOLOAD'))#no point in doing any of this if it can't AUTOLOAD. |
125
|
|
|
|
|
|
|
{ |
126
|
24
|
|
|
|
|
81
|
my $package = $class->_findAUTOLOADPackage($object); |
127
|
|
|
|
|
|
|
|
128
|
|
|
|
|
|
|
{ |
129
|
8
|
|
|
8
|
|
45
|
no strict 'refs'; |
|
8
|
|
|
|
|
12
|
|
|
8
|
|
|
|
|
2697
|
|
|
24
|
|
|
|
|
43
|
|
130
|
24
|
|
|
|
|
34
|
*{$package.'::AUTOLOAD'} = \$method; |
|
24
|
|
|
|
|
75
|
|
131
|
|
|
|
|
|
|
} |
132
|
|
|
|
|
|
|
} |
133
|
|
|
|
|
|
|
|
134
|
28
|
|
|
|
|
1147
|
return UNIVERSAL::can($object, 'AUTOLOAD'); |
135
|
|
|
|
|
|
|
} |
136
|
|
|
|
|
|
|
|
137
|
|
|
|
|
|
|
#defaults, these are overridable when someone calls ->inherit |
138
|
|
|
|
|
|
|
Class::Data::TIN->new(__PACKAGE__, |
139
|
|
|
|
|
|
|
inflate => sub {return $_[0]->new_inflate($_[1]);}, |
140
|
|
|
|
|
|
|
debug => 0, |
141
|
|
|
|
|
|
|
); |
142
|
|
|
|
|
|
|
|
143
|
|
|
|
|
|
|
sub inherit |
144
|
|
|
|
|
|
|
{ |
145
|
|
|
|
|
|
|
#calls to Class::LazyObject->inherit are forwarded here. |
146
|
|
|
|
|
|
|
|
147
|
8
|
|
|
8
|
|
17
|
my $class = shift; #don't care about our own package name. |
148
|
8
|
|
|
|
|
36
|
my %params = @_; |
149
|
|
|
|
|
|
|
|
150
|
8
|
|
|
|
|
26
|
my @required_params = qw(inflated_class deflated_class); |
151
|
|
|
|
|
|
|
|
152
|
8
|
|
|
|
|
20
|
foreach my $param (@required_params) |
153
|
|
|
|
|
|
|
{ |
154
|
15
|
100
|
|
|
|
70
|
croak "You did not pass '$param', which is a required parameter." unless exists $params{$param}; |
155
|
|
|
|
|
|
|
} |
156
|
|
|
|
|
|
|
|
157
|
7
|
|
|
|
|
23
|
my %param_map = ( #keys are key names in the parameters passed to this function. Values are corrisponding class data names. |
158
|
|
|
|
|
|
|
inflated_class => 'class' |
159
|
|
|
|
|
|
|
); |
160
|
|
|
|
|
|
|
|
161
|
7
|
|
|
|
|
31
|
my %class_data = %params; |
162
|
7
|
|
|
|
|
27
|
delete @class_data{keys %param_map, 'deflated_class'};#we'll stick these in with their appropriate names: |
163
|
7
|
|
|
|
|
57
|
@class_data{values %param_map} = @params{keys %param_map};#pass the parameters whose names have changed |
164
|
|
|
|
|
|
|
|
165
|
|
|
|
|
|
|
|
166
|
7
|
|
|
|
|
24
|
my $method_package = $params{deflated_class}.'::Methods'; |
167
|
|
|
|
|
|
|
|
168
|
|
|
|
|
|
|
{ |
169
|
8
|
|
|
8
|
|
51
|
no strict 'refs'; #more symbol table munging |
|
8
|
|
|
|
|
15
|
|
|
8
|
|
|
|
|
2136
|
|
|
7
|
|
|
|
|
14
|
|
170
|
7
|
|
|
|
|
10
|
push(@{$method_package.'::ISA'}, $class); #Create a package to hold all the methods, that inherits from THIS class, or add this class to its inheritance if it does exist. #Should this be $class instead of __PACKAGE__ |
|
7
|
|
|
|
|
113
|
|
171
|
|
|
|
|
|
|
#^Push is used instead of unshift so that someone can override their ::Methods package with its own inheritence hierarchy, and methods will be called here only AFTER Perl finds they don't exist in the overridden ISA. |
172
|
|
|
|
|
|
|
} |
173
|
|
|
|
|
|
|
|
174
|
7
|
|
|
|
|
59
|
Class::Data::TIN->new($method_package, %class_data); |
175
|
|
|
|
|
|
|
} |
176
|
|
|
|
|
|
|
|
177
|
|
|
|
|
|
|
sub new |
178
|
|
|
|
|
|
|
{ |
179
|
56
|
|
|
56
|
|
2274
|
my ($own_package, $class, $id) = @_;#first argument is this method's, class, not the lazy object's |
180
|
|
|
|
|
|
|
|
181
|
56
|
50
|
33
|
|
|
200
|
if (ref($id) && UNIVERSAL::isa($id, $own_package->get_classdata('class'))) |
182
|
|
|
|
|
|
|
{ |
183
|
0
|
|
|
|
|
0
|
croak "A Lazy Object's ID cannot be a an object of same class (or of a class inherited from the one) it is proxying!"; |
184
|
|
|
|
|
|
|
} |
185
|
|
|
|
|
|
|
|
186
|
56
|
|
|
|
|
292
|
return bless \$id, $class; |
187
|
|
|
|
|
|
|
} |
188
|
|
|
|
|
|
|
|
189
|
|
|
|
|
|
|
1; |
190
|
|
|
|
|
|
|
|
191
|
|
|
|
|
|
|
#LAUNDRY LIST: |
192
|
|
|
|
|
|
|
#LAZYNESS, impatience, hubris |
193
|
|
|
|
|
|
|
#should we document the $AUTOLOAD persistence thingy as a caveat? |
194
|
|
|
|
|
|
|
#CALLING AUTOLOAD on inflate |
195
|
|
|
|
|
|
|
#CAVEAT: can't distinguish between no id and an id of undef. |
196
|
|
|
|
|
|
|
# -solve by storing a Class::LazyObject::NoID object instead of undef? |
197
|
|
|
|
|
|
|
#Does goto propogate scalar/list context? |
198
|
|
|
|
|
|
|
#Lvalue subs? |
199
|
|
|
|
|
|
|
#PROBLEM: Can't inherit from a lazy object (that has already called inherit) it right now without calling inherit because the corrisponding ::Methods class hasn't been created yet. Instead of being completely nonpolluting, can we create a method with a long convoluted name like __________Class_____LazyObject______Find____Methods and use the NEXT module to make redispatch any calls of it that are object method calls instead of static class calls? |
200
|
|
|
|
|
|
|
#Does ORL's can work correctly for classes that inherit from an unrealized class? |
201
|
|
|
|
|
|
|
|
202
|
|
|
|
|
|
|
|
203
|
|
|
|
|
|
|
__END__ |