File Coverage

blib/lib/overload/reify.pm
Criterion Covered Total %
statement 95 96 98.9
branch 41 50 82.0
condition 10 15 66.6
subroutine 17 17 100.0
pod 2 2 100.0
total 165 180 91.6


line stmt bran cond sub pod time code
1             package overload::reify;
2              
3 6     6   870127 use 5.006;
  6         22  
4              
5             # ABSTRACT: Provide named methods for inherited overloaded operators
6              
7 6     6   29 use strict;
  6         12  
  6         122  
8 6     6   25 use warnings;
  6         13  
  6         215  
9              
10             our $VERSION = '0.07';
11              
12 6     6   33 use overload ();
  6         15  
  6         76  
13 6     6   29 use Carp ();
  6         13  
  6         3352  
14              
15             my %MethodNames = (
16              
17             # with_assign => '+ - * / % ** << >> x .',
18             '+' => 'add',
19             '-' => 'subtract',
20             '*' => 'multiply',
21             '/' => 'divide',
22             '%' => 'modulus',
23             '**' => 'pow',
24             '<<' => 'lshift',
25             '>>' => 'rshift',
26             'x' => 'repetition',
27             '.' => 'append',
28              
29             # assign => '+= -= *= /= %= **= <<= >>= x= .='
30             '+=' => 'add_assign',
31             '-=' => 'subtract_assign',
32             '*=' => 'multiply_assign',
33             '/=' => 'divide_assign',
34             '%=' => 'modulus_assign',
35             '**=' => 'pow_assign',
36             '<<=' => 'lshift_assign',
37             '>>=' => 'rshift_assign',
38             'x=' => 'repetition_assign',
39             '.=' => 'append_assign',
40              
41             # num_comparison => '< <= > >= == !=',
42             '<' => 'numeric_lt',
43             '<=' => 'numeric_le',
44             '>' => 'numeric_gt',
45             '>=' => 'numeric_ge',
46             '==' => 'numeric_eq',
47             '!=' => 'numeric_ne',
48              
49             # '3way_comparison' => '<=> cmp',
50             '<=>' => 'numeric_cmp',
51             'cmp' => 'string_cmp',
52              
53             # str_comparison => 'lt le gt ge eq ne',
54             'lt' => 'string_lt',
55             'le' => 'string_le',
56             'gt' => 'string_gt',
57             'ge' => 'string_ge',
58             'eq' => 'string_eq',
59             'ne' => 'string_ne',
60              
61             # binary => '& &= | |= ^ ^= &. &.= |. |.= ^. ^.=',
62             '&' => 'binary_and',
63             '&=' => 'binary_and_assign',
64             '|' => 'binary_or',
65             '|=' => 'binary_or_assign',
66             '^' => 'binary_xor',
67             '^=' => 'binary_xor_assign',
68             '&.' => 'binary_string_and',
69             '&.=' => 'binary_string_and_assign',
70             '|.' => 'binary_string_or',
71             '|.=' => 'binary_string_or_assign',
72             '^.' => 'binary_string_xor',
73             '^.=' => 'binary_string_xor_assign',
74              
75             # unary => 'neg ! ~ ~.',
76             'neg' => 'neg',
77             '!' => 'not',
78             '~' => 'bitwise_negation',
79             '~.' => 'bitwise_string_negation',
80              
81              
82             # mutators => '++ --',
83             '++' => 'increment',
84             '--' => 'decrement',
85              
86             # func => 'atan2 cos sin exp abs log sqrt int',
87             'atan2' => 'atan2',
88             'cos' => 'cos',
89             'sin' => 'sin',
90             'exp' => 'exp',
91             'abs' => 'abs',
92             'log' => 'log',
93             'sqrt' => 'sqrt',
94             'int' => 'int',
95              
96             # conversion => 'bool "" 0+ qr',
97             'bool' => 'bool',
98             '""' => 'stringify',
99             '0+' => 'numerify',
100             'qr' => 'regexp',
101              
102             # iterators => '<>',
103             '<>' => 'null_filehandle',
104              
105             # filetest => '-X',
106             '-X' => 'filetest',
107              
108             # dereferencing => '${} @{} %{} &{} *{}',
109             '${}' => 'scalar_deref',
110             '@{}' => 'array_deref',
111             '%{}' => 'hash_deref',
112             '&{}' => 'code_deref',
113             '*{}' => 'glob_deref',
114              
115             # matching => '~~',
116             '~~' => 'smartmatch',
117              
118             # special => 'nomethod fallback ='
119             'nomethod' => 'nomethod',
120             '=' => 'copy_constructor',
121             );
122              
123             # get those supported on this version of Perl
124             my @PlatformOps = grep( $_ ne 'fallback',
125             map( split( /\s+/, $_ ), values %overload::ops ) );
126              
127             # and create a mapping to the method names. if a method name
128             # is missing, it'll result in an undef entry in the mapping,
129             # and it'll trigger an error in the test suite.
130             my %OP;
131             @OP{@PlatformOps} = @MethodNames{@PlatformOps};
132              
133              
134             # operator overloads are stored in the symbol table as "($op"
135             #
136             # if the overload is a coderef
137             # *{$symbol}{CODE} = $coderef
138             #
139             # if the overload is a $method_name
140             # *{$symbol}{CODE} = \&overload::nil (or ::_nil)
141             # *{$symbol}{SCALAR} = $method_name
142             #
143             # cribbed from Role::Tiny
144              
145              
146             sub import {
147              
148 13     13   6161 my $class = shift;
149              
150             my %opt = (
151             -redefine => 0,
152             -methods => 1,
153             -prefix => 'operator_',
154 13 100       74 'HASH' eq ref $_[-1] ? %{ pop() } : (),
  5         28  
155             );
156              
157              
158 13   66     88 my $into = delete( $opt{-into} ) || caller;
159 13         34 my $wrap_methods = delete $opt{-methods};
160 13         29 my $method_name_prefix = delete $opt{-prefix};
161 13         30 my $redefine_methods = delete $opt{-redefine};
162              
163 13 50       38 Carp::croak( "unknown options: ", keys %opt ) if %opt;
164              
165 13         21 my %install;
166              
167 13         33 my @args = @_;
168 13         48 while ( @args ) {
169              
170 4         8 my $arg = shift @args;
171              
172 4 100       10 if ( $arg eq '-not' ) {
173              
174             # if first is an exclusion, populate
175 3 100       11 @install{ $class->_ops( ':all' ) } = 1
176             if @args == @_ - 1;
177              
178 3 50       11 $arg = shift @args
179             or Carp::croak( "missing operator after -not\n" );
180              
181 3 50       18 $arg = [ $arg ] unless 'ARRAY' eq ref $arg;
182              
183 3         8 delete @install{ $class->_ops( $_ ) } foreach @$arg
184             }
185             else {
186 1         3 @install{ $class->_ops( $arg ) } = 1;
187             }
188             }
189              
190             # default to all if not specified, but only if no arguments were
191             # passed. that way if the caller (mistakenly?) excludes everything
192             # it gets what it asks for.
193 13 100 100     85 @install{ $class->_ops( ':all' ) } = 1
194             unless %install || @_;
195              
196 13         256 for my $op ( keys %install ) {
197              
198 693         1062 my $symbol = '(' . $op;
199              
200 693         1324 my $glob = overload::mycan( $into, $symbol );
201 693 100       17712 next unless defined $glob;
202              
203 46         63 my $coderef = *{$glob}{CODE};
  46         79  
204 46 50       103 next unless defined $coderef;
205              
206             # method name ?
207 46         66 my $original_method_name;
208 46 100 66     280 if (
      33        
      66        
209             ( defined &overload::nil && $coderef == \&overload::nil )
210             || ( defined &overload::_nil
211             && $coderef == \&overload::_nil ) )
212             {
213 9         19 $original_method_name = ${ *{$glob}{SCALAR} };
  9         15  
  9         22  
214             # weird but possible?
215 9 50       37 next unless defined $original_method_name;
216             }
217              
218 46         130 my $new_method_name = $method_name_prefix . $OP{$op};
219              
220             # it's a real method; only rewire if requested to do so
221 46 100       106 if ( defined $original_method_name ) {
222 9 100       24 next unless $wrap_methods;
223              
224             # if it's the same name, we'll simply pick it up via
225             # inheritance
226 8 100       50 next if $original_method_name eq $new_method_name;
227              
228             ## no critic(ProhibitStringyEval)
229 7     3   569 $coderef
  3         12226  
230             = eval "package $into; sub { shift()->$original_method_name(\@_) }";
231             }
232              
233 44         98 _install_overload( $into, $symbol, $new_method_name, $coderef, $redefine_methods );
234             }
235             }
236              
237             sub _install_overload {
238              
239 44     44   91 my ( $into, $symbol, $method_name, $coderef, $redefine ) = @_;
240              
241             # if not overwriting, make sure there's nothing there
242 44 100       100 unless ( $redefine ) {
243              
244             Carp::croak( "${into}::${_} would be redefined" )
245 34         61 for grep { _is_existing_method( $into, $_ ) }
  68         121  
246             $symbol, $method_name;
247             }
248              
249 6     6   39 no warnings 'redefine';
  6         12  
  6         657  
250 42         62 *{ _getglob( "${into}::${method_name}") } = $coderef;
  42         101  
251 42         101 my $glob = _getglob ("${into}::${symbol}");
252 42         77 *$glob = \$method_name;
253 42 50       146 *$glob = defined &overload::nil ? \&overload::nil : \&overload::_nil;
254             }
255              
256             # stolen from Role::Tiny
257             sub _getglob {
258             ## no critic( ProhibitNoStrict )
259 6     6   34 no strict 'refs';
  6         12  
  6         316  
260 86     86   117 \*{ $_[0] };
  86         318  
261             }
262              
263              
264             # don't create a symbol table entry if we can help it
265             sub _get_existing_glob {
266 68     68   107 my ( $package, $name ) = @_;
267             ## no critic( ProhibitNoStrict )
268 6     6   27 no strict 'refs';
  6         13  
  6         2304  
269              
270 68 100       95 exists ${"${package}::"}{$name} ? _getglob( "${package}::${name}" ) : undef;
  68         182  
271              
272             }
273              
274             sub _is_existing_method {
275              
276 68     68   118 my ( $package, $name ) = @_;
277              
278 68         125 my $glob = _get_existing_glob( $package, $name );
279              
280 68 100       317 return defined $glob ? defined *{$glob}{CODE} : 0;
  2         217  
281             }
282              
283             #pod =method tag_to_ops
284             #pod
285             #pod @ops = overload::reify->tag_to_ops( $tag );
286             #pod
287             #pod Return a list of operators correspond to the passed tag. A tag is a string which
288             #pod is either
289             #pod
290             #pod =over
291             #pod
292             #pod =item *
293             #pod
294             #pod an operator, e.g. C<'++'>; or
295             #pod
296             #pod =item *
297             #pod
298             #pod a string (in the form C<:>I) representing a class
299             #pod of operators. A class may be any of the keys accepted by the
300             #pod L pragma, as well as the
301             #pod special class C, which consists of all operators.
302             #pod
303             #pod =back
304             #pod
305             #pod =cut
306              
307             sub tag_to_ops {
308              
309 38     38 1 60882 my ( $class, $op ) = @_;
310              
311 38 100       155 return $op if defined $OP{$op};
312 32 100       355 return keys %OP if $op eq ':all';
313              
314 17         114 my ( $tag ) = $op =~ /^:(.*)$/;
315              
316 17 50       72 Carp::croak( "couldn't parse \$op: $op\n" )
317             if ! defined $tag;
318              
319             return grep( $_ ne 'fallback', split( /\s+/, $overload::ops{$tag} ) )
320 17 50       234 if defined $overload::ops{$tag};
321              
322 0         0 return;
323             }
324              
325             sub _ops {
326              
327 16     16   34 my ( $class, $op ) = @_;
328              
329 16         41 my @ops = $class->tag_to_ops( $op );
330              
331 16 50       71 Carp::croak( "unknown operator or tag: $op\n" )
332             unless @ops;
333              
334 16         283 return @ops;
335             }
336              
337             #pod =method method_names
338             #pod
339             #pod # from the command line:
340             #pod perl -Ilib -MData::Dumper -Moverload::reify \
341             #pod -e 'print Dumper overload::reify->method_names()'
342             #pod
343             #pod # in code
344             #pod $hashref = overload::reify->method_names( ?@ops, ?\%options );
345             #pod
346             #pod This class method returns the mapping between operators and generated
347             #pod method names. Supplied operators are first run through
348             #pod L. If no operators are passed, a map for all of the
349             #pod supported ones is returned.
350             #pod
351             #pod The map is returned a hashref whose keys are operators and whose
352             #pod values are the names of generated methods. The available options are:
353             #pod
354             #pod =over
355             #pod
356             #pod =item C<-prefix>
357             #pod
358             #pod The prefix for the names of the generated method names. It defaults to
359             #pod C.
360             #pod
361             #pod =back
362             #pod
363             #pod =cut
364              
365             sub method_names {
366              
367 5     5 1 160877 my $class = shift;
368              
369             my %opt = ( -prefix => 'operator_',
370 5 100       18 'HASH' eq ref $_[-1] ? %{ pop() } : (),
  2         8  
371             );
372              
373 5 100       32 my @ops = @_ ? map $class->tag_to_ops( $_ ), @_ : keys %OP;
374              
375 5         107 return { map +($_ => $opt{-prefix} . $OP{$_}), @ops };
376             };
377              
378             1;
379              
380             #
381             # This file is part of overload-reify
382             #
383             # This software is copyright (c) 2017 by Smithsonian Astrophysical Observatory.
384             #
385             # This is free software; you can redistribute it and/or modify it under
386             # the same terms as the Perl 5 programming language system itself.
387             #
388              
389             =pod
390              
391             =head1 NAME
392              
393             overload::reify - Provide named methods for inherited overloaded operators
394              
395             =head1 VERSION
396              
397             version 0.07
398              
399             =head1 SYNOPSIS
400              
401             { package Parent;
402             use overload
403             '+=' => 'plus_equals',
404             '++' => sub { ... };
405              
406             # ...
407              
408             sub plus_equals { ... }
409             }
410              
411             { package Child1;
412              
413             use Parent;
414              
415             use overload::reify;
416              
417             # this creates new methods:
418             #
419             # operator_increment()
420             # performs the ++ operation
421             #
422             # operator_add_assign()
423             # comparable to plus_equals(), but modifying
424             # it won't modify plus_equals
425              
426             }
427              
428             { package Child2;
429              
430             use Parent;
431              
432             # don't create methods for overloads with method names
433             use overload::reify { -methods => 0 };
434              
435             # this creates new methods:
436             #
437             # operator_increment()
438             # performs the ++ operation
439             }
440              
441             =head1 DESCRIPTION
442              
443             This pragma creates named methods for inherited operator overloads.
444             The child may then modify them using such packages as L,
445             L, or L.
446              
447             =head2 Background
448              
449             When a package overloads an operator it provides either a method
450             name or a code reference, e.g.
451              
452             overload
453             '++' => 'plus_plus',
454             '--' => sub { ..., }
455              
456             In the latter case, the overloaded subroutine cannot be modified via
457             e.g., the B subroutine in
458             L (or
459             L or L) as it has no named symbol
460             table entry.
461              
462             B installs named methods for overloaded operators
463             into a package's symbol table. The method names are constructed by
464             concatenating a prefix (provided by the C<-prefix> option) and a
465             standardized operator name (see L). An existing method
466             with the same name will be quietly replaced, unless the L option
467             is true.
468              
469             For operators overloaded with a method name which is different from
470             the new method name, a wrapper which calls the original method by its
471             name is installed. If the original and new method names are the same,
472             nothing is installed.
473              
474             For operators overloaded with a code reference, an alias to the code
475             reference is installed.
476              
477             By default named methods are constructed for I overloaded
478             operators, regardless of how they are implemented (providing the child
479             class a uniform naming scheme). If this is not desired, set the
480             C<-methods> option to false.
481              
482             =head2 Usage
483              
484             The pragma is invoked with the following template:
485              
486             use overload::reify @operators, ?\%options;
487              
488             where C<@operators> is a list of strings, each of which may contain:
489              
490             =over
491              
492             =item *
493              
494             an operator to be considered, e.g. C<'++'>;
495              
496             =item *
497              
498             a tag (in the form C<:>I) representing a class
499             of operators. A class may be any of the keys accepted by the
500             L pragma, as well as the
501             special class C, which consists of all operators.
502              
503             =item *
504              
505             the token C<-not>, indicating that the next operator is to be excluded
506             from consideration. If C<-not> is the first element in the list of
507             operators, the list is pre-seeded with all of the operators.
508              
509             =back
510              
511             and C<%options> is a hash with one or more of the following keys:
512              
513             =over
514              
515             =item C<-into>
516              
517             The package into which the methods will be installed. This defaults
518             to the calling package.
519              
520             =item C<-redefine>
521              
522             A boolean which if true will cause an exception to be thrown if
523             installing the new method would replace an existing one of the same
524             name in the package specified by L. Defaults to false.
525              
526             =item C<-methods>
527              
528             A boolean indicating whether or not wrappers will be generated for overloaded operators with named methods. This defaults to I.
529              
530             =item C<-prefix>
531              
532             The prefix for the names of the generated method names. It defaults to
533             C.
534              
535             =back
536              
537             =head1 METHODS
538              
539             =head2 tag_to_ops
540              
541             @ops = overload::reify->tag_to_ops( $tag );
542              
543             Return a list of operators correspond to the passed tag. A tag is a string which
544             is either
545              
546             =over
547              
548             =item *
549              
550             an operator, e.g. C<'++'>; or
551              
552             =item *
553              
554             a string (in the form C<:>I) representing a class
555             of operators. A class may be any of the keys accepted by the
556             L pragma, as well as the
557             special class C, which consists of all operators.
558              
559             =back
560              
561             =head2 method_names
562              
563             # from the command line:
564             perl -Ilib -MData::Dumper -Moverload::reify \
565             -e 'print Dumper overload::reify->method_names()'
566              
567             # in code
568             $hashref = overload::reify->method_names( ?@ops, ?\%options );
569              
570             This class method returns the mapping between operators and generated
571             method names. Supplied operators are first run through
572             L. If no operators are passed, a map for all of the
573             supported ones is returned.
574              
575             The map is returned a hashref whose keys are operators and whose
576             values are the names of generated methods. The available options are:
577              
578             =over
579              
580             =item C<-prefix>
581              
582             The prefix for the names of the generated method names. It defaults to
583             C.
584              
585             =back
586              
587             =head1 SEE ALSO
588              
589             L, L, L.
590              
591             =head1 CONTRIBUTORS
592              
593             Thanks to
594              
595             =over
596              
597             =item *
598              
599             L for the
600             suggestion to house this code in its own module and for the module name.
601              
602             =item *
603             L for reviewing
604             an initial version of this code.
605              
606             =back
607              
608             =head1 AUTHOR
609              
610             Diab Jerius
611              
612             =head1 COPYRIGHT AND LICENSE
613              
614             This software is copyright (c) 2017 by Smithsonian Astrophysical Observatory.
615              
616             This is free software; you can redistribute it and/or modify it under
617             the same terms as the Perl 5 programming language system itself.
618              
619             =cut
620              
621             __END__