Class-Declare
view release on metacpan - search on metacpan
view release on metacpan or search on metacpan
# NB: when using Storable::dclone we need to make sure that we
# only clone each reference once, so if multiple entries
# refer to the same structure, then the copy of the hash will show
# those entries pointing to the same structure
my %hash; undef %hash;
{
# create a lookup table of all stored references
my %memory; undef %memory;
# for each class, extract the attribute definition array
ISA: foreach my $isa ( @isa ) {
# only worry about Class::Declare classes
next ISA unless ( exists $__DECL__{ $isa } );
# extract the definition hash for this class
# this contains the default values for the class and object
# attributes
# however, if we've been called as an instance method, then we
# should use the calling object's instance hash (stored in
# %__OBJECTS__) for the default values
# have we been called as an instance method?
# - extract the instance hash
# - otherwise, use the class's default hash (ignore this class
# if there is no default hash)
my $defn = ref( $self ) ? $__OBJECTS__{ ${ $self } }
: $__DEFN__{ $isa };
# split the typemap hash into key/value pairs
# - the typemap hash maps attributes to their types
# e.g. public, private, protected, etc
while ( my ( $key , $type ) = each %{ $__TYPE__{ $isa } } ) {
# extract the value for this attribute
my $value = $defn->{ $key };
# if this is an instance attribute and it has a reference
# value then we should clone the attribute value so that
# each instance has a copy of the original structure
my $vtype = ref( $value );
if ( $vtype && $vtype ne 'CODE' && $__INSTANCE__{ $type } ) {
# OK, we need to keep track of the references we
# clone, so that if we see the same reference more
# than once we only clone it a single time
# clone this reference if we haven't seen it before
$value = $memory{ $value }
||= Storable::dclone( $value );
}
# store the key/value pair
$hash{ $key } = $value;
}
}
}
# create an anonymous hash reference for this object
my $ref = \%hash;
my ( $key ) = ( $ref =~ m#0x([a-f\d]+)#o );
$__OBJECTS__{ $key } = $ref;
# create the new object (applying the index offset)
my $obj = bless \$key => $class;
# if there were any arguments passed, then these will be used to
# set the parameters for this object
# NB: - only public attributes may be set this way
# - need to examine every class in the @ISA hierarchy
# - may override 'public attributes' with 'new' list in declare()
my $default = sub {
( defined $__NEW__{ $_[0] } )
? @{ $__NEW__{ $_[0] } }
: map { @{ $_ } }
grep { defined }
map { $_->{ public } }
grep { defined }
( $__ATTR__{ $_ } )
}; # $default()
my %default = map { $_ => $hash{ $_ } }
map { $default->( $_ ) } @isa;
my %args = eval { __PACKAGE__->arguments( \@_ => \%default ) };
# if there has been an error, then augment the error string
# with a new() specific explanation
# NB: have to adjust the original error string to show the
# source of the original error
if ( $@ ) {
my ( undef , $file , $line , $sub ) = caller 0;
# rather than report this base class, make sure the
# subroutine is a method of the calling class
my $pkg = __PACKAGE__;
$sub =~ s#$pkg#$class#g;
# augment the error message
my $msg = $@;
$msg =~ s#\S+ at #$sub() at #;
$msg =~ s#at \S+ line \d+#at $file line $line#;
# add the additional explanation to the message
die $msg . "\t(only public attributes may be set during "
. "object creation)\n";
}
# otherwise, set the default attributes for this object
$hash{ $_ } = $args{ $_ } foreach ( keys %args );
# execute the initialisation routines
foreach my $pkg ( grep { exists $__INIT__{ $_ } } @isa ) {
# make sure the initialisation succeeds
$__INIT__{ $pkg }->( $obj )
or do {
my ( undef , $file , $line ) = caller 0;
die "Initialisation of $class object failed at "
. "$file line $line\n\t($pkg initialisation)\n";
};
}
# return the object
return $obj;
} # new()
view all matches for this distributionview release on metacpan - search on metacpan
( run in 0.868 second using v1.00-cache-2.02-grep-82fe00e-cpan-503542c4f10 )