view release on metacpan or  search on metacpan

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

        push @args, $attr;
    }
    
    my @caller_isa;
    
    { no strict 'refs';
        @caller_isa = @{ $caller."::ISA" };
    }
    
    my $not_seen_parents = 0;
    for my $parent ( @caller_isa ) {
	
        next if $self->{$base_init_done_key}->{$parent};

        if ( my $code = $parent->can("init") ) {
            $not_seen_parents++;
            $self->$code( @args );
        }
    }

    unless ( $not_seen_parents ) {
        $self->$root_init(@args);
    }
};

declare base_destroy => method {
    my $self = shift;
    
    my $caller;
    if ( @_ and $_[0] =~ /^CALLER=(.*)/ ) {
        $caller = $1;
    }

    unless ( defined $caller ) {
	$caller = caller();
	$caller =~ s/::LOCAL$//;
    }

    $self->{$base_destroy_done_key}->{$caller} = 1;
    
    my @caller_isa;
    
    { no strict 'refs';
        @caller_isa = @{ $caller."::ISA" };
    }
    
    for my $parent ( @caller_isa ) {
	
        next if $self->{$base_destroy_done_key}->{$parent};

        if ( my $code = $parent->can("DESTROY") ) {
            $self->$code;
        }
    }

};

my $root_class_init = sub {
    my $class = shift;
    
    my $cdata = $class_data->{$class};

    my %args = ( @_ );

    while ( my($k,$v) = each %args ) {
        my $method = $k;
        unless ( $cdata->{$attr_init_done_key}->{$method} ) { 
            $cdata->{$attr_init_done_key}->{$method} = 1;
	    if ( ::RT_CHECKS ) {
		eval { $class->$method($v) };
		croak "Error calling method \"$method\" for \"$class\": $EVAL_ERROR\n" if $EVAL_ERROR;
	    } else {
		$class->$method($v);
	    }
        }
    }
};

declare class_init => class_method { goto $root_class_init };

declare base_class_init => class_method {
    my $class = shift;
    my $cdata = $class_data->{$class};

    my $caller;
    if ( @_ and $_[0] =~ /^CALLER=(.*)/ ) {
        shift;
        $caller = $1;
    }
    
    unless ( defined $caller ) {
	$caller = caller();
	$caller =~ s/::LOCAL$//;
    }
    
    $cdata->{$base_init_done_key}->{$caller} = 1;

    my %attr_values = %{ $schema->{$caller}->{CLASS_ATTR_VALUES} };
    my @args = ( %attr_values );
    
    my $key = 0;
    my $prefix = prefix($caller);
	
    foreach ( @_ ) {
        my $attr = $_;

	$key ^= 1;	
	$attr =~ s/^_/$prefix/ if $key;

        push @args, $attr;
    }
    
    my @caller_isa;
    
    { no strict 'refs';
        @caller_isa = @{ $caller."::ISA" };
    }
    
    my $not_seen_parents = 0;
    for my $parent ( @caller_isa ) {

        next if $cdata->{$base_init_done_key}->{$parent};

        if ( my $code = $parent->can("class_init") ) {
            $not_seen_parents++;
            $class->$code( @args );
        }
    }

    unless ( $not_seen_parents ) {
        $class->$root_class_init(@args);
    }
    
};

declare class_schema_check => class_method {
    my $class = shift;
    
    return 1 unless ::CT_CHECKS;

    my $err = "";
    while( my($name, $mhr) = each %{ $schema->{$class}->{SUBS} } ) {
	
	#print $name, Dumper($mhr);

	my $flags = $mhr->{FLAGS};
	my $parent = $mhr->{PARENT};
	if ( $flags & VIRT and $parent ne $class ) {
	    $err .= "Virtual method \"$name\" defined in class \"$parent\" not implemented in derived class \"$class\"\n";
	}
    }
    
    if ( $err ) {
	croak $err;
    }

    return 1;
};


if ( ::CT_CHECKS ) {

    declare class_schema => class_method sub(){

	my $proto = shift;
	my $class = ref($proto) || $proto;

	my $local_caller = caller();
	my $caller = cl2c($local_caller);
	
	$class = $caller unless defined $class;
    
	my $cschema = $schema->{$class};

	my $str = "";
	$str .= "class \"$class\" schema:\n";

	my $csubs = $cschema->{SUBS};
    
	my $class_attributes = "";
	my $attributes = "";
	my $class_methods = "";