#  Copyright (c) 1997-2004
#  Ewgenij Gawrilow, Michael Joswig (Technische Universitaet Berlin, Germany)
#  http://www.math.tu-berlin.de/polymake,  mailto:polymake@math.tu-berlin.de
#
#  This program is free software; you can redistribute it and/or modify it
#  under the terms of the GNU General Public License as published by the
#  Free Software Foundation; either version 2, or (at your option) any
#  later version: http://www.gnu.org/licenses/gpl.txt.
#
#  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.
#-----------------------------------------------------------------------------
# $Project: polymake $$Id: Struct.pm,v 1.12 2004/11/01 21:37:11 gawrilow Exp $

use integer;
use strict;
use Poly;
use namespaces 'Poly';

$Carp::Internal{Struct}=1;

package Struct;
use Poly::Ext;

sub import {
   shift;			# drop the own package name
   my $cnt=0;
   my ($pkg)=caller(0);
   my $constructor="";
   my ($signature, $own_signature, $check_arg, $min_arg, $max_arg, $keyed_args, $super, $redefine, $can_die);
   my $with_namespaces=namespaces::uses($pkg);
   my $prologue="use strict;\n" . (!$with_namespaces && "no namespaces;\n") . "package $pkg";
   while (ref($_[0])) {
      if ($_[0]->[0] eq '@ISA') {
	 my $isa=shift;
	 shift @$isa;
	 {  no strict 'refs';
	    @{"$pkg\::ISA"}=@$isa;
	 }

	 foreach my $s (@$isa) {
	    if (defined (my $super_constructor=UNIVERSAL::can($s, ".constructor"))) {
	       $super=$s;
	       ($cnt, $constructor)=$super_constructor->();
	       if (!$own_signature && defined (my $super_signature=$super->can(".signature"))) {
		  ($signature, $min_arg, $max_arg)=$super_signature->();
	       }
	       $keyed_args= substr($signature,-1) eq '%';
	       $redefine=1;
	       if ($with_namespaces && namespaces::uses($super)) {
		  namespaces::using($pkg, $super);
	       }
	       last;
	    }
	 }

      } elsif ($_[0]->[0] eq 'new') {
	 $signature=(shift)->[1];
	 if ($signature !~ m'^ (\$*) (?: ;(\$+) | ([@%]) )? $ 'x) {
	    croak( "invalid constructor signature: '$signature'" );
	 }
	 $own_signature=$signature;
	 $min_arg=length($1);
	 $check_arg= "\@_ <= $min_arg";
	 $max_arg=$min_arg+length($2)+1;
	 if (defined $2) {
	    $check_arg .= "or \@_ > $max_arg";
	 } else {
	    $keyed_args= $3 eq '%';
	 }

      } else {
	 last;
      }
   }

   foreach my $field (@_) {
      my ($code, $name)=split //, (ref($field) ? $field->[0] : (undef($redefine), $field)), 2;
      croak( "unknown field type '$code'$name" ) if $code !~ m'[$@%&]';
      my $accessor=$pkg->can($name);
      if (defined($redefine)) {
	 if (!defined($accessor) || ($redefine=get_field_index($accessor))<0) {
	    undef $redefine;	# new field or an occasionaly overwritten non-field method
	 }
      } elsif (get_field_index($accessor)>=0) {
	 croak( "multiple definition of field $name" );
      }
      my @aliases=split /\s*\|\s*/, $name;
      my ($kname, $get_kname, $get_kname_trailer);
      if ($keyed_args) {
	 if (@aliases>1) {
	    $kname='$kname';
	    $get_kname=<<"_#_#_#_";
do {
   my \$kname;
   foreach (qw(@aliases)) {
      if (exists \$kw{\$_}) {
	 \$kname=\$_;
	 last
      }
   }
   \$kname
_#_#_#_
            $get_kname_trailer=<<"_#_#_#_";
}
_#_#_#_
	 } else {
	    $kname="'$name'";
	    $get_kname="exists \$kw{$name}";
         }
      }
      my $key_in_expr;
      my $deflt=$code eq '@' ? "[]" :
                $code eq '%' ? "{}" :
	        $code eq '&' ? "undef" :
                               "''";
      my $init=
         ref($field)
	 ? $field->[1] ne '##'
	 ? do {
	      my $expr=$field->[1];
	      if ($expr =~ s{(?: (?<=^) | (?<=\s)) \#(?:([\d+]) | (%)) (?= $ | \s)}
	                    { $2 ? $keyed_args ? ($key_in_expr=1, "$kname, \$kval") : croak("constructor has no keyword arguments")
			         : $1<$max_arg ? "\$_[$1]" : croak("constructor argument #$1 out of range") }egx) {
	         if ($key_in_expr) {
		    if ($#$field>=2) {
		       $expr="do { my \$kval; $get_kname ? (\$kval=delete \$kw{$kname}) : (\$kval=$field->[2]); $expr; $get_kname_trailer }";
		    } else {
		       $expr="$get_kname ? do { my \$kval=delete \$kw{$kname}; $expr } : $deflt $get_kname_trailer";
		    }
		    $can_die=1;
		 }
		 undef $get_kname;
	      }
	      if ($code eq '@') {
		 $expr =~ s/^ \s* \( (.*) \) \s* $/[$1]/x
		    or
		 $expr =~ s/^ \s* \@ .*/[$&]/x;
	      } elsif ($code eq '%') {
		 $expr =~ s/^ \s* \( (.*) \) \s* $/{$1}/x
		    or
		 $expr =~ s/^ \s* % .*/{$&}/x;
	      }
	      $expr
	   }
	 : do { undef $get_kname;  $deflt }
	 : $deflt;
      if ($get_kname) {
	 $init="$get_kname ? delete \$kw{$kname} : $init $get_kname_trailer";
      }
      my $set_filter=$key_in_expr && do {
	 my $expr=$field->[1];
	 $expr =~ s{(?: (?<=^) | (?<=\s)) \#% (?= $ | \s)}{\@_}x;
	 eval "$prologue; sub { $expr }"
	 or croak( "syntax error compiling set-accessor: $@" );
      };
      if (defined($redefine)) {
	 if ($redefine) {
	    my $prev=$redefine-1;
	    $constructor =~ /\#\#\#<$prev>\n/s;
	    pos($constructor)=$+[0];
	 }
	 $constructor =~ s/\G .*? (?= ,\s*\#\#\#<$redefine>\n)/$init/xs;
         if ($set_filter) {
            $accessor=create_accessor($redefine);
            foreach my $field_name (@aliases) {
               define_function($pkg, $field_name, $accessor);
               no strict 'refs';
               $ {"$pkg\::$field_name"}=$set_filter;
            }
         }

      } else {
	 $constructor .= "$init, ###<$cnt>\n";
	 $accessor=create_accessor($cnt);
         foreach my $field_name (@aliases) {
            define_function($pkg, $field_name, $accessor);
            if ($set_filter) {
               no strict 'refs';
               $ {"$pkg\::$field_name"}=$set_filter;
            }
         }
	 ++$cnt;
      }
   }

   if (@_ || $own_signature) {
      my $new_text= <<"_#_0_#_";
$prologue;
sub {
_#_0_#_
      if ($can_die) {
	 $new_text .= <<'_#_2_#_';
   local $Carp::CarpLevel=$Carp::CarpLevel+1;
_#_2_#_
      }
      if ($keyed_args) {
	 $new_text .= <<"_#_3_#_";
   my %kw;
   for (my \$i=$min_arg+1; \$i<=\$#_; ) {
      if (Poly::is_hash(\$_[\$i])) {
	 push %kw, %{\$_[\$i++]};
      } else {
	 \$kw{\$_[\$i]}=\$_[\$i+1];
	 \$i+=2;
      }
   }
_#_3_#_
      }
      if ($check_arg) {
	 $new_text .= <<"_#_4_#_";
   if ($check_arg) {
      Poly::croak( "usage: new \$_[0] (" . '$signature' . ")" );
   }
_#_4_#_
      }
      if ($keyed_args) {
	 $new_text .= <<"_#_5_#_";
   my \$self=bless [
$constructor
   ], shift;
   if (keys %kw) {
      Poly::croak( ref(\$self), "::new - unknown keywords: ", join(", ", keys %kw) );
   }
   \$self
_#_5_#_
      } else {
	 $new_text .= <<"_#_6_#_";
   bless [
$constructor
   ], shift;
_#_6_#_
      }
      $new_text .= <<"_#_9_#_";
}
_#_9_#_
      my $_new=eval $new_text;
      if ($@) {
	 my @new_lines=(undef, split /(?:\#\#\#<\d+>)?\n/, $new_text);	# leading undef makes the line numbers = array index
	 $@ =~ s/at \(eval \d+\) line (\d+)/near line $1: '$new_lines[$1]'/g;
	 croak( "syntax error building $pkg constructor: $@" );
      }
      define_function($pkg, "__new", $_new);

   } elsif (!$super) {
      croak( "no own fields and no Struct-based super class specified" );
   }

   define_function($pkg, ".constructor", sub { ($cnt, $constructor) });
   define_function($pkg, "sizeof", sub { $cnt });
   if ($own_signature) {
      define_function($pkg, ".signature", sub { ($signature, $min_arg, $max_arg) });
   }
   no strict 'refs';
   *{"$pkg\::_new"}=\&_new;
   if (!$super || $super->can("new")==$super->can("_new")) {
      *{"$pkg\::new"}=\&{"$pkg\::_new"};
   }
}

sub _new { &{$_[0]->can("__new")} }

1;
