File Coverage

blib/lib/autobox.pm
Criterion Covered Total %
statement 175 181 96.6
branch 60 72 83.3
condition 6 9 66.6
subroutine 24 25 96.0
pod n/a
total 265 287 92.3


line stmt bran cond sub pod time code
1             package autobox;
2              
3 19     19   224004 use 5.008;
  19         54  
4              
5 19     19   69 use strict;
  19         23  
  19         364  
6 19     19   62 use warnings;
  19         26  
  19         458  
7              
8 19     19   67 use Carp;
  19         34  
  19         1607  
9 19     19   74 use XSLoader;
  19         21  
  19         319  
10 19     19   56 use Scalar::Util;
  19         28  
  19         841  
11 19     19   8012 use Scope::Guard;
  19         6167  
  19         772  
12 19     19   11000 use Storable;
  19         47454  
  19         1255  
13              
14             our $VERSION = '2.85';
15              
16             XSLoader::load 'autobox', $VERSION;
17              
18 19     19   6173 use autobox::universal (); # don't import
  19         32  
  19         4814  
19              
20             ############################################# PRIVATE ###############################################
21              
22             my $SEQ = 0; # unique identifier for synthetic classes
23             my $BINDINGS_CACHE = {}; # hold a reference to the bindings hashes
24             my $CLASS_CACHE = {}; # reuse the same synthetic class if the @isa has been seen before
25              
26             # all supported types
27             # the boolean indicates whether the type is a real internal type (as opposed to a virtual type)
28             my %TYPES = (
29             UNDEF => 1,
30             INTEGER => 1,
31             FLOAT => 1,
32             NUMBER => 0,
33             STRING => 1,
34             SCALAR => 0,
35             ARRAY => 1,
36             HASH => 1,
37             CODE => 1,
38             UNIVERSAL => 0
39             );
40              
41             # type hierarchy: keys are parents, values are (depth, children) pairs
42             my %ISA = (
43             UNIVERSAL => [ 0, [ qw(SCALAR ARRAY HASH CODE) ] ],
44             SCALAR => [ 1, [ qw(STRING NUMBER) ] ],
45             NUMBER => [ 2, [ qw(INTEGER FLOAT) ] ]
46             );
47              
48             # default bindings when no args are supplied
49             my %DEFAULT = (
50             SCALAR => 'SCALAR',
51             ARRAY => 'ARRAY',
52             HASH => 'HASH',
53             CODE => 'CODE'
54             );
55              
56             # reinvent List::MoreUtils::uniq to keep the dependencies light - return a reference
57             # to an array containing (in order) the unique members of the supplied list
58             sub _uniq($) {
59 470     470   344 my $list = shift;
60 470         316 my (%seen, @uniq);
61              
62 470         431 for my $element (@$list) {
63 788 100       1761 next if ($seen{$element});
64 752         579 push @uniq, $element;
65 752         785 $seen{$element} = 1;
66             }
67              
68 470         836 return [ @uniq ];
69             }
70              
71             # create a shim class - actual methods are implemented by the classes in its @ISA
72             #
73             # as an optimization, return the previously-generated class
74             # if we've seen the same (canonicalized) @isa before
75             sub _generate_class($) {
76 470     470   488 my $isa = _uniq(shift);
77              
78             # As an optimization, simply return the class if there's only one.
79             # This speeds up method lookup as the method can (often) be found directly in the stash
80             # rather than in the ISA hierarchy with its attendant AUTOLOAD-related overhead
81 470 100       670 if (@$isa == 1) {
82 340         283 my $class = $isa->[0];
83 340         374 _make_class_accessor($class); # NOP if it has already been added
84 340         725 return $class;
85             }
86              
87 130         216 my $key = Storable::freeze($isa);
88              
89 130   66     2845 return $CLASS_CACHE->{$key} ||= do {
90 46         145 my $class = sprintf('autobox::_shim_%d_', ++$SEQ);
91 46         55 my $synthetic_class_isa = _get_isa($class); # i.e. autovivify
92              
93 46         422 @$synthetic_class_isa = @$isa;
94 46         64 _make_class_accessor($class);
95 46         192 $class;
96             };
97             }
98              
99             # expose the autobox class (for can, isa &c.)
100             # https://rt.cpan.org/Ticket/Display.html?id=55565
101             sub _make_class_accessor ($) {
102 386     386   292 my $class = shift;
103 386 50       538 return unless (defined $class);
104              
105             {
106 19     19   87 no strict 'refs';
  19         24  
  19         3165  
  386         260  
107 386 100   136   237 *{"$class\::autobox_class"} = sub { $class } unless (*{"$class\::autobox_class"}{CODE});
  115         283  
  136         48075  
  386         2101  
108             }
109             }
110              
111             # pretty-print the bindings hash by showing its values as the inherited classes rather than the synthetic class
112             sub _pretty_print($) {
113 44     44   26 my $hash = { %{ shift() } }; # clone the hash to isolate it from the original
  44         119  
114              
115             # reverse() turns a hash that maps an isa signature to a class name into a hash that maps
116             # a class name into a boolean
117 44         195 my %synthetic = reverse(%$CLASS_CACHE);
118              
119 44         93 for my $type (keys %$hash) {
120 218         160 my $class = $hash->{$type};
121 218 100       305 $hash->{$type} = $synthetic{$class} ? [ _get_isa($class) ] : [ $class ];
122             }
123              
124 44         115 return $hash;
125             }
126              
127             # default sub called when the DEBUG option is supplied with a true value
128             # prints the assigned bindings for the current scope
129             sub _debug ($) {
130 0     0   0 my $bindings = shift;
131 0         0 require Data::Dumper;
132 19     19   76 no warnings qw(once);
  19         19  
  19         2494  
133 0         0 local ($|, $Data::Dumper::Indent, $Data::Dumper::Terse, $Data::Dumper::Sortkeys) = (1, 1, 1, 1);
134 0         0 print STDERR Data::Dumper::Dumper($bindings), $/;
135             }
136              
137             # return true if $ref ISA $class - works with non-references, unblessed references and objects
138             # we can't use UNIVERSAL::isa to test if a value is an array ref;
139             # if the value is 'ARRAY', and that package exists, then UNIVERSAL::isa('ARRAY', 'ARRAY') is true!
140             sub _isa($$) {
141 1044     1044   879 my ($ref, $class) = @_;
142 1044 50       2520 return Scalar::Util::blessed($ref) ? $ref->isa($class) : ref($ref) eq $class;
143             }
144              
145             # get/autovivify the @ISA for the specified class
146             sub _get_isa($) {
147 237     237   840 my $class = shift;
148 237         124 my $isa = do {
149 19     19   76 no strict 'refs';
  19         27  
  19         17308  
150 237         148 *{"$class\::ISA"}{ARRAY};
  237         620  
151             };
152 237 100       521 return wantarray ? @$isa : $isa;
153             }
154              
155             # install a new set of bindings for the current scope
156             #
157             # XXX this could be refined to reuse the same hashref if its contents have already been seen,
158             # but that requires each (frozen) hash to be cached; at best, it may not be much of a win, and at
159             # worst it will increase bloat
160             sub _install ($) {
161 108     108   92 my $bindings = shift;
162 108         338 $^H{autobox} = $bindings;
163 108         986 $BINDINGS_CACHE->{$bindings} = $bindings; # keep the $bindings hash alive
164             }
165              
166             # return the supplied class name or a new class name made by appending the specified
167             # type to the namespace prefix
168             sub _expand_namespace($$) {
169 967     967   723 my ($class, $type) = @_;
170              
171             # make sure we can weed out classes that are empty strings or undef by returning an empty list
172 967 50       1155 Carp::confess("_expand_namespace not called in list context") unless (wantarray);
173              
174 967 100 66     2490 if ((defined $class) && ($class ne '')) {
175 961 100       2331 ($class =~ /::$/) ? "$class$type" : $class;
176             } else { # return an empty list
177             ()
178 6         7 }
179             }
180              
181             ############################################# PUBLIC (Methods) ###############################################
182              
183             # enable some flavour of autoboxing in the current scope
184             sub import {
185 101     101   8276 my $class = shift;
186 101 100 66     465 my %args = ((@_ == 1) && _isa($_[0], 'HASH')) ? %{shift()} : @_; # hash or hashref
  2         8  
187 101         128 my $debug = delete $args{DEBUG};
188              
189 101 100       247 %args = %DEFAULT unless (%args); # wait till DEBUG has been deleted
190              
191             # normalize %args so that it has a (possibly empty) array ref for all types, both real and virtual
192 101         303 for my $type (keys %TYPES) {
193 1010 100       1031 if (exists $args{$type}) { # exists() as the value may be undef (or ''), meaning "don't default this type"
194 160 100       226 if (_isa($args{$type}, 'ARRAY')) {
195 8         9 $args{$type} = [ @{$args{$type}} ]; # clone the array ref to isolate changes
  8         19  
196             } else {
197 152         276 $args{$type} = [ $args{$type} ];
198             }
199             } else {
200 850         977 $args{$type} = [];
201             }
202             }
203              
204             # if supplied, fill in defaults for unspecified SCALAR, ARRAY, HASH and CODE bindings
205             # must be done before the virtual type expansion below as one of the defaults, SCALAR, is a
206             # virtual type
207              
208 101         152 my $default = delete $args{DEFAULT};
209              
210 101 100       187 if ($default) {
211 30 100       35 $default = [ $default ] unless (_isa($default, 'ARRAY')); # no need to clone as we flatten it each time
212              
213 30         50 for my $type (keys %DEFAULT) {
214             # don't default if a binding has already been supplied; this may include an undef value meaning
215             # "don't default this type" e.g.
216             #
217             # use autobox
218             # DEFAULT => 'MyDefault',
219             # HASH => undef;
220             #
221             # undefs are winnowed out by _expand_namespace
222              
223 120 100       75 next if (@{$args{$type}});
  120         187  
224 100         73 push @{$args{$type}}, map { _expand_namespace($_, $type) } @$default;
  100         138  
  108         116  
225             }
226             }
227              
228             # expand the virtual type "macros" from the root to the leaves
229 101         300 for my $vtype (sort { $ISA{$a}->[0] <=> $ISA{$b}->[0] } keys %ISA) {
  225         353  
230 303 50       446 next unless ($args{$vtype});
231              
232 303         231 my @types = @{$ISA{$vtype}->[1]};
  303         536  
233              
234 303         298 for my $type (@types) {
235 808 50       861 if (_isa($args{$vtype}, 'ARRAY')) {
236 808         500 push @{$args{$type}}, map { _expand_namespace($_, $vtype) } @{$args{$vtype}};
  808         796  
  390         427  
  808         972  
237             } else {
238             # _expand_namespace returns an empty list if $args{$vtype} is undef (or '')
239 0         0 push @{$args{$type}}, _expand_namespace($args{$vtype}, $vtype);
  0         0  
240             }
241             }
242              
243 303         466 delete $args{$vtype};
244             }
245              
246 101         141 my $bindings; # custom typemap
247              
248             # clone the bindings hash if available
249             #
250             # we may be assigning to it, and we don't want to contaminate outer/previous bindings
251             # with nested/new bindings
252             #
253             # as of 5.10, references in %^H get stringified at runtime, but we don't need them then
254              
255 101 100       199 $bindings = $^H{autobox} ? { %{ $^H{autobox} } } : {};
  31         91  
256              
257             # sanity check %args, expand the namespace prefixes into class names,
258             # and copy values to the $bindings hash
259              
260 101         351 my %synthetic = reverse (%$CLASS_CACHE); # synthetic class name => bool - see _pretty_print
261              
262 101         198 for my $type (keys %args) {
263             # we've handled the virtual types, so we only need to check that this is a valid (real) type
264 707 0       998 Carp::confess("unrecognized option: '", (defined $type ? $type : ''), "'") unless ($TYPES{$type});
    50          
265              
266 707         433 my (@isa, $class);
267              
268 707 100       1986 if ($class = $bindings->{$type}) {
269 142 100       222 @isa = $synthetic{$class} ? _get_isa($class) : ($class);
270             }
271              
272             # perform namespace expansion; dups are removed in _generate_class below
273 707         490 push @isa, map { _expand_namespace($_, $type) } @{$args{$type}};
  469         489  
  707         734  
274              
275 707         1327 $bindings->{$type} = [ @isa ]; # assign the (possibly) new @isa for this type
276             }
277              
278             # replace each array ref of classes with the name of the generated class.
279             # if there's only one class in the type's @ISA (e.g. SCALAR => 'MyScalar') then
280             # that class is used; otherwise a shim class whose @ISA contains the two or more classes
281             # is created
282              
283 101         258 for my $type (keys %$bindings) {
284 707         634 my $isa = $bindings->{$type};
285              
286             # delete empty arrays e.g. use autobox SCALAR => []
287 707 100       871 if (@$isa == 0) {
288 237         308 delete $bindings->{$type};
289             } else {
290             # associate the synthetic/single class with the specified type
291 470         493 $bindings->{$type} = _generate_class($isa);
292             }
293             }
294              
295             # This turns on autoboxing i.e. the method call checker sets a flag on the method call op
296             # and replaces its default handler with the autobox implementation.
297             #
298             # It needs to be set unconditionally because it may have been unset in unimport
299              
300 101         225 $^H |= 0x80020000; # set HINT_LOCALIZE_HH + an unused bit to work around a %^H bug
301              
302             # install the specified bindings in the current scope
303 101         137 _install($bindings);
304              
305             # this is %^H as an integer - it changes as scopes are entered/exited
306             # we don't need to stack/unstack it in %^H as %^H itself takes care of that
307             # note: we need to call this *after* %^H is referenced (and possibly created) above
308              
309 101         258 my $scope = _scope();
310 101 100       176 my $old_scope = exists($^H{autobox_scope})? $^H{autobox_scope} : 0;
311 101         72 my $new_scope; # is this a new (top-level or nested) scope?
312              
313 101 100       124 if ($scope == $old_scope) {
314 25         655 $new_scope = 0;
315             } else {
316 76         155 $^H{autobox_scope} = $scope;
317 76         73 $new_scope = 1;
318             }
319              
320             # warn "OLD ($old_scope) => NEW ($scope): $new_scope ", join(':', (caller(1))[0 .. 2]), $/;
321              
322 101 100       167 if ($debug) {
323 44 50       54 $debug = \&_debug unless (_isa($debug, 'CODE'));
324 44         64 $debug->(_pretty_print($bindings));
325             }
326              
327 101 100       22600 return unless ($new_scope);
328              
329             # This sub is called when this scope's $^H{autobox_leave} is deleted, usually when
330             # %^H is destroyed at the end of the scope, but possibly directly in unimport()
331             #
332             # _enter splices in the autobox method call checker and method call op
333             # if they're not already enabled
334             #
335             # _leave performs the necessary housekeeping to ensure that the default
336             # checker and op are restored when autobox is no longer in scope
337              
338 76     76   391 my $guard = Scope::Guard->new(sub { _leave() });
  76         36724  
339 76         805 $^H{autobox_leave} = $guard;
340              
341 76         7411 _enter();
342             }
343              
344             # delete one or more bindings; if none remain, disable autobox in the current scope
345             #
346             # note: if bindings remain, we need to create a new hash (initially a clone of the current
347             # hash) so that the previous hash (if any) is not contaminated by new deletion(s)
348             #
349             # use autobox;
350             #
351             # "foo"->bar;
352             #
353             # no autobox qw(SCALAR); # don't clobber the default bindings for "foo"->bar
354             #
355             # however, if there are no more bindings we can remove all traces of autobox from the
356             # current scope.
357              
358             sub unimport {
359 34     34   9879 my ($class, @args) = @_;
360              
361             # the only situation in which there is no bindings hash is if this is a "no autobox"
362             # that precedes any "use autobox", in which case we don't need to turn autoboxing off as it's
363             # not yet been turned on
364 34 100       437 return unless ($^H{autobox});
365              
366 20         21 my $bindings;
367              
368 20 100       50 if (@args) {
369 9         10 $bindings = { %{$^H{autobox}} }; # clone the current bindings hash
  9         43  
370 9         21 my %args = map { $_ => 1 } @args;
  10         31  
371              
372             # expand any virtual type "macros"
373 9         33 for my $vtype (sort { $ISA{$a}->[0] <=> $ISA{$b}->[0] } keys %ISA) {
  23         933  
374 27 100       60 next unless ($args{$vtype});
375              
376             # we could delete the types directly from $bindings here, but we may as well pipe them
377             # through the option checker below to ensure correctness
378 7         6 $args{$_} = 1 for (@{$ISA{$vtype}->[1]});
  7         28  
379              
380 7         12 delete $args{$vtype};
381             }
382              
383 9         21 for my $type (keys %args) {
384             # we've handled the virtual types, so we only need to check that this is a valid (real) type
385 17 0       31 Carp::confess("unrecognized option: '", (defined $type ? $type : ''), "'") unless ($TYPES{$type});
    50          
386 17         34 delete $bindings->{$type};
387             }
388             } else { # turn off autoboxing
389 11         18 $bindings = {}; # empty hash to trigger full deletion below
390             }
391              
392 20 100       54 if (%$bindings) {
393 7         15 _install($bindings);
394             } else { # remove all traces of autobox from the current scope
395 13         31 $^H &= ~0x80020000; # unset HINT_LOCALIZE_HH + the additional bit
396 13         37 delete $^H{autobox};
397 13         25 delete $^H{autobox_scope};
398 13         118 delete $^H{autobox_leave}; # triggers the leave handler
399             }
400             }
401              
402             1;