view release on metacpan or  search on metacpan

Declare.pm  view on Meta::CPAN

  #   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()