File Coverage

lib/Class/MethodMaker/Engine.pm
Criterion Covered Total %
statement 89 217 41.0
branch 35 126 27.7
condition 3 26 11.5
subroutine 21 24 87.5
pod 3 6 50.0
total 151 399 37.8


line stmt bran cond sub pod time code
1             # (X)Emacs mode: -*- cperl -*-
2              
3             package Class::MethodMaker::Engine;
4              
5             =head1 NAME
6              
7             Class::MethodMaker::Engine - The parameter passing, method installation &
8             non-data-structure methods of Class::MethodMaker.
9              
10             =head1 SYNOPSIS
11              
12             This class is for internal implementation only. It is not a public API.
13              
14             The non-data-structure methods do form part of the public API, but not called
15             directly: rather, called through the C/C interface, as for
16             data-structure methods.
17              
18             =cut
19              
20             # Pragmas -----------------------------
21              
22 8     8   108 use 5.006;
  8         24  
  8         405  
23 8     8   32 use strict;
  8         10  
  8         231  
24 8     8   29 use warnings;
  8         14  
  8         212  
25              
26 8     8   36 use warnings::register;
  8         19  
  8         1417  
27              
28             # Inheritance -------------------------
29              
30             our @ISA = qw( AutoLoader );
31              
32             # Utility -----------------------------
33              
34 8     8   4369 use AutoLoader qw( AUTOLOAD );
  8         10174  
  8         45  
35 8     8   275 use Carp qw( carp croak cluck );
  8         14  
  8         585  
36 8     8   2199 use Class::MethodMaker::OptExt qw( OPTEXT );
  8         11  
  8         609  
37 8     8   2788 use Class::MethodMaker::V1Compat qw( V1COMPAT );
  8         15  
  8         621  
38              
39             # ----------------------------------------------------------------------------
40              
41             # CLASS METHODS --------------------------------------------------------------
42              
43             # -------------------------------------
44             # CLASS CONSTANTS
45             # -------------------------------------
46              
47             # Weird "useless use of a constant in void context" without the ?:
48 8 50   8   36 use constant DEBUG => $ENV{_CMM_DEBUG} ? 1 : 0;
  8         12  
  8         694  
49             BEGIN {
50 8     8   6383 if ( DEBUG ) {
51             require B::Deparse;
52             require Data::Dumper;
53             Data::Dumper->import('Dumper');
54             }
55             }
56              
57             # -------------------------------------
58              
59             our $PACKAGE = 'Class-MethodMaker';
60             our $VERSION = '2.22_01';
61              
62             # -------------------------------------
63             # CLASS CONSTRUCTION
64             # -------------------------------------
65              
66             # -------------------------------------
67             # CLASS COMPONENTS
68             # -------------------------------------
69              
70             # A starter for introspective information
71              
72             # For each class, a list of the components installed for that class (as a
73             # hashref from name to hashref. Keys of latter hashref:
74             # 'type' name of component type, e.g., scalar, array, hash
75             # 'assign' name of method to perform assignment. This is used by new with
76             # hash_init. This level of indirection is to cater for the
77             # possibility of an assignment function named other than '*'
78              
79             my %class_comps;
80             sub _class_comp_assign {
81 6 50   6   1202 exists $class_comps{$_[1]}->{$_[2]} ?
82             $class_comps{$_[1]}->{$_[2]}->{assign} : undef;
83             }
84              
85             sub _class_comp_options {
86 0 0   0   0 exists $class_comps{$_[1]}->{$_[2]} ?
87             $class_comps{$_[1]}->{$_[2]}->{options} : undef;
88             }
89              
90             # -------------------------------------
91             # CLASS HIGHER-LEVEL FUNCTIONS
92             # -------------------------------------
93              
94             # -------------------------------------
95             # CLASS HIGHER-LEVEL PROCEDURES
96             # -------------------------------------
97              
98             =head1 The Class::MethodMaker Method Installation Engine
99              
100             Z<>
101              
102             =cut
103              
104             # -------------------------------------
105              
106             =head2 import
107              
108             This performs argument parsing ready for calling create_methods. In
109             particular, this is the point at which v1 & v2 calls are distinguished.
110              
111             This is implicitly called as part of a C statement:
112              
113             use Class::MethodMaker
114             [ scalar => [qw/ foo bar baz /],
115             new => [qw/ new /] ,
116             ];
117              
118             is equivalent to
119              
120             Class::MethodMaker->import([scalar => [qw/ foo bar baz /],
121             new => [qw/ new /] ,
122             ]);
123              
124             See L for details of this equivalence.
125              
126             The methods created are installed into the class calling the import - or more
127             accurately, the first class up the calling stack that is not
128             C or a subclass thereof.
129              
130             =over 4
131              
132             =item SYNOPSIS
133              
134             Class::MethodMaker->import([scalar => [+{ -type => 'File::Stat',
135             -forward => [qw/ mode size /],
136             '*_foo' => '*_fig',
137             '*_gop' => undef,
138             '*_bar' => '*_bar',
139             '*_hal' => '*_sal',
140             },
141             qw/ -static bob /,
142             ]
143             ]);
144              
145             =back
146              
147             =cut
148              
149             sub import {
150 40     40   66 my $class = shift;
151 40         103 my $target = $class->_find_target_class;
152              
153 40         49 my (@args);
154 40         47 my $mode = 2;
155              
156 40 100       185 return unless @_;
157              
158 38 0       91 if ( @_ == 1 ) {
159 37 50       126 croak "import requires an arrayref"
160             unless UNIVERSAL::isa($_[0], 'ARRAY');
161 37         40 @args = @{$_[0]};
  37         96  
162             } else {
163 1 50       5 croak("import requires an even number of arguments in v1 compatibility ".
164             "mode")
165             unless @_ % 2 == 0;
166              
167 1         3 @args = @_;
168             # -1 on $#args ensures that no range is generated when $#args is 0.
169             # check above ensures that scalar(@args) is even, so $#args is odd,
170             # so $#args-1 is even and ($#args-1)/2 == int ($#args/2). .. provides an
171             # integer context to its operands.
172             $mode = 1
173 1         12 for grep exists V1COMPAT->{$_}, map $args[$_*2], 0..($#args-1)/2;
174 0 0       0 if ( $mode == 1 ) {
175             croak("meta-method type $_ not recognized as a V1 compatibility type\n" .
176             "(cannot mix v1 & v2 options)\n")
177 0         0 for grep ! exists V1COMPAT->{$_}, map $args[$_*2], 0..($#args-1)/2;
178             } else {
179 0 0       0 croak('meta-method' . (($#args/2>1) ? 's' : '') . ' ' .
180             join(', ', map qq'"$args[$_*2]"', 0..($#args-1)/2) .
181             " found in v1 compatibility mode, but not recognized as v1.\n" .
182             "please update to v2, presenting your arguments to use/import\n" .
183             "as a single arrayref (wrap them with [...])\n");
184             }
185             }
186              
187 0 0       0 if ( $mode == 1 ) {
188 0         0 $class->parse_v1_options($target, \@args);
189             } else {
190 0         0 $class->parse_options($target, \@args);
191             }
192             }
193              
194             # -------------------------------------
195              
196             =head2 parse_options
197              
198             Parse the arguments given to import and call L
199             appropriately. See main text for options syntax.
200              
201             =over 4
202              
203             =item SYNOPSIS
204              
205             Class::MethodMaker->parse_options('TargetClass',
206             [scalar =>
207             [{ -type => 'File::stat',
208             -forward => [qw/ mode
209             size /],
210             '*_foo' => '*_fig',
211             '*_gop' => undef,
212             '*_bar' => '*_bar',
213             '*_hal' => '*_sal',
214             },
215             qw( -static bob ),
216             ]])},
217              
218             Class::MethodMaker->parse_options('TargetClass2',
219             [scalar =>
220             ['baz',
221             { -type => 'File::stat',
222             -forward => [qw/ mode
223             size /],
224             '*_foo' => '*_fog',
225             '*_bar' => '*_bar',
226             '*_hal' => '*_sal',
227             },
228             qw( -static bob ),
229             ]],
230             +{ -type => 'Math::BigInt', },
231             +{'*_foo' => '*_fig',
232             '*_gop' => undef,},
233             )},
234              
235              
236              
237             =item ARGUMENTS
238              
239             =over 4
240              
241             =item target_class
242              
243             The class into which to install components
244              
245             =item args
246              
247             The arguments to parse, as a single arrayref.
248              
249             =item options
250              
251             A hashref of options to apply to all components created by this call (subject
252             to overriding by explicit option calls).
253              
254             =item renames
255              
256             A hashref of renames to apply to all components created by this call (subject
257             to overriding by explicit rename calls).
258              
259             =back
260              
261             =back
262              
263             =cut
264              
265             sub parse_options {
266 0     39 1 0 my $class = shift;
267 0         0 my ($target_class, $args, $options, $renames) = @_;
268              
269 0         0 print STDERR ("Parsing Options: ",
270             Data::Dumper->Dump([$args, $options, $renames],
271             [qw( args options renames )]))
272             if DEBUG;
273              
274 0         0 my (%options, %renames);
275              
276             # It is important that components are created in the specified order, so
277             # that e.g., forwarding works as expected (lest the forward method applies
278             # to the wrong component).
279              
280 0         0 for (my $i = 0; $i < @$args; $i++) {
281 0 0       0 if ( ! ref $args->[$i] ) {
282 0         0 my $type = $args->[$i];
283              
284 0 0       0 if ( substr($type, 0, 1) eq '-' ) {
285 0         0 my $option = substr($type, 1);
286 0 0       0 if ( $option eq 'target_class' ) {
287 0 0       0 croak "No argument found for -target_class\n"
288             if $i == $#$args;
289 0         0 $target_class = $args->[++$i];
290 0 0       0 croak "-target_class takes a simple scalar argument\n"
291             if ref $target_class;
292             } else {
293 0         0 croak "Unrecognized option: $type\n";
294             }
295             } else {
296             # Reset options, renames to input global settings
297 0 0       0 %options = defined $options ? %$options : ();
298 0 0       0 %renames = defined $renames ? %$renames : ();
299 0         0 my $created = 0;
300 0 0       0 croak("No arguments found for $type while creating methods for ",
301             $target_class, "\n")
302             if $i == $#$args;
303 0         0 my $opts = $args->[++$i];
304 0 0       0 if ( UNIVERSAL::isa($opts, 'SCALAR') ) {
    0          
305 0         0 $class->create_methods ($target_class, $type, $opts,
306             \%options, \%renames);
307 0         0 $created = 1;
308             } elsif ( UNIVERSAL::isa($opts, 'ARRAY') ) {
309 0         0 for (@$opts) {
310 0 0       0 if ( ! ref $_ ) {
    0          
    0          
311 0 0       0 if ( $_ =~ /^[A-Za-z_][0-9A-Za-z_]*$/ ) {
    0          
312 0         0 $class->create_methods ($target_class, $type, $_,
313             \%options, \%renames);
314 0         0 $created = 1;
315             } elsif ( $_ =~ /^([-!])([0-9A-Za-z_]+)$/ ) {
316 0 0       0 $options{$2} = ($1 eq '!' ? 0 : 1);
317             } else {
318 0         0 croak "Argument $_ for type $type not understood\n";
319             }
320             } elsif ( UNIVERSAL::isa($_, 'HASH') ) {
321 0         0 while ( my ($k, $v) = each %$_ ) {
322 8 0   8   4418 if ( index($k, '*') > $[-1 ) {
  8         2776  
  8         6776  
  0         0  
323 0         0 $renames{$k} = $v;
324             } else {
325 0         0 $k =~ s/^-//;
326 0         0 $options{$k} = $v;
327             }
328             }
329             } elsif ( UNIVERSAL::isa($_, 'ARRAY') ) {
330 0         0 $class->parse_options($target_class, [$type, $_],
331             \%options, \%renames);
332             } else {
333 0         0 croak("Argument type " . ref($_) .
334             " to type $type not handled\n");
335             }
336             }
337             } else {
338 0         0 $class->create_methods ($target_class, $type, $opts,
339             $options, $renames);
340 0         0 $created = 1;
341             }
342              
343 0 0       0 warnif("No attributes found for type $type\n")
344             unless $created;
345             }
346             } else {
347 0         0 croak "Argument not handled: ", $args->[$i], "\n";
348             }
349             }
350              
351 0         0 return;
352             }
353              
354             # -------------------------------------
355              
356             # V1 compatibility is purposely not documented.
357              
358             sub parse_v1_options {
359 0     0 0 0 my $class = shift;
360 0         0 my ($target_class, $args) = @_;
361              
362 0         0 print STDERR "V1 Parser (1) : ", Data::Dumper->Dump([$args],
363             [qw( args )])
364             if DEBUG;
365              
366 0         0 while (my ($v1type, $names) = splice @$args, 0, 2 ) {
367 0         0 my %options = (v1_compat => 1);
368              
369 0 0       0 croak("No argument found for $v1type while creating methods for ",
370             $target_class, "\n")
371             unless defined $names;
372              
373 0         0 my $v2type = $v1type;
374              
375 0         0 my ($rename, $opt_handler, $rephrase);
376 0 0       0 if ( exists V1COMPAT->{$v1type} ) {
377 0         0 my $v1compat = V1COMPAT->{$v1type};
378 0 0       0 $v2type = $v1compat->{v2name}
379             if exists $v1compat->{v2name};
380 0         0 ($rename, $opt_handler, $rephrase) =
381 0         0 @{$v1compat}{qw(rename option rephrase)};
382 0         0 print STDERR "V1 Parser (2) : ",
383             Data::Dumper->Dump([$v1type, $v2type, $v1compat,
384             $rename, $opt_handler, $rephrase,],
385             [qw(v1type v2type v1compat
386             rename opt_handler rephrase)])
387             if DEBUG;
388             }
389              
390 0         0 print STDERR "V1 Parser (3) : ",
391             Data::Dumper->Dump([$names],[qw(inames)])
392             if DEBUG;
393 0 0       0 if ( defined $rephrase ) {
394 0         0 $names = $rephrase->($names);
395 0         0 print STDERR "V1 Parser (3.5) : ",
396             Data::Dumper->Dump([$names],[qw(rephrased)])
397             if DEBUG;
398             }
399              
400             # warnif("Class::MethodMaker V1 compatibility mode enabled for $type\n");
401              
402 0 0       0 my @names = UNIVERSAL::isa($names, 'ARRAY') ? @$names : $names;
403              
404 0         0 for (@names) {
405 0 0 0     0 if ( ref($_) or substr($_, 0, 1) eq '-' ) {
406 0         0 print STDERR "V1 Parser (4) : ",
407             Data::Dumper->Dump([\%options, $_],[qw(options name)])
408             if DEBUG;
409 0 0       0 if ( defined $opt_handler ) {
410 0         0 $opt_handler->($v1type, $_, $rename, \%options, $target_class);
411             } else {
412 0         0 croak "Options not handled for v1 type $v1type\n";
413             }
414 0         0 print STDERR "V1 Parser (4.5) : ",
415             Data::Dumper->Dump([\%options],[qw(options)])
416             if DEBUG;
417             } else {
418 0         0 $class->create_methods($target_class, $v2type, $_,
419             \%options, $rename);
420             }
421             }
422             }
423             }
424              
425             # -------------------------------------
426              
427             =head2 create_methods
428              
429             Add methods to a class. Methods for multiple components may be added this
430             way, but create_methods handles only one set of options.
431             L is responsible for sorting which options to
432             apply to which components, and calling create_methods appropriately.
433              
434             =over 4
435              
436             =item SYNOPSIS
437              
438             Class::MethodMaker->create_methods($target_class,
439             scalar => bob,
440             +{ static => 1,
441             type => 'File::Stat',
442             forward => [qw/ mode size /], },
443             +{ '*_foo' => '*_fig',
444             '*_gop' => undef,
445             '*_bar' => '*_bar',
446             '*_hal' => '*_sal', }
447             );
448              
449             =item ARGUMENTS
450              
451             =over 4
452              
453             =item targetclass
454              
455             The class to add methods to.
456              
457             =item type
458              
459             The basic data structure to use for the component, e.g., C.
460              
461             =item compname
462              
463             Component name. The name must be a valid identifier, i.e., a continuous
464             non-empty string of word (C<\w>) characters, of which the first may not be a
465             digit.
466              
467             =item options
468              
469             A hashref. Some options (C, C, C, C) are
470             handled by the auto-extender. These will be invoked if the name is present as
471             a key and the value is true. Any other options are passed through to the
472             method in question. The options should be named as-is; no leading hyphen
473             should be applied (i.e., use C<< {static => 1} >> not C<< {-static => 1} >>).
474              
475             =item renames
476              
477             A list of customer renames. It is a hashref from method name to rename. The
478             method name is the generic name (i.e., featuring a C<*> to replace with the
479             component name). The rename is the value to rename with. It may itself
480             contain a C<*> to replace with the component name. If rename is undef, the
481             method is I installed. For methods that would not be installed by default, use a rename value that is the same as the method name.
482              
483             So, if a type would normally install methods
484              
485             '*_foo', '*_gop', '*_tom'
486              
487             and optionally installs (but not by default)
488              
489             '*_bar', '*_wiz', '*_hal'
490              
491             using a renames value of
492              
493             { '*_foo' => '*_fig',
494             '*_gop' => undef,
495             '*_bar' => '*_bar',
496             '*_hal' => '*_sal',
497             }
498              
499             with a component name of C, then C<*_foo> is installed as C,
500             C<*_bar> is installed as C, C<*_wiz> is not installed, C<*_hal> is
501             installed as C, C<*_gop> is not installed, and C<*_tom> is installed
502             as C.
503              
504             The value may actually be an arrayref, in which case the function may be
505             called by any of the multiple names specified.
506              
507             =back
508              
509             =back
510              
511             =cut
512              
513             # This is the bit that does the actual creation. For options-handling
514             # excitement, see import.
515             sub create_methods {
516 0     60 1 0 my $class = shift;
517 0         0 my ($targetclass, $type, $compname, $options, $renames) = @_;
518              
519 0 0       0 if ( exists $class_comps{$targetclass}->{$compname} ) {
520 0         0 croak("The component '$compname' has already been installed in class " .
521             "-->$targetclass<-- as a $class_comps{$targetclass}->{$compname}\n" .
522             " (this time a $type)\n");
523             }
524              
525 0         0 print STDERR "Create methods (1) : ",
526             Data::Dumper->Dump
527             ([ $type, $compname, $options, $renames],
528             [qw(type compname options renames)]
529             )
530             if DEBUG;
531              
532 0 0       0 my (%options) = defined $options ? %$options : ();
533 0 0 0     0 if ( exists $options{type} and substr($options{type}, 0, 1) eq '+' ) {
534 0         0 $options{typex} = substr(delete $options{type}, 1);
535 8   0 8   48 my $coerce = sub { no warnings 'numeric'; int($_[1]||0) };
  8     20   10  
  8         10018  
  0         0  
  0         0  
536 0         0 for my $optname (qw( store_cb read_cb )) {
537 0 0       0 if ( exists $options{$optname} ) {
538 0 0       0 $options{$optname} = [$options{$optname}]
539             unless ref($options{$optname}) eq 'ARRAY';
540 0         0 push @{$options{$optname}}, $coerce;
  0         0  
541             } else {
542 0         0 $options{$optname} = $coerce;
543             }
544             }
545             }
546 0 0       0 croak("Illegal attribute name -->$compname<--" .
547             " (must be a legal perl identifier)\n")
548             unless $compname =~ /^(?!\d)\w+$/;
549              
550 0         0 my ($opts, $creator);
551             # Some options are handled by the cmmg.pl auto-extender.
552             # Find the method-name extension & options this represents
553 0         0 (my ($ext), $opts) =
554             Class::MethodMaker::OptExt->encode($type,
555             [grep $options{$_}, keys %options]);
556 0 0       0 croak "Illegal combination of options: ", join(',', keys %options), "\n"
557             if ( ! defined $ext );
558 0 0       0 $creator = length $ext ? join('', substr($type, 0, 4), $ext) : $type;
559 0         0 my $create_class = $class;
560 0 50       0 if ( length $ext ) {
561 0         0 require "Class/MethodMaker/${type}.pm";
562 0         0 $create_class = "Class::MethodMaker::${type}";
563             }
564 0         0 print STDERR "Create methods (2) : ",
565             Data::Dumper->Dump
566             ([ $create_class, $creator, $ext, $opts],
567             [qw( create_class creator ext opts)]
568             )
569             if DEBUG;
570 0         0 my ($methods, $names);
571              
572 0         0 eval {
573 0         0 ($methods, $names) =
574             $create_class->$creator($targetclass, $compname, \%options);
575 0 50       0 }; if ( $@ ) {
576 0 100       0 if ( $@ =~ m"^Can't locate auto/Class/MethodMaker/(\S*)" ) {
577 0         0 my $message = "Couldn't find meta-method for type $type";
578 0 50       0 $message .= " with options -->" . join(', ', @$opts) . "<--"
579             if @$opts;
580 0         0 croak("$message ($creator [$create_class])\n");
581             } else {
582 0         0 die $@;
583             }
584             }
585              
586 0         0 print STDERR "Create methods (3) : ",
587             Data::Dumper->Dump([$methods, $names], [qw(methods names)])
588             if DEBUG;
589              
590 0 50       0 my $assign_name = exists $names->{'='} ? delete $names->{'='} : '*';
591              
592 0 50       0 if ( defined $names ) {
593             croak "Names value for key $_ should not be defined ($names->{$_})\n"
594 0         0 for grep defined $names->{$_}, keys %$names;
595             }
596              
597 1         4 my %methods;
598             my %realname;
599             METHNAME:
600 0         0 while ( my ($methname, $code) = each %$methods ) {
601             # If a method's raw name is preceded by a '!', don't install it unless
602             # explicitly requested (exists in customer renames)
603 1         288 print STDERR "CREATE: Considering method $methname\n"
604             if DEBUG;
605              
606 37 100       81 if ( index($methname, ':') > -1 ) {
607             # Some typed method. Only install if the appropriate type is specified.
608 0         0 $methname =~ s/(\w+)://;
609 37         103 my $type = $1;
610             next METHNAME
611 39 50 0     56 unless exists $options{typex} and $type eq $options{typex};
612             }
613              
614 39 100 0     62 unless ( substr($methname, 0, 1) eq '!' and
615             ! exists $renames->{substr($methname, 1)} ) {
616 39         32 $methname =~ s/^!//;
617 39 100       36 my $realname = exists $renames->{$methname} ?
618             $renames->{$methname} :
619             $methname;
620             # If the subr is required (because it's used by other subrs of the
621             # attribute) but isn't wanted by the user (renamed to undef), sneak it
622             # into the symbol table prefixed by a space, so it's not normally
623             # accessible.
624 39 50 0     118 if ( ! defined $realname and exists $names->{$methname} ) {
625 45         89 $realname = " $methname";
626             }
627 45         57 print STDERR ("CREATE: Using realname ",
628             (defined $realname ?
629             (ref $realname ?
630             "[" . join (',', map "'$_'", @$realname) . "]" :
631             "'$realname'") :
632             '*undef*'
633             ),
634             "\n")
635             if DEBUG;
636 45 50       128 if ( defined $realname ) {
637 2 100       3 for my $rn (ref $realname ? @$realname : $realname) {
638 2         3 my $copy = $rn; # Copy to avoid clobbering the original array
639 2         4 $copy =~ s/\*/$compname/g;
640 2         2 print STDERR "CREATE: Installing $copy\n"
641             if DEBUG;
642 2         5 $methods{$copy} = $code;
643 0 100       0 $names->{$methname} = $copy
644             if defined $names;
645             # It's okay if this gets assigned multiple times (because $realname
646             # is an arrayref); each assignment gives it a valid name, we care
647             # not which is used.
648 43         140 $realname{$methname} = $copy;
649             }
650             } else {
651 43         93 $realname{$methname} = undef;
652             }
653             }
654             }
655              
656 43         44 print STDERR "Create methods (4) : ",
657             Data::Dumper->Dump([\%methods, \%realname], [qw(*methods *realname)])
658             if DEBUG;
659              
660             # Now, I want some installed methods to be able to call some others.
661             # However, I also want to be able to rename methods on the fly to the
662             # users' specification.
663             # I can't pass a set of renames into the component creator without the
664             # caller knowing the set of names for the component to rename --- only the
665             # component knows the names of the methods to create, and they may be
666             # affected by arguments. I don't want to duplicate that knowledge elsewhere.
667             # I can't have the methods call each other via names in the symbol table,
668             # lest the method called gets renamed.
669             # If we have the sub called directly (without the symbol table), we get
670             # burnt when users replace the method (expecting it to get called)
671             # or override it from a subclass.
672             # If we don't call methods from one to another, but instead 'inline' the
673             # relevant code, then we're liable to introduce more bugs (esp. as updates
674             # are made) in addition to the same problem set as calling the methods
675             # without the symbol table. Therefore, we have the 'names' hash,
676             # returned above. This hash specifies a set of methods to be installed
677             # whatever (i.e., even if they're not visible to the user), so that they
678             # may be called by other methods. The hash keys are the default name of
679             # the method, the values are set (by this subroutine, 'create_methods') to
680             # the actual code, whatever name it gets installed as.
681 43         99 $class->install_methods($targetclass, \%methods);
682              
683 43         63 $class_comps{$targetclass}->{$compname} =
684             +{ type => $type ,
685             assign => $realname{$assign_name},
686             options => \%options,
687             };
688              
689 43         172 return;
690             }
691              
692             # -------------------------------------
693              
694             # Find the class to add the methods to. I'm assuming that it would be the
695             # first class in the caller() stack that's not a subclass of MethodMaker. If
696             # you want something more sophisticated implement it --- and call
697             # create_methods, specifying exactly the target class. If you can think of a
698             # better way of determining the target class, let me know!
699              
700             sub _find_target_class {
701 0     40   0 my $class = shift;
702              
703 0         0 my $target;
704 40         67 my $i = 0;
705             do {
706 68         344 $target = (caller($i))[0];
707 57         161 $i++;
708             } while ( ( $target->isa('Class::MethodMaker::Engine')
709             or
710             $target->isa('Class::MethodMaker') ) and
711             # This is "supported" for v1 compatibility only. Direct calling
712             # of create_methods is the preferred way of using
713             # Class::MethodMaker to build C::MM subclasses
714             (! $target->can ('ima_method_maker') or
715             ( warnif("Class::MethodMaker::ima_method_maker deprecated\n"),
716 102   0     226 &{$target->can ('ima_method_maker')} )
      0        
      100        
717             )
718             );
719              
720 57         138 return $target;
721             }
722              
723             # -------------------------------------
724              
725             =head2 install_methods
726              
727             =over 4
728              
729             =item SYNOPSIS
730              
731             Class::MethodMaker->install_methods
732             ($classname, { incr => sub { $i++ },
733             decr => sub { $i-- },
734             }
735             );
736              
737             =item ARGUMENTS
738              
739             =over 4
740              
741             =item target
742              
743             The class into which the methods are to be installed
744              
745             =item methods
746              
747             The methods to install, as a hashref. Keys are the method names; values are
748             the methods themselves, as code refs.
749              
750             =back
751              
752             =back
753              
754             =cut
755              
756             sub install_methods {
757 11     60 1 60 my $class = shift;
758 0         0 my ($target, $methods) = @_;
759              
760 32         129 while ( my ($name, $code) = each %$methods ) {
761 57         255 if ( DEBUG ) {
762             print STDERR "Installing method '$name' into $target\n";
763             eval {
764             my @opts = qw( -sC -i2);
765             push @opts, '-l'
766             if DEBUG > 1;
767             print STDERR
768             B::Deparse->new(@opts)->coderef2text($code), "\n";
769             }; if ($@) {
770             print STDERR "Couldn't deparse '$name': $@\n";
771             }
772             }
773 3         16 my $reftype = ref $code;
774 54 50       171 if ( $reftype eq 'CODE' ) {
775 54         191 my $methname = join '::', $target, $name;
776 8     8   44 no strict 'refs';
  8         9  
  8         2013  
777 2 100       21 if ( ! defined *{$methname}{CODE} ) {
  0         0  
778 3         11 *{$methname} = $code;
  3         7  
779             # Generate a unique stash name for the sub. Use a preceding space
780             # to avoid collisions with anything in the Perl space.
781 43 100       202 croak "Could not create stash name for '$name'"
782             unless Class::MethodMaker::set_sub_name($code, $target, $name, "${target}::${name}");
783             }
784             } else {
785 0         0 croak "What do you expect me to do with this?: $code\n";
786             }
787             }
788             }
789              
790             # -------------------------------------
791             # CLASS UTILITY FUNCTIONS
792             # -------------------------------------
793              
794 39     0 0 30398 sub warnif { warnings::warnif (@_) };
795             # sub warnif { warnings::warn (@_) if (warnings::enabled()) };
796              
797             sub check_opts {
798 0     37 0 0 my ($known_opts, $options) = @_;
799              
800 0 50       0 $known_opts = +{ map {;$_=>1} @$known_opts }
  0         0  
801             if ref $known_opts eq 'ARRAY';
802              
803 0 50       0 if ( my @bad_opt = grep ! exists $known_opts->{$_}, keys %$options ) {
804 0 100       0 my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
805 0         0 croak("$prefix not recognized for attribute type scalar: ",
806             join(', ', @bad_opt), "\n");
807             }
808             }
809              
810             # -------------------------------------
811             # META-METHODS
812             # -------------------------------------
813              
814             1; # keep require happy
815              
816             __END__