# Structure definition
# $Id: Struct.pm,v 1.13 2000/04/23 21:33:47 earl Exp $

# Copyright (c) 2000 Earl A. Killian.  All Rights Reserved.
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License version 2 as
# published by the Free Software Foundation.
#
# This program is distributed in the hope that it will be useful, but
# WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
# General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; see the file COPYING.  If not, write to
# the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
# Boston, MA 02111-1307, USA.

# Usage
#   use Struct qw(A B C...);
# where A, B, C, etc. have one of the following forms:
#    $A
#	Define a scalar member named A with access methods get and set.
#    $A(M1:M2:...)
#	Define a scalar member named A with access methods M1, M2, etc.
#	The methods will be given default names, unless =NAME is specified.
#	Method specifiers (M1, etc.) are get, set, inc, and dec.
#    @A
#	Define an array member named A with access methods get and ref.
#    @A(M1:M2:...)
#	Define an array member named A with access methods M1, M2, etc.
#	The methods will be given default names, unless =NAME is specified.
#	Method specifiers (M1, etc.) are get, set, ref, setref, elt, setelt,
#	push, pop, shift, and unshift.
#    %A
#	Define a hash member named A with access method ref.
#    %A(M1:M2:...)
#	Define a hash member named A with access methods M1, M2, etc.
#	The methods will be given default names, unless =NAME is specified.
#	Method specifiers (M1, etc.) are get, ref, setref, elt, setelt,
#	values, and keys.
#    :extends(A)
#	Struct A is a base for this structure.  We inherit its members
#	and methods.  You can override its methods by defining them in this
#	package.
#    :name(A)
#	Name this structure A.  The default is the package of the caller.
#    :new(A:B:C:...)
#	Create a constructor named "new" that initializes members A, B, C, etc.
#	from the new argument list.
#    :_new(A:B:C:...)
#	You will provide your own "new"; this creates a "_new" as above.
#	that your "new" can call.  Allows you greater flexibility in
#	parsing the arguments to "new".
#    :init(A:B:...)
#	Call an initialization methods A, B, etc. from the generated
#	new/_new after the object is created.  Useful when new just
#	needs to do some extra things at the end.  Simpler than using :_new.
#    :isa
#	Generate an "isa" method that determines if the object has the
#	type of the method argument (a string).
#    :debug
#	Print out the generated code.

package Struct;

# pragmas
use strict;

# Perl library modules
use Text::Wrap;

use vars qw(%struct);

sub import {
  my $class = shift;
  # parse options of the form :FOO and :FOO(A:B:C:...)
  # special case :extends
  # make a hash from option name to argument list out of the parse
  my %opt = map(/^:(\w+)(?:\((.*)\))?$/
		? ($1, !defined($2)
		       ? []
		       : ($1 eq 'extends' || $1 eq 'name'
			  ? [$2]
			  : [split(/:/, $2)]))
		: (),
		@_);
  # determine structure name; defaults to caller's package
  my $struct = $opt{'name'};
  if (defined($struct)) {
    $struct = $struct->[0];
  } else {
    my ($pkg, $file, $line) = caller;
    $struct = $pkg;
  }
  # check for illegal option names
  my @badopt = grep(   $_ ne 'new'
		    && $_ ne '_new'
		    && $_ ne 'init'
		    && $_ ne 'extends'
		    && $_ ne 'name'
		    && $_ ne 'isa'
		    && $_ ne 'dump'
		    && $_ ne 'debug',
		    keys %opt);
  print STDERR ("$::myname: Warning: unknown options '@badopt' in Struct $struct.\n")
    if @badopt != 0;
  # check if structure is being redefined
  die ("$::myname: Warning: redefining Struct $struct.\n")
    if defined($struct{$struct});
  # begin code generation
  my $code = 'package '.$struct.";\n";
  my @init = ();		# list of slot initialization expressions
  # handle :extends(BASE)

  my @newargs = @{ $opt{'new'} || $opt{'_new'} || [] };
  my $newargs = join(':', @newargs);
  my $extends = $opt{'extends'};
  if (defined($extends)) {
    die ("$::myname: Fatal: Struct $struct :extends(".join(':',@$extends).").\n")
      if @$extends != 1;
    my $basename = $extends->[0];
    my $base = $struct{$basename};
    if (!defined($base)) {
      require $basename;
      $base = $struct{$basename};
      die ("$::myname: Fatal: Struct $struct base $basename not defined.\n")
        unless $base;
    }
    # get the argument number and slot initialization expressions from
    # our base class
    my $basenewargs;
    (undef, $basenewargs, @init) = @$base;
    # add our base class to perl's ISA array for this package so that
    # it will search for methods in our base class if it doesn't find
    # them in this class
    $code .= "\@".$struct."::ISA = qw($basename);\n";
    die("$::myname: Error: base struct $basename and struct $struct new arguments inconsistent ($basenewargs vs. $newargs).\n")
      unless substr($newargs,0,length($basenewargs)) eq $basenewargs;
  }
  # create hash mapping :new/:_new arguments to an expression to
  # reference the specified slot in @_
  my $initarg = 1;		# next argument number (0 is class)
  my %init = map(($_, "\$_[".$initarg++."]"), @newargs);
#  print STDERR ($struct, ":\n", map("  $_ => $init{$_}\n", keys(%init)), "\n");
  my @dump;
  # now process member specifications
  my $arg;
  foreach $arg (@_) {
    my $type;			# the first character of the specifier
    my $name;			# the name of the member
    my $ops;			# the access methods to generate
    my $slot = @init;		# the slot number for storing this member
    if (($type, $name, $ops) = $arg =~ /^([\$\@\%\:])(\w+)(?:\((.*)\))?$/) {
      if ($type eq "\$") {	# scalar member
	my $op;
	foreach $op (defined($ops) ? split(/:/, $ops) : qw(get set)) {
	  my $methodname;
	  if ($op =~ /^(\w+)=(\w+)$/) {
	    $op = $1;
	    $methodname = $2;
	  } else {
	    $methodname = $op eq 'get' ? $name : $op.'_'.$name;
	  }
	  if ($op eq 'get') {
	    $code .= 'sub '.$methodname." {\n";
	    $code .= "  \$_[0]->[$slot];\n";
	    $code .= "}\n";
	  } elsif ($op eq 'set') {
	    $code .= 'sub '.$methodname." {\n";
	    $code .= "  \$_[0]->[$slot] = \$_[1];\n";
	    $code .= "}\n";
	  } elsif ($op eq 'inc') {
	    $code .= 'sub '.$methodname." {\n";
	    $code .= "  \$_[0]->[$slot] += \$_[1];\n";
	    $code .= "}\n";
	  } elsif ($op eq 'dec') {
	    $code .= 'sub '.$methodname." {\n";
	    $code .= "  \$_[0]->[$slot] -= \$_[1];\n";
	    $code .= "}\n";
	  } elsif ($op eq 'append') {
	    $code .= 'sub '.$methodname." {\n";
	    $code .= "  \$_[0]->[$slot] .= \$_[1];\n";
	    $code .= "}\n";
	  } elsif ($op eq 'min') {
	    $code .= 'sub '.$methodname." {\n";
	    $code .= "  \$_[0]->[$slot] = \$_[1] if \$_[1] < \$_[0]->[$slot];\n";
	    $code .= "}\n";
	  } elsif ($op eq 'max') {
	    $code .= 'sub '.$methodname." {\n";
	    $code .= "  \$_[0]->[$slot] = \$_[1] if \$_[1] > \$_[0]->[$slot];\n";
	    $code .= "}\n";
	  } else {
	    die ("$::myname: Fatal: '$op' not supported for '$type$name'.\n");
	  }
	}
	push (@init, $init{$name} || 'undef');
	push (@dump, $name);
      } elsif ($type eq "\@") {	# array member
	my $op;
	foreach $op (defined($ops) ? split(/:/, $ops) : qw(get ref)) {
	  my $methodname;
	  if ($op =~ /^(\w+)=(\w+)$/) {
	    $op = $1;
	    $methodname = $2;
	  } else {
	    $methodname = $op eq 'get' ? $name : $op.'_'.$name;
	  }
	  if ($op eq 'get') {
	    $code .= 'sub '.$methodname." {\n";
	    $code .= "  \@{\$_[0]->[$slot]};\n";
	    $code .= "}\n";
	  } elsif ($op eq 'ref') {
	    $code .= 'sub '.$methodname." {\n";
	    $code .= "  \$_[0]->[$slot];\n";
	    $code .= "}\n";
	  } elsif ($op eq 'setref') {
	    $code .= 'sub '.$methodname." {\n";
	    $code .= "  \$_[0]->[$slot] = \$_[1];\n";
	    $code .= "}\n";
	  } elsif ($op eq 'elt') {
	    $code .= 'sub '.$methodname." {\n";
	    $code .= "  \$_[0]->[$slot]->[\$_[1]];\n";
	    $code .= "}\n";
	  } elsif ($op eq 'set') {
	    $code .= 'sub '.$methodname." {\n";
	    $code .= "  my \$self = shift;\n";
	    $code .= "  \$self->[$slot] = [\@_];\n";
	    $code .= "}\n";
	  } elsif ($op eq 'setelt') {
	    $code .= 'sub '.$methodname." {\n";
	    $code .= "  \$_[0]->[$slot]->[\$_[1]] = \$_[2];\n";
	    $code .= "}\n";
	  } elsif ($op eq 'push') {
	    $code .= 'sub '.$methodname." {\n";
	    $code .= "  my \$self = shift;\n";
	    $code .= "  push(\@{\$self->[$slot]}, \@_);\n";
	    $code .= "}\n";
	  } elsif ($op eq 'pop') {
	    $code .= 'sub '.$methodname." {\n";
	    $code .= "  pop(\@{\$_[0]->[$slot]});\n";
	    $code .= "}\n";
	  } elsif ($op eq 'shift') {
	    $code .= 'sub '.$methodname." {\n";
	    $code .= "  shift(\@{\$_[0]->[$slot]});\n";
	    $code .= "}\n";
	  } elsif ($op eq 'unshift') {
	    $code .= 'sub '.$methodname." {\n";
	    $code .= "  my \$self = shift;\n";
	    $code .= "  unshift(\@{\$self->[$slot]}, \@_);\n";
	    $code .= "}\n";
	  } else {
	    die ("$::myname: Fatal: '$op' not supported for '$type$name'.\n");
	  }
	}
	push (@init, $init{$name} || '[]');
	push (@dump, $name);
      } elsif ($type eq "\%") {	# hash member
	my $op;
	foreach $op (defined($ops) ? split(/:/, $ops) : qw(ref)) {
	  my $methodname;
	  if ($op =~ /^(\w+)=(\w+)$/) {
	    $op = $1;
	    $methodname = $2;
	  } else {
	    $methodname = $op eq 'get' ? $name : $op.'_'.$name;
	  }
	  if ($op eq 'get') {
	    $code .= 'sub '.$methodname." {\n";
	    $code .= "  \%{\$_[0]->[$slot]};\n";
	    $code .= "}\n";
	  } elsif ($op eq 'ref') {
	    $code .= 'sub '.$methodname." {\n";
	    $code .= "  \$_[0]->[$slot];\n";
	    $code .= "}\n";
	  } elsif ($op eq 'setref') {
	    $code .= 'sub '.$methodname." {\n";
	    $code .= "  \$_[0]->[$slot] = \$_[1];\n";
	    $code .= "}\n";
	  } elsif ($op eq 'elt') {
	    $code .= 'sub '.$methodname." {\n";
	    $code .= "  \$_[0]->[$slot]->{\$_[1]};\n";
	    $code .= "}\n";
	  } elsif ($op eq 'setelt') {
	    $code .= 'sub '.$methodname." {\n";
	    $code .= "  \$_[0]->[$slot]->{\$_[1]} = \$_[2];\n";
	    $code .= "}\n";
	  } elsif ($op eq 'values') {
	    $code .= 'sub '.$methodname." {\n";
	    $code .= "  values \%{\$_[0]->[$slot]};\n";
	    $code .= "}\n";
	  } elsif ($op eq 'keys') {
	    $code .= 'sub '.$methodname." {\n";
	    $code .= "  keys \%{\$_[0]->[$slot]};\n";
	    $code .= "}\n";
	  } else {
	    die ("$::myname: Fatal: '$op' not supported for '$type$name'.\n");
	  }
	}
	push (@init, $init{$name} || '{}');
	push (@dump, $name);
      } elsif ($type eq "\:") {
	# nothing to do this pass
      } else {
	die ("$::myname: Internal: Struct $struct '$arg'.\n");
      }
    } else {
      die ("$::myname: '$arg' not understood in Struct $name.\n");
    }
  } # foreach arg
  # handle :isa (generate an is-a test)
  my $isa = $opt{'isa'};
  if (defined($isa)) {
    $code .= "sub ".(@$isa == 0 ? 'isa' : $isa->[0])." {\n";
    my @names = ($struct);
    for (my $p = $extends && $extends->[0];
	 defined($p);
	 $p = $struct{$p}->[0]) {
      push (@names, $p);
    }
    $code .= "  ".join(' || ', map('$_[1] eq "'.$_.'"', @names)).";\n";
    $code .= "}\n";
  }
  my $dump = $opt{'dump'};
  if (defined($dump)) {
    $code .= "sub ".(@$dump == 0 ? 'dump' : $dump->[0])." {\n";
    foreach my $i (0 .. $#dump) {
      $code .= "  Struct::odump ('".$dump[$i]."', \$_[0]->[$i], \$_[1]);\n";
    }
    $code .= "}\n";
  }
  # generate new or _new
  $code .= "sub ".(defined($opt{'new'}) ? 'new' : '_new')." {\n";
  my $initmethods = $opt{'init'};
  if (defined($initmethods)) {
    $code .= "  my \$self = bless [".join(', ', @init)."], \$_[0];\n";
    foreach $_ (@$initmethods) {
      $code .= "  \$self->".$_.";\n";
    }
    $code .= "  \$self;\n";
  } else {
    $code .= "  bless [".join(', ', @init)."], \$_[0];\n";
  }
  $code .= "}\n";
  # evaluate the code
  print STDERR ($code)
    if $opt{'debug'};
  eval ($code);
  die ("$::myname: Fatal: $@\n")
    if $@;
  # add this structure to our database (in case it is used as a base)
  $struct{$struct} = [$extends && $extends->[0], $newargs, @init];
}

sub odump {
  my ($name, $object, $indent) = @_;
  my $is;
  if (defined($indent)) {
    $is = indentstring($indent);
  } else {
    $indent = 0;
    $is = '';
  }
  my $ref = ref($object);
  if ($ref eq '') {
    print STDERR ($is, $name, ':');
    if ($object =~ /^\-?\d+(?:\.\d+(?:[eE][-+]?\d+)?)?$/) {
      printf STDERR (" %s\n", $object);
    } else {
      printf STDERR (" '%s'\n", $object);
    }
  } elsif ($ref eq 'ARRAY') {
    print STDERR (wrap($is, indentstring($indent + 2),
		       $name.': ['.join(', ', @$object).']'), "\n");
  } elsif ($ref eq 'HASH') {
    print STDERR (wrap($is, indentstring($indent + 2),
		       $name.': {'.join(', ', map($_->[0].' => '.$_->[1],
						  each %$object)).'}'), "\n");
  } else {
    printf STDERR (" %s\n", $object);
  }
}

sub indentstring {
  my ($indent) = @_;
  ("\t" x ($indent >> 3)).(' ' x ($indent & 0x7));
}


1;


# Local Variables:
# mode:perl
# perl-indent-level:2
# cperl-indent-level:2
# End: