view release on metacpan or  search on metacpan

lib/Class/Generate.pm  view on Meta::CPAN

    my $i           = 0;
    for my $param (@param_names)
    {
        croak
qq|$cm: Error in new => { style => '... $param' }: $param is not a member|
            if !defined $class->members($param);
        croak
qq|$cm: Error in new => { style => '... $param' }: $param is not a public member|
            if $class->private($param) || $class->protected($param);
    }
    my %uses;
    for my $param (@param_names)
    {
        $uses{$param}++;
    }
    %uses = map( ( $uses{$_} > 1 ? ( $_ => $uses{$_} ) : () ), keys %uses );
    if (%uses)
    {
        croak "$cm: Error in new => { style => '...' }: ",
            join( '; ', map qq|Name "$_" used $uses{$_} times|, keys %uses );
    }
};

$croak_if_duplicate_names = sub {
    my $class_spec = $_[0];
    my ( @names, %uses );
    if ( UNIVERSAL::isa( $class_spec, 'ARRAY' ) )
    {
        for ( my $i = 0 ; $i <= $#$class_spec ; $i += 2 )
        {
            push @names, $$class_spec[$i];
        }
    }
    else
    {
        @names = keys %$class_spec;
    }
    for (@names)
    {
        $uses{ substr( $_, 0, 1 ) eq '&' ? substr( $_, 1 ) : $_ }++;
    }
    %uses = map( ( $uses{$_} > 1 ? ( $_ => $uses{$_} ) : () ), keys %uses );
    if (%uses)
    {
        croak "$cm: ",
            join( '; ', map qq|Name "$_" used $uses{$_} times|, keys %uses );
    }
};

$invalid_spec_message = sub {
    return
        sprintf
        qq|$cm: Invalid specification of %s "%s" ($sh_needed with "%s" key)|,
        @_;
};

package Class::Generate::Class_Holder;    # This package encapsulates functions
$Class::Generate::Class_Holder::VERSION = '1.18';
use strict;    # related to storing and retrieving
               # information on classes.  It lets classes
               # saved in files be reused transparently.
my %classes;

sub store($)
{    # Given a class, store it so it's
    my $class = $_[0];                    # accessible in future invocations of
    $classes{ $class->name } = $class;    # class() and subclass().
}

# Given a class name, try to return an instance of Class::Generate::Class
# that models the class.  The instance comes from one of 3 places.  We
# first try to get it from wherever store() puts it.  If that fails,
# we check to see if the variable %<class_name>::_cginfo exists (see
# form(), below); if it does, we use the information it contains to
# create an instance of Class::Generate::Class.  If %<class_name>::_cginfo
# doesn't exist, the package wasn't created by Class::Generate.  We try
# to infer some characteristics of the class.
sub get($;$)
{
    my ( $class_name, $default_type ) = @_;
    return $classes{$class_name} if exists $classes{$class_name};

    return undef if !eval '%' . $class_name . '::';    # Package doesn't exist.

    my ( $class, %info );
    if ( !eval "exists \$" . $class_name . '::{_cginfo}' )
    {                                                  # Package exists but is
        return undef if !defined $default_type;        # not a class generated
        if ( $default_type eq 'ARRAY' )
        {                                              # by Class::Generate.
            $class = new Class::Generate::Array_Class $class_name;
        }
        else
        {
            $class = new Class::Generate::Hash_Class $class_name;
        }
        $class->constructor( new Class::Generate::Constructor );
        $class->constructor->style( new Class::Generate::Own );
        $classes{$class_name} = $class;
        return $class;
    }

    eval '%info = %' . $class_name . '::_cginfo';
    if ( $info{base} eq 'ARRAY' )
    {
        $class = Class::Generate::Array_Class->new( $class_name,
            last => $info{last} );
    }
    else
    {
        $class = Class::Generate::Hash_Class->new($class_name);
    }
    if ( exists $info{members} )
    {    # Add members ...
        while ( my ( $name, $mem_info_ref ) = each %{ $info{members} } )
        {
            my ( $member, %mem_info );
            %mem_info = %$mem_info_ref;
        DEFN:
            {
                $mem_info{type} eq "\$" and do