# (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.19';
# -------------------------------------
# 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 continuous
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 subclass 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.
croak "Could not create stash name for '$name'"
unless 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 constructor 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 initializer 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 responsibility 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 overridden 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: ",
join(', ', @bad_opt), "\n");
}
return +{ '*' => sub {
my ($self) = @_;
my $cclass = ref $self;
die <<"END";
Cannot invoke abstract method '${tclass}::${name}', called from '$cclass'.
END
},
};
}
# ----------------------------------------------------------------------------
=head2 copy
use Class::MethodMaker
[ copy => [qw/ shallow -deep deep /] ];
This creates method that produce a copy of self. The copy is a by default a
I<shallow> copy; any references will be shared by the instance upon which the
method is called and the returned newborn. One option is taken, C<-deep>,
which causes the method to create I<deep> copies instead (i.e., references are
copied recursively).
B<Implementation Note:>
Deep copies are performed using the C<Storable> module if available, else
C<Data::Dumper>. The C<Storable> module is liable to be much quicker.
However, this implementation note is not an API specification: the
implementation details are open to change in a future version as faster/better
ways of performing a deep copy become available.
Note that deep copying does not currently support the copying of coderefs,
ties or XS-based objects.
=cut
sub copy {
my $class = shift;
my ($tclass, $name, $options, $global) = @_;
check_opts([qw/ v1_compat deep /], $options);
if ( $options->{deep} ) {
eval 'use Storable;';
eval 'use Data::Dumper;' if $@;
die("Couldn't find required Data::Dumper module for deep copying: $@\n",
"(which is odd, 'cause it's part of the core...\n")
if $@;
return +{ '*' => sub {
my $self = shift; my $class = ref $self;
if ( Storable->VERSION ) {
return Storable::dclone $self;
} else {
my $copy;
eval Data::Dumper->Dump([$self],['copy']);
return $copy;
}
},
};
} else {
return +{ '*' => sub {
my $self = shift; my $class = ref $self;
return bless { %$self }, $class;
},
};
}
}
# ----------------------------------------------------------------------------
# This supplied for V1 compatiblity only
my (%BooleanPos, %BooleanFields);
sub _boolean {
my $class = shift;
my ($tclass, $name, $options, $global) = @_;
check_opts([qw/ v1_compat /], $options);
my $bstore = join '__', $tclass, 'boolean';
$BooleanFields{$tclass} ||= [];
my $boolean_fields = $BooleanFields{$tclass};
my $bfp = $BooleanPos{$tclass}++;
# $boolean_pos a global declared at top of file. We need to make a local
# copy because it will be captured in the closure and if we capture the
# global version the changes to it will effect all the closures. (Note also
# that it's value is reset with each call to import_into_class.)
push @$boolean_fields, $name;
# $boolean_fields is also declared up above. It is used to store a list of
# the names of all the bit fields.
return +{
'bits' => sub {
my ($self, $new) = @_;
defined $new and $self->{$bstore} = $new;
$self->{$bstore};
},
'bit_fields' => sub { @$boolean_fields; },
'bit_dump' => sub {
my ($self) = @_;
map { ($_, $self->$_()) } @$boolean_fields;
},
'*' => sub {
my ($self, $on_off) = @_;
defined $self->{$bstore} or $self->{$bstore} = "";
if (defined $on_off) {
vec($self->{$bstore}, $bfp, 1) = $on_off ? 1 : 0;
}
vec($self->{$bstore}, $bfp, 1);
},
'*_set' => sub {
my ($self) = @_;
$self->$name(1);
},
'*_clear' => sub {
my ($self) = @_;
$self->$name(0);
},
};
}
=head1 AUTHOR
Martyn J. Pearce <fluffy@cpan.org>
=cut