File Coverage

blib/lib/Class/Root.pm

Criterion	Covered	Total	%
statement	655	776	84.4
branch	202	306	66.0
condition	74	153	48.3
subroutine	70	78	89.7
pod	0	1	0.0
total	1001	1314	76.1

package Class::Root;

use 5.006000;
use warnings;
use strict;

=head1 NAME

Class::Root - framework for writing perl OO modules

=head1 VERSION

Version 0.02

=cut

our $VERSION = '0.02';

my $ROOT_CLASS = __PACKAGE__;

package declare;

sub import {
    shift;
    goto &Class::Root::LOCAL::declare;
}

sub new {
    my $class = shift;
    my $self = { @_ };
    bless $self, $class;
}

$INC{"declare.pm"} = 1;

package Class::Root::LOCAL;

use strict;
use warnings;

use English;
use Carp;
$Carp::Verbose = 0;

use Data::Dumper;

use Filter::Util::Call;

my @flags;
BEGIN {
    *::CT_CHECKS = sub(){1} unless defined(&::CT_CHECKS);
    *::RT_CHECKS = sub(){1} unless defined(&::RT_CHECKS);
    *::LOCAL_SUBS = sub(){1} unless defined(&::LOCAL_SUBS);

    @flags = qw( AF MF CF PRIV PROT RO OVER VIRT SETOPTS );

    my $i = 0;

    foreach (@flags) {
	my $n = $i++;
	no strict 'refs';
	*$_ = sub(){ 1<<$n };
    }
}

sub flags2hr {
    my $flags = shift;
    my $hr;
    foreach (@flags) {
	no strict 'refs';
	$hr->{$_} = $flags & &$_ ? 1 : 0;
    }
    return $hr;
}

# here we save class attributes for all classes
my $class_data = {};

# hash of all subs ( methods and attributes )
my $subs = {};

# class schema hash
my $schema = {};

sub init_schema {
    my $class = shift;

    $schema->{$class} = {
	NUMBER_OF_PARENTS => 0,
	HAVE_CLASS_ATTR_VALUES => 0,
	HAVE_INSTANCE_ATTR_VALUES => 0,
        INSTANCE_ATTR_VALUES => {},
	CLASS_ATTR_VALUES => {},
        PROT_EXPORT => [],
	LOCAL_SUBS => {},
	SUBS => {},
	CT_OPTS => {
	    VERBOSE_SOURCE_CODE_CHANGES => 0,
	    DEFINE_LOCAL_SUBS => 0,
	    VERBOSE => 0,
	},
    }
}

init_schema($ROOT_CLASS);

my @export_local = qw( declare attribute class_attribute attributes method class_method overwrite override private protected virtual readonly setopts setoptions setval setvalue );

sub prefix {
    my $str = shift;

    $str =~ s/:/_/g;
    return $str."__";
};

my $ROOT_CLASS_PREFIX = prefix($ROOT_CLASS);

my %s2f = (
    '_' => PRIV,
    ':' => CF,
    '?' => RO,
    '*' => PROT,
    '!' => OVER,
    '~' => VIRT,
);

sub method_name_ok {
    local $_ = shift;
    /^[_:?*!~]*[a-zA-Z]\w*$/;
}

sub sflags2flags {
    my $sflags = shift;

    my $flags = 0;
    foreach ( unpack('A1' x length($sflags), $sflags) ) {
        $flags |= $s2f{$_};
    }
    return $flags;
}

sub c2cl {
    my $class = shift;
    return $class."::LOCAL";
}

sub cl2c {
    my $str = shift;
    $str =~ s/::LOCAL$//;
    return $str;
}

sub vmesg {
    my $class = shift;
    my $mesg = shift;

    my $verbose = $schema->{$class}->{CT_OPTS}->{VERBOSE};
    print STDERR $mesg if $verbose;
}

sub declare {

    my $caller_local = caller();
    my $caller = cl2c($caller_local);

    my @args = ();

    #print Dumper( \@_ );

    foreach ( @_ ) {
        if ( /^([+-])(.*)/ ) {
	    my $v = ( $1 eq '+' ) ? 1 : 0;
	    my $k = $2;
	    my $old_v = $schema->{$caller}->{CT_OPTS}->{$k};
	    $schema->{$caller}->{CT_OPTS}->{$k} = $v;

	    if ( $k eq 'DEFINE_LOCAL_SUBS' and $v and !$old_v ) {
	        define_local_subs($caller_local, $caller, $caller);
	    }

	} else {
	    push @args, $_;
	}
    }

    @_ = @args;

    my $i = 0;
    while ( @_ ) {

        my $name_str = shift;
	my $hr = shift;

	unless ( defined $hr ) {
	    $hr = "declare"->new( FLAGS => AF, OPTS => {} );
	}

	unless ( ref($hr) eq "declare" ) {
	    $hr = "declare"->new( FLAGS => AF, OPTS => { value => $hr } );
	}

	if ( ::CT_CHECKS ) {
	    $i += 2;
	    croak "declare: syntax error - wrong argument in position $i\n" unless ref($hr) eq "declare";
	}

	unless ( $name_str =~ /([:_?*!~]*)([a-zA-Z]\w*)$/ ) {
	    croak "Wrong format for method name -->$name_str<--\n";
	}

	my $flags = sflags2flags($1);
        my $pub_name = $2;

        $flags |= $hr->{FLAGS};

	#attribute flag is set by default
	$flags |= AF unless $flags & MF;

        my $priv_name = prefix($caller) . $pub_name;

        my $opts = $hr->{OPTS};

	my $name = $pub_name;
	my $key = $pub_name;
	my $sub;
	my $tied_sub;

	if ( $flags & AF ) {

	    my $oro = $opts->{readonly};
	    if ( defined $oro ) {
		$flags |= RO if $oro;
		$flags = $flags | RO ^ RO unless $oro;
	    }
	}

	# remove PRIV flag for RO attrs
	my $ro_flags = $flags | PRIV ^ PRIV;

	# remove PROT flag for RO attrs
	$ro_flags = $ro_flags | PROT ^ PROT;

	# force PRIV flag fo priv part of RO and PROT
	$flags |= PRIV if $flags & (RO|PROT);

        if ( $flags & PRIV ) {
	    $name = $priv_name;
	    $key = $priv_name;
        }

	# set options for existing method
	if ( $flags & SETOPTS ) {
	    setopts_only( CLASS => $caller, NAME => $name, OPTS => $opts );
	    next;
	}

	if ( exists $opts->{value} ) {
	    my $key = $flags & CF ? "CLASS" : "INSTANCE";
	    $schema->{$caller}->{$key."_ATTR_VALUES"}->{$name} = $opts->{value};
	    $schema->{$caller}->{"HAVE_".$key."_ATTR_VALUES"} = 1;
	}

	$sub = $hr->{SUB} if $flags & MF;

	if ( $flags & AF ) {
	    ( $sub, $tied_sub ) = create_accessor( NAME => $name, KEY => $key, FLAGS => $flags );
	}
	make_method( CLASS => $caller, NAME => $name,  FLAGS => $flags, SUB => $sub, TIED_SUB => $tied_sub );

	if ( ::RT_CHECKS ) {
	    if ( exists $opts->{check_value} ) {
		$schema->{$caller}->{SUBS}->{$name}->{TIED} = 1;
		$schema->{$caller}->{SUBS}->{$name}->{CHECK_VALUE} = $opts->{check_value};
	    }
	}

	if ( $flags & RO ) {
	    ( my $ro_sub ) = create_accessor( NAME => $pub_name, KEY => $priv_name, FLAGS => $ro_flags );
	    make_method( CLASS => $caller, NAME => $pub_name,  FLAGS => $ro_flags, SUB => $ro_sub, TIED_SUB => $tied_sub );
	}
    }
};

sub setopts_only {
    my %args = ( @_ );

    my $class = $args{CLASS};
    my $name = $args{NAME};
    my $opts = $args{OPTS};

    my $mhr = $schema->{$class}->{SUBS}->{$name};

    if ( ::CT_CHECKS ) {

	croak "Can't set options for undefined attribute $name" unless defined $mhr;

	croak "Can't set options for readonly attribute $name" if $mhr->{FLAGS} & RO;

	croak "Can't set options for method" if $mhr->{FLAGS} & MF;

    }

    my $value = $opts->{value};

    if ( defined $value ) {
	my $key = $mhr->{FLAGS} & CF ? "CLASS" : "INSTANCE";
	$schema->{$class}->{$key."_ATTR_VALUES"}->{$name} = $value;
	$schema->{$class}->{"HAVE_".$key."_ATTR_VALUES"} = 1;
    }

    if ( ::RT_CHECKS ) {
	if ( defined $opts->{check_value} ) {
	    $schema->{$class}->{SUBS}->{$name}->{TIED} = 1;
    	    $schema->{$class}->{SUBS}->{$name}->{CHECK_VALUE} = $opts->{check_value};
	}
    }

}

sub gen_sub {

    my $name = shift;
    my $flag = shift;

    my $setopts = ( $name =~ /^setopt(ion)?s$/ or $name =~ /^setval(ue)?$/ );

    my $sub = sub {

	#print "$name: ", Dumper(\@_);

        my @ret = ();
        my $hr = "declare"->new( FLAGS => 0, OPTS => {} );

	if ( @_ ) {

	    my $arg0 = shift;

	    if ( $setopts ) {

		my $val = $arg0;
		my $val_pos = 1;

		if ( @_ ) {

		    if ( method_name_ok($arg0) ) {
			push @ret, $arg0;
			$hr->{FLAGS} = SETOPTS;

			$val = shift;
			$val_pos = 2;
		    }
		    #croak "function \"$name\": couldn't have more then 2 arguments" if @_;
		}

		if ( $name =~ /^setopt(ion)?s$/ ) {

		    croak "function \"$name\": argument at position $val_pos is not an options hr" unless ref($val) eq "HASH";
		    my %known_options = (
			value => 1,
			check_value => 1
		    );

		    foreach my $key ( keys %$val ) {
			croak "function \"$name\": unknown option $key" unless exists $known_options{$key};
		    }

		    $hr->{OPTS} = $val;

		} else {

		    $hr->{OPTS} = { value => $val };
		}


	    } else {

		if ( ref($arg0) eq "declare" ) {
		    $hr = $arg0

		} elsif ( ref($arg0) eq "HASH" ) {

		    croak "function \"$name\": arg0 could be a method name or other declare subfunction\n";
		} else {

		    croak "function \"$name\": wrong format of method name arg0\n" unless method_name_ok($arg0);

		    push @ret, $arg0;

		    if ( @_ ) {
			my $arg1 = shift;

			#croak "function \"$name\": couldn't have more then 2 arguments" if @_;

			if ( ref($arg1) eq "declare" ) {
			    $hr = $arg1;

			} else {

    			    $hr->{OPTS} = { value => $arg1 };
    			}
    		    }
		}
	    }
	}

	unless ( $setopts ) {
	    my $flags = $hr->{FLAGS};
	    $flags |= $flag;
	    $flags = $flags | SETOPTS ^ SETOPTS;
	    $hr->{FLAGS} = $flags;;
	}

	push @ret, $hr, @_;

        return @ret;
    };

    no strict 'refs';
    *$name = $sub;
};

my %declare_subs = (
    attribute => AF,
    class_attribute => CF|AF,
    protected => PROT,
    private => PRIV,
    virtual => VIRT,
    overwrite => OVER,
    override => OVER,
    readonly => RO,
    setopts => SETOPTS,
    setoptions => SETOPTS,
    setval => SETOPTS,
    setvalue => SETOPTS,
);

while ( my ($k, $v ) = each %declare_subs ) {
    gen_sub($k, $v);
}

sub method(;&) {
    #print "method: ", Dumper(\@_);
    my $sub = shift;
    return "declare"->new( FLAGS => MF,  SUB => $sub, OPTS => {} );
};

sub class_method(;&) {
    #print "class_method: ", Dumper(\@_);
    my $sub = shift;
    return "declare"->new( FLAGS => CF|MF, SUB => $sub, OPTS => {} );
};


sub attributes {

    my @ret = ();

    foreach ( @_ ) {
        foreach my $line ( split /\n/, $_ ) {

            $line =~ s/(^|\s)#.*//;

            foreach my $str ( split /\s+/, $line ) {

		next unless $str;

		unless ( $str =~ /^([_:?*]*)([a-zA-Z]\w*)$/ ) {
		    croak "Wrong attribute format for -->$str<--\n";
		}

                my $flags_str = $1;
                my $name = $2;

		my $flags = AF | sflags2flags($flags_str);

                push @ret, $name, "declare"->new( FLAGS => $flags, OPTS => {} );
            }
        }
    }

    return @ret;
};

if ( ::CT_CHECKS ) {

    *update_schema = sub {

	my $o = shift;
	my $n = !$o;

	my $hr = { @_ };

	my $name = delete $hr->{NAME};
	my $class = delete $hr->{CLASS};

	my $cschema = $schema->{$class};
	my $csubs = $cschema->{SUBS};

	unless ( exists $csubs->{$name} ) {
	    $csubs->{$name} = $hr;
	    return "";
	}

	my $hr2 = $csubs->{$name};

	my $ohr = $o ? $hr : $hr2;
	my $nhr = $o ? $hr2 : $hr;

	my $oflags = $ohr->{FLAGS};
	my $oparent = $ohr->{PARENT};
	my $osub = $ohr->{SUB};

	my $nflags = $nhr->{FLAGS};
	my $nparent = $nhr->{PARENT};
	my $nsub = $nhr->{SUB};

	my $ocf = $oflags & CF;
	my $ncf = $nflags & CF;

	my $overstr = $class eq $nparent ? " (defined in class \"$class\")" : " (defined in base class \"$nparent\")";

	if ( $ncf != $ocf ) {

	    my $type_str1 = $ncf ? "instance method" : "class method";
	    my $type_str2 = $ocf ? "instance method" : "class method";

	    return "$type_str1 \"$name\"$overstr also defined as $type_str2 \"$name\" in base class \"$oparent\"";
	}

	# same method in 2 base classes
	if ( ($class ne $nparent) and ($oparent ne $nparent) ) {
	    unless ( $name =~ /^(init|class_init|DESTROY)$/ ) {
		return "Method \"$name\"$overstr also defined in base class \"$oparent\"";
	    }
	}

	# overwriting of nonvirtual method from base class
	if ( ($class eq $nparent) and !($nflags & OVER) and !($oflags & VIRT) ) {
	    return "Method \"$name\"$overstr also defined in base class \"$oparent\"";
	}

	if ( $nflags & AF and $nflags & OVER ) {
	    return "attributes couldn't be overwritten";
	}

	return "" if ( $osub eq $nsub );

	$csubs->{$name} = $nhr;
	return "";

    };
}

# files for which we already have a filter
my %filter_line = ();

# already seen classes
my %import_done = ();

my $base_init_done_key = "_BASE_INIT_DONE";
my $base_destroy_done_key = "_BASE_DESTROY_DONE";
my $attr_init_done_key = "_ATTR_INIT_DONE";

declare import => class_method {
    my $parent = shift;

    my $isa_arg = "";
    if ( @_ and $_[0] eq "isa" ) {
	$isa_arg = shift;
    }

    my ( $caller, $caller_file, $caller_line ) = caller();
    my $caller_local = c2cl($caller);

    unless ( exists  $schema->{$caller} ) {
        init_schema($caller);
    }

    my $cschema = $schema->{$caller};
    my $copts = $cschema->{CT_OPTS};

    my @args = ();
    foreach ( @_ ) {
	if ( /^([+-])(.*)/ ) {
	    my $v = ( $1 eq '+' ) ? 1 : 0;
	    $copts->{$2} = $v;
	} else {
	    push @args, $_;
	};
    }

    unless ( $isa_arg ) {

        if ( $copts->{DEFINE_LOCAL_SUBS} ) {
	    define_local_subs($caller, $parent);
	}

	if ( my $local_import = $caller_local->can("import") ) {
	    local @_ = ( $parent, @args );
	    goto $local_import;
	} else {
	    return;
	}
    }

    my $filter_prefix = prefix($caller);

	$filter_line{$caller_file} = $caller_line+1;

	filter_add(
	    sub {
		my $status;

		if ( ( $status = filter_read() ) > 0 ) {

		    my $line = $filter_line{$caller_file}++;

		    if ( /^\s*package\s+([\w:]+)\s*;/ ) {
			filter_del() unless ( $1 eq $caller_local );
		    }

		    # $class_foo->_PrivMethod will be translated in $class_foo->Class__Foo__PrivMethod
		    my $sav_line = "$_";
		    my $changed = 0;

		    if ( $filter_prefix ) {
			s/((-\>\s*)_(?=[A-Za-z]))/$2$filter_prefix/g and $changed=1 ;
		    }

		    # $obj->__Some_Method will be translated in $obj->_Some_Method
		    s/(-\>\s*_)_/$1/g and $changed=1;

		    if ( ::CT_CHECKS ) {

			my $verbose_sf = $copts->{VERBOSE_SOURCE_CODE_FILTER};
			my $verbose = $copts->{VERBOSE};

			if ( $changed and ($verbose or $verbose_sf) ) {
			    print STDERR "Changing source file \"$caller_file\", line $line:\nfrom..> ${sav_line}to....> $_";
			}
		    }
		}

		$status;
	    }
	);

    # @ISA

    my $caller_isa = $caller."::ISA";

    if ( ::CT_CHECKS ) {
	vmesg($caller,"push $parent to \@$caller_isa\n");
    }

    { no strict 'refs';
	push @$caller_isa, $parent;
    }

    $cschema->{NUMBER_OF_PARENTS}++;

    # this should be done only once for each class
    unless ( $import_done{$caller} ) {

	$import_done{$caller} = 1;

	$class_data->{$caller} = {
	    $base_init_done_key => {},
	    $attr_init_done_key => {},
	};

	( my $inc_key = $caller ) =~ s{::}{/}g;
	$inc_key .= '.pm';
	$INC{$inc_key} = 1;

	# export declare and subfunctions in caller's "LOCAL" package
	foreach my $f ( @export_local ) {
	    my $caller_f = $caller_local."::".$f;

	    if ( ::CT_CHECKS ) {
		vmesg($caller,"Defining sub $caller_f\n");
	    }

	    no strict 'refs';
	    *$caller_f = *$f;
	}

	my $class_initialize = $caller_local."::class_initialize";

	if ( ::CT_CHECKS ) {
	    vmesg($caller,"Defining sub \"$class_initialize\"\n");
	}

	my $generic_class_init_method = sub {
	    my $class = shift;
	    $class->base_class_init( "CALLER=$caller", @_ );
	};

	my $caller_class_init = $caller."::class_init";

	{ no strict 'refs';
	    *$class_initialize = sub {

		unless ( defined(&$caller_class_init) ) {
		    if ( @_ or $cschema->{NUMBER_OF_PARENTS} > 1 or $cschema->{HAVE_CLASS_ATTR_VALUES} ) {
			if ( ::CT_CHECKS ) {
			    vmesg($caller,"Defining sub \"$caller_class_init\" with generic code\n");
			}

			*$caller_class_init = $generic_class_init_method;
		    }
		}

		$caller->class_init( @_ )
	    };
	}

	my $class_verify = $caller_local."::class_verify";

	if ( ::CT_CHECKS ) {
	    vmesg($caller,"Defining sub \"$class_verify\"\n");
	}

	my $generic_init_method = sub {
	    my $self = shift;
	    $self->base_init( "CALLER=$caller", @_ );
	};

	my $caller_init = $caller."::init";

	my $generic_destroy_method = sub {
	    my $self = shift;
	    $self->base_destroy( "CALLER=$caller" );
	};

	my $caller_destroy = $caller."::DESTROY";

	{ no strict 'refs';
	    *$class_verify = sub {

		unless ( defined(&$caller_init) ) {
		    if ( $cschema->{NUMBER_OF_PARENTS} > 1 or $cschema->{HAVE_INSTANCE_ATTR_VALUES} ) {
			if ( ::CT_CHECKS ) {
			    vmesg($caller,"Defining sub \"$caller_init\" with generic code\n");
			}

			*$caller_init = $generic_init_method;
		    }
		}

		unless ( defined(&$caller_destroy) ) {
		    if ( $cschema->{NUMBER_OF_PARENTS} > 1 ) {
			if ( ::CT_CHECKS ) {
			    vmesg($caller,"Defining sub \"$caller_destroy\" with generic code\n");
			}

			*$caller_destroy = $generic_destroy_method;
		    }
		}

		$caller->class_schema_check( @_ )
	    };
	}
    }

    my $caller_prot_export = $cschema->{PROT_EXPORT};

    my $caller_prefix = prefix($caller);

    my $pschema = $schema->{$parent};
    my $parent_prot_export = $pschema->{PROT_EXPORT};
    my $parent_prefix = prefix($parent);

    foreach my $prot_m ( @$parent_prot_export ) {

	push @$caller_prot_export, $prot_m;
	my $caller_prot_m = $caller_prefix.$prot_m;
        my $parent_prot_m = $parent_prefix.$prot_m;

        my $caller_mname = $caller."::$caller_prot_m";
        my $parent_mname = $parent."::$parent_prot_m";

	if ( ::CT_CHECKS ) {
	    vmesg($caller,"Defining sub $caller_mname as alias to $parent_mname\n");
	    my $pmhr = $pschema->{SUBS}->{$parent_prot_m};
	    my $err = update_schema( 1, CLASS => $caller, NAME => $caller_prot_m, SUB => $pmhr->{SUB}, PARENT => $parent, FLAGS => $pmhr->{FLAGS} );
            croak "Schema error for class \"$caller\": $err\n" if $err;
	}

	if ( ::LOCAL_SUBS ) {
	    my $pmhr = $pschema->{LOCAL_SUBS}->{$parent_prot_m};
	    $cschema->{LOCAL_SUBS}->{$caller_prot_m}->{SUB} = $pmhr->{SUB};
	    $cschema->{LOCAL_SUBS}->{$caller_prot_m}->{FLAGS} = $pmhr->{FLAGS};
	}

	no strict 'refs';
	*$caller_mname = *$parent_mname;

    }

    if ( ::CT_CHECKS ) {
        while ( my($m, $mhr) = each %{ $pschema->{SUBS} } ) {
	    my $sub = $mhr->{SUB};
	    my $parent = $mhr->{PARENT};
	    my $flags = $mhr->{FLAGS};
            my $err = update_schema( 1, CLASS => $caller, NAME => $m, SUB => $sub, PARENT => $parent, FLAGS => $flags );
            croak "Schema error: $err\n" if $err;
        }
    }

    if ( ::LOCAL_SUBS ) {
	while ( my($m, $mhr) = each %{ $pschema->{LOCAL_SUBS} } ) {
	    my $flags = $mhr->{FLAGS};
	    next if ( $flags & PRIV or exists $cschema->{LOCAL_SUBS}->{$m} );
	    $cschema->{LOCAL_SUBS}->{$m}->{SUB} = $mhr->{SUB};
	    $cschema->{LOCAL_SUBS}->{$m}->{FLAGS} = $flags;
	}
    }
};

sub define_local_subs {
    my $caller = shift;
    my $class = shift;
    my $default_class = shift;

    croak "Can't define local subs with disabled LOCAL_SUBS\n" unless ::LOCAL_SUBS;

    my $clsubs = $schema->{$class}->{LOCAL_SUBS};

    while ( my($f, $mhr) = each %$clsubs ) {

	my $flags = $mhr->{FLAGS};

	my $priv = $flags & PRIV;

	next if ( $caller ne $class and $priv );

	my $sub = $mhr->{SUB};
	my $prototype = prototype( $sub );
	if ( defined $prototype and $prototype eq "" ) {
	    $f = "_$f" if $priv;
	    if ( $priv ) {
		my $prefix = prefix($caller);
		$f =~ s/^$prefix/_/;
	    }
	    my $caller_f = $caller."::".$f;

	    my $lfsub = $sub;

	    my $def = "";
	    if ( defined $default_class and $flags & CF ) {
		my $ro = $flags & RO;

		if ($flags & RO and !$priv) {

		    $lfsub = sub {
			local $_ = shift || $default_class;
			&$sub;
		    };

		} else {

		    $lfsub = sub():lvalue {
			local $_ = shift || $default_class;
			&$sub;
		    };
		}

		if ( ::CT_CHECKS ) {
		    $def = "D:$default_class";
		}
	    }

	    no strict 'refs';

	    if ( defined &$caller_f ) {
		croak "Function \"$f\" already defined in package \"$caller\"\n" unless \&$caller_f eq $lfsub;
	    } else {

		if (::CT_CHECKS ) {
		    vmesg($caller,"Defining local sub $caller_f $def\n");
		}

		*$caller_f = $lfsub;
	    }
	}
    }
}

sub make_method {

    my %args = ( @_ );

    my $class = $args{CLASS};
    my $name = $args{NAME};
    my $flags = $args{FLAGS};
    my $sub = $args{SUB};
    my $tied_sub = $args{TIED_SUB};

    my $virt = $flags & VIRT;

    if ( ::CT_CHECKS ) {

	unless ( $name =~ /^[a-zA-Z]\w*$/ ) {
	    croak "Wrong method name: -->$name<--. Supported method names should match ".'/^[a-zA-Z]\w*$/'."\n";
	}

	if ( !$virt and !defined( $sub ) ) {
	    croak "class $class: implementation subroutine should be defined for non-virtual method \"$name\"\n";
	}

	if ( $virt and defined( $sub ) ) {
	    croak "class $class: no implementation subroutine should be defined for virtual method \"$name\"\n";
	}

	my $over = $flags & OVER;
	my $cschema = $schema->{$class};
	my $csubs = $cschema->{SUBS};

	my $code;
	if ( !$over and $code = $class->can($name) ) {
	    unless( $csubs->{$name}->{FLAGS} & VIRT ) {
		my $bc = defined $csubs->{$name} ? $csubs->{$name}->{PARENT} : "???";

		my $mname = $name;
		if ( $csubs->{$name}->{FLAGS} & PRIV ) {
		    my $prefix = prefix($class);
		    $mname =~ s/^$prefix/_/;
		}
		croak "class \"$class\": method \"$mname\" already defined in base class \"$bc\"\n";
	    }
	}

	if ( $over and !$class->can($name) ) {
	    croak "class \"$class\": method $name not defined, can not overwrite\n";
	}
    }

    if ( $virt ) {
	$sub = sub {
	    my ($package, $filename, $line ) = caller(1);
	    croak "call of virtual method \"$name\" defined in class \"$class\" from package \"$package\", file \"$filename\", line \"$line\"\n";
	};
    }

    if ( $flags & PROT ) {
        my $prefix = prefix($class);
        $name =~ /^$prefix(.*)/;
        push @{ $schema->{$class}->{PROT_EXPORT} }, $1;
    }

    my $method_name = $class."::".$name;

    unless ( exists $subs->{$sub} ) {
	$subs->{$sub} = {
	    NAME => $name,
	    SUB => $sub,
	    TIED_SUB => $tied_sub,
	}
    }

    if ( ::CT_CHECKS ) {
	my $err = update_schema( 0, CLASS => $class, PARENT => $class, NAME => $name, SUB => $sub, FLAGS => $flags );
        croak "Schema error in class \"$class\": $err\n" if $err;
    };

    if ( ::LOCAL_SUBS ) {
	my $cschema = $schema->{$class};
	$cschema->{LOCAL_SUBS}->{$name}->{SUB} = $sub;
	$cschema->{LOCAL_SUBS}->{$name}->{FLAGS} = $flags;
    }

    if ( ::CT_CHECKS ) {
        vmesg($class,"Defining sub $method_name\n");
    }

    {
	no strict 'refs';
        if ( $name eq "class_init" or $name eq "init" or $name eq "DESTROY" ) {
	    no warnings;
	    *$method_name = $sub;
	} else {
	    *$method_name = $sub;
	}
    }

    if ( ::LOCAL_SUBS ) {

	if ( $schema->{$class}->{CT_OPTS}->{DEFINE_LOCAL_SUBS} ) {
	    my $local_func_name = $class."::LOCAL::".$name;

	    my $cf = $flags & CF;
	    my $ro = $flags & RO;
	    my $priv = $flags & PRIV;

	    if ( $priv ) {
		my $prefix = prefix($class);
		$name =~ /^$prefix(.*)/;
		$local_func_name = $class."::LOCAL::_$1";
	    }

	    my $prototype = prototype( $sub );
	    if ( defined $prototype and $prototype eq "" ) {

		my $lfsub = $sub;

		my $def = "";
		if ( $cf ) {

		    $lfsub = ($ro and !$priv) ? sub{local $_=shift||$class; &$sub} : sub():lvalue{local $_=shift||$class; &$sub };

		    $def = "D:$class";
		}

		if ( ::CT_CHECKS ) {
		    vmesg($class,"Defining local sub $local_func_name\n");
		}

		no strict 'refs';
		*$local_func_name = $lfsub;
	    }
	}
    }
};

my $ties = {};

if ( ::RT_CHECKS ) {

    *Class::Root::tiescalar::TIESCALAR = sub {
	my $class = shift;
	my $scalar = undef;
	return (bless \$scalar, $class);
    };

    *Class::Root::tiescalar::FETCH = sub {
	my $self = shift;

	my $hr = $ties->{$self}->{hr};
	my $key = $ties->{$self}->{key};
	return $hr->{$key};
    };

    *Class::Root::tiescalar::STORE = sub {
	my $self = shift;

	my $val = shift;

	my $hr = $ties->{$self}->{hr};
	my $key = $ties->{$self}->{key};
	my $class = $ties->{$self}->{class};
	my $name = $ties->{$self}->{subname};

	my $chk_sub = sub {
	    my $sub = shift;

	    local $_ = $val;
	    my $err = &$sub;
	    croak "check_value error for attr ", $name, " : $err" if $err;
	};

	my $rec_check;
	$rec_check = sub {
	    my $class = shift;
	    my $sub = $schema->{$class}->{SUBS}->{$name}->{CHECK_VALUE};
	    &$chk_sub($sub) if defined $sub;

	    my @class_isa;
	    { no strict 'refs';
		@class_isa = @{$class."::ISA"};
	    }

	    foreach my $parent ( @class_isa ) {
		$rec_check->($parent);
	    }
	};

	$rec_check->($class);

	$hr->{$key} = $val;
    };
}

my $accessors = {};

sub create_accessor {

    my %args = (
	@_,
    );

    my $name = $args{NAME};
    my $key = $args{KEY};
    my $flags = $args{FLAGS};

    my $cf = $flags & CF;
    my $ro = $flags & RO;
    my $priv = $flags & PRIV;


    my $akey = "$name/$key/$cf/$ro";
    my $sub = $accessors->{$akey};
    my $tied_sub;

    if ( $ro and !$priv ) {

	$sub or $sub = sub () {
	    my $self = shift || $_;
	    my $class = ref($self) || $self;

	    if ( @_ ) {
		my $err = $cf ?
		    "class \"$class\": couldn't set read only class attribute \"$name\"\n"
		  :
		    "instance of \"$class\": couldn't set read only attribute \"$name\"\n"
		;
		croak $err if @_;
	    }

	    my $data = $cf ? $class_data->{$class} : $self;

	    return $data->{$key};
	}

    } else {

	$sub or $sub = sub () : lvalue {

	    my $self = shift || $_;
	    my $class = ref($self) || $self;

	    if ( ::RT_CHECKS ) {
	        if ( $schema->{$class}->{SUBS}->{$name}->{TIED} ) {
		    unshift @_, $self;
		    goto $subs->{$sub}->{TIED_SUB};
		}
	    };

	    my $data = $cf ? $class_data->{$class} : $self;

	    $data->{$key} = shift if @_;

	    $data->{$key};
	};

    	if ( ::RT_CHECKS ) {
	    my $tref = tie my $tie, "Class::Root::tiescalar";

	    $ties->{$tref} = {
		key => $key,
    		subname => $name,
    	    };

	    $tied_sub = sub () : lvalue {
		my $self = shift || $_;
		my $class = ref($self) || $self;

		$ties->{$tref}->{class} = $class;
		$ties->{$tref}->{hr} = $cf ? $class_data->{$class} : $self;

		if ( @_ ) {
		    $tie = shift
		}

		$tie;
    	    };
	}
    }

    $accessors->{$akey} = $sub;
    return( $sub, $tied_sub );
}

declare new => class_method {
    my $proto = shift;
    my $class = ref($proto) || $proto;

    my $self = {};
    $self->{$attr_init_done_key} = {};
    $self->{$base_init_done_key} = {};

    bless($self, $class);

    if ( ::RT_CHECKS ) {

	my $key = 0;
	foreach ( @_ ) {
	    $key ^= 1;
	    if ( $key and /^_/ ) {
		croak "constructor new: couldn't set private attribute \"$_\"\n";
	    }
	}
    }

    $self->init( @_ );

    return $self;
};

my $root_init = sub {
    my $self = shift;
    my $class = ref($self);

    my %args = ( @_ );

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

declare init => method { goto $root_init };

declare base_init => method {
    my $self = shift;

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

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

    $self->{$base_init_done_key}->{$caller} = 1;

    my %attr_values = %{ $schema->{$caller}->{INSTANCE_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 $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 = "";
	my $methods = "";

	foreach my $m ( sort keys %$csubs ) {
	    my $mhr = $csubs->{$m};

	    my $flags = $mhr->{FLAGS};
	    my $parent = $mhr->{PARENT};
	    my $priv = $flags & PRIV;
	    my $prot = $flags & PROT;

	    next if ( $priv and !$prot and $parent ne $class );

	    my $mflags = "";
	    if ( $priv and !$prot ) {
		$mflags = "priv";
		my $prefix = prefix($class);
		$m =~ s/^$prefix/_/;
	    }

	    if ( $prot ) {
		$mflags = "prot";
		my $prefix = prefix($class);
		next unless ( $m =~ /^$prefix/ );
		$m =~ s/^$prefix/_/;
	    }

	    if ( $flags & VIRT ) {
		$mflags = "virt";
	    }

	    if ( $flags & RO and !$priv ) {
		$mflags = "ro";
	    }

	    my $r;
	    $r = \$attributes if $flags & AF;
	    $r = \$class_attributes if ( $flags & CF and $flags & AF);
	    $r = \$methods if $flags & MF;
	    $r = \$class_methods if ( $flags & CF and $flags & MF);

	    $$r .= sprintf "%4s%-20s%-10s%s\n", "", $m, $mflags, $parent;

	}

	$str .= "  class attributes:\n";
	$str .= $class_attributes;

	$str .= "  attributes:\n";
	$str .= $attributes;

	$str .= "  class methods:\n";
	$str .= $class_methods;

	$str .= "  methods:\n";
	$str .= $methods;

	return $str;
    };

    my $dump = sub {

	my $proto = shift;
	my $o_dump = ref($proto) ? 1 : 0;
	my $class = ref($proto) || $proto;

	my $str = $o_dump ? "instance \"$proto\"" : "class \"$class\"";
	$str .= " dump:\n";

	my $self = $o_dump ? $proto : $class;

	my $hr = {};

	my $cschema = $schema->{$class};

	my $csubs = $cschema->{SUBS};

	foreach my $m ( keys %$csubs ) {
	    my $mhr = $csubs->{$m};

	    my $flags = $mhr->{FLAGS};
	    my $parent = $mhr->{PARENT};
	    my $priv = $flags & PRIV;
	    my $prot = $flags & PROT;

	    next unless ( $flags & AF );

	    next if ( $o_dump and $flags & CF );
	    next if ( !$o_dump and !($flags & CF) );
	    next if ( $priv|$prot and $parent ne $class );

	    my $nm = $m;
	    if ( $priv|$prot ) {
		my $prefix = prefix($class);

		$nm =~ s/^$prefix/_/;
	    }

	    no strict 'refs';
	    $hr->{$nm} = $self->$m;

	}

	local $Data::Dumper::Indent = 1;
	local $Data::Dumper::Sortkeys = 1;
	my $dumper = Dumper( $hr );
	my @lines = split "\n", $dumper;
	my @less_lines = @lines[1..$#lines-1];

	$str .= join "\n", @less_lines;
	$str .= "\n" if scalar(@less_lines);

	return $str;
    };

    declare instance_dump => method {
	my $self = shift;
	my $class = ref($self);

	return $dump->($self);
    };

    declare class_dump => class_method {
	my $proto = shift;
	my $class = ref($proto) || $proto;

	return $dump->($class);
    };

}

1; # End of Class::Root

__END__