};
_subclass_error() if @$isa;
tie @$isa, 'Class::Struct::Tie_ISA';
# Create constructor.
croak "function 'new' already defined in package $class"
if do { no strict 'refs'; defined &{$class . "::new"} };
my @methods = ();
my %refs = ();
my %arrays = ();
my %hashes = ();
my %classes = ();
my $got_class = 0;
my $out = '';
$out = "{\n package $class;\n use Carp;\n sub new {\n";
$out .= " my (\$class, \%init) = \@_;\n";
$out .= " \$class = __PACKAGE__ unless \@_;\n";
my $cnt = 0;
my $idx = 0;
my( $cmt, $name, $type, $elem );
if( $base_type eq 'HASH' ){
$out .= " my(\$r) = {};\n";
$cmt = '';
}
elsif( $base_type eq 'ARRAY' ){
$out .= " my(\$r) = [];\n";
}
while( $idx < @decls ){
$name = $decls[$idx];
$type = $decls[$idx+1];
push( @methods, $name );
if( $base_type eq 'HASH' ){
$elem = "{'${class}::$name'}";
}
elsif( $base_type eq 'ARRAY' ){
$elem = "[$cnt]";
++$cnt;
$cmt = " # $name";
}
if( $type =~ /^\*(.)/ ){
$refs{$name}++;
$type = $1;
}
my $init = "defined(\$init{'$name'}) ? \$init{'$name'} :";
if( $type eq '@' ){
$out .= " croak 'Initializer for $name must be array reference'\n";
$out .= " if defined(\$init{'$name'}) && ref(\$init{'$name'}) ne 'ARRAY';\n";
$out .= " \$r->$elem = $init [];$cmt\n";
$arrays{$name}++;
}
elsif( $type eq '%' ){
$out .= " croak 'Initializer for $name must be hash reference'\n";
$out .= " if defined(\$init{'$name'}) && ref(\$init{'$name'}) ne 'HASH';\n";
$out .= " \$r->$elem = $init {};$cmt\n";
$hashes{$name}++;
}
elsif ( $type eq '$') {
$out .= " \$r->$elem = $init undef;$cmt\n";
}
elsif( $type =~ /^\w+(?:::\w+)*$/ ){
$out .= " if (defined(\$init{'$name'})) {\n";
$out .= " if (ref \$init{'$name'} eq 'HASH')\n";
$out .= " { \$r->$elem = $type->new(\%{\$init{'$name'}}) } $cmt\n";
$out .= " elsif (UNIVERSAL::isa(\$init{'$name'}, '$type'))\n";
$out .= " { \$r->$elem = \$init{'$name'} } $cmt\n";
$out .= " else { croak 'Initializer for $name must be hash or $type reference' }\n";
$out .= " }\n";
$classes{$name} = $type;
$got_class = 1;
}
else{
croak "'$type' is not a valid struct element type";
}
$idx += 2;
}
$out .= " bless \$r, \$class;\n }\n";
# Create accessor methods.
my( $pre, $pst, $sel );
$cnt = 0;
foreach $name (@methods){
if ( do { no strict 'refs'; defined &{$class . "::$name"} } ) {
warnings::warnif("function '$name' already defined, overrides struct accessor method");
}
else {
$pre = $pst = $cmt = $sel = '';
if( defined $refs{$name} ){
$pre = "\\(";
$pst = ")";
$cmt = " # returns ref";
}
$out .= " sub $name {$cmt\n my \$r = shift;\n";
if( $base_type eq 'ARRAY' ){
$elem = "[$cnt]";
=2= |