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