File Coverage

blib/lib/Class/LazyObject.pm
Criterion Covered Total %
statement 95 96 98.9
branch 18 22 81.8
condition 12 21 57.1
subroutine 19 19 100.0
pod n/a
total 144 158 91.1


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__