#  Copyright (c) 1997-2011
#  Ewgenij Gawrilow, Michael Joswig (Technische Universitaet Darmstadt, Germany)
#  http://www.polymake.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 10167 2011-04-29 07:15:57Z gawrilow $

use strict;
use namespaces;

package Polymake::Struct;
use Polymake::Ext;
use Carp;

$Carp::Internal{'Polymake::Struct'}=1;

require "Polymake/regex.pl";

sub find_expr {
   my $index=shift;
   pos($_)=0;
   while (m{\G .*? (\#\#\#<(\d+)>\n)}xsg) {
      return @- if $2==$index;
   }
   ()
}

sub replace_expr {
   local $_=$_[0];
   if (my ($expr_start, $expr_end)=find_expr($_[1])) {
      substr($_[0],$expr_start,$expr_end-$expr_start)="$_[2] ";
   } else {
      $_[0].="$_[2] ###<$_[1]>\n";
   }
}

sub delete_expr {
   local $_=$_[0];
   if (my ($expr_start, $expr_end)=find_expr($_[1])) {
      substr($_[0],$expr_start,$expr_end-$expr_start)="";
      substr($_[0],$expr_start) =~ s/.*?\n//m;
   }
}

sub import {
   shift;                       # drop the own package name
   my $cnt=0;
   my ($pkg, $file, $line)=caller(0);
   if (my $def=UNIVERSAL::can($pkg,".defined")) {
      my $other_pkg=method_owner($def);
      if ($pkg eq $other_pkg) {
         croak "package $pkg already declared as Struct at ".&$def.", conflicting declaration";
      } else {
         croak "inheritance from package $other_pkg declared as Struct at ".&$def.
               "\n seems to be established via plain \@ISA assignment and conflicts with Struct declaration";
      }
   }
   my $symtab=get_pkg($pkg);
   my $constructor="";
   my $constructor_deferred="";
   my ($signature, $own_signature, $check_arg, $min_arg, $max_arg, $keyed_args, %keys, $keys_changed,
       $trailing_list, $trailing_arg, $super, $super_symtab, $super_trailing_arg, $redefine, $merger, $merger_changed);
   my $with_namespaces=namespaces::caller_scope();
   my $prologue="use strict; $with_namespaces\npackage $pkg";
   while (ref($_[0])) {
      if ($_[0]->[0] eq '@ISA') {
         my $isa=shift;
         shift @$isa;
         if (substr($with_namespaces,0,3) eq "use") {
            $_=namespaces::lookup_class_in_caller_scope($symtab,$_) for @$isa;
         }
         { no strict 'refs';
           @{"$pkg\::ISA"}=@$isa; }

         foreach my $s (@$isa) {
            if (defined (my $super_constructor=UNIVERSAL::can($s, ".constructor"))) {
               $super=$s;
               ($cnt, $constructor, $constructor_deferred, $merger)=$super_constructor->();
               if (!$own_signature && defined (my $super_signature=UNIVERSAL::can($super, ".signature"))) {
                  ($signature, $min_arg, $max_arg, $trailing_arg)=$super_signature->();
                  $trailing_list=defined($trailing_arg);
                  $super_trailing_arg=$trailing_arg;
               }
               if (my $k=UNIVERSAL::can($s, ".keys")) {
                  $keyed_args=1;
                  %keys=%{$k->()};
               }
               $merger &&= [ @$merger ];
               $redefine=1;
               namespaces::using($pkg, $super) if $with_namespaces !~ /^no/;
               $super_symtab=get_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>0 && "\@_ <= $min_arg";
         $max_arg=$min_arg+length($2)+1;
         $trailing_list=defined($4);
         if (defined $2) {
            if (!$4) {
               $check_arg .= ($min_arg>0 && " or ") ."\@_ > $max_arg";
            }
         } elsif ($3) {
            $keyed_args=1;
         }

      } elsif ($_[0]->[0] eq 'aliases') {
         $redefine or croak "a Struct-based super class is required to define aliases";
         my $list=shift;
         for (my ($i, $n)=(1, $#$list); $i<$n; $i+=2) {
            my @aliases=split /\s*\|\s*/, $list->[$i];
            my $ref=$list->[$i+1];
            my $accessor=UNIVERSAL::can($super,$ref) or croak "alias declaration refers to an unknown field $ref";
            my $index=get_field_index($accessor);
            $index>=0 or croak "alias declaration refers to a method $ref instead of a field";
            define_function($symtab, $_, $accessor) for @aliases;
            if (defined (my $k=$keys{$ref})) {
               $keys{$_}=$k for @aliases;
            }
            $keys_changed=1;
         }

      } else {
         last;
      }
   }

   foreach my $field (@_) {
      my ($code, $name)=split //, (ref($field) ? $field->[0] : (undef($redefine), $field)), 2;
      if ($code !~ m'[$=@%&]') {
         croak "unknown field type '$code'$name";
      }
      my @aliases=split /\s*\|\s*/, $name;
      my $accessor=UNIVERSAL::can($pkg,$aliases[0]);
      my $index;
      if (defined($redefine)) {
         if (!defined($accessor) || ($redefine=get_field_index($accessor))<0) {
            undef $redefine;    # new field or an occasionaly overwritten non-field method
            $index=$cnt;
         } else {
            $index=$redefine;
         }
      } elsif (get_field_index($accessor)>=0 && method_owner($accessor) eq $pkg) {
         croak "multiple definition of field $aliases[0]";
      } else {
         $index=$cnt;
      }
      my ($key_in_expr, $set_filter, $set_filter_is_method, $init_deferred, $init_deferred_expr, $merge_expr);
      my $deflt=$code eq '@' ? "[]" :
                $code eq '%' ? "{}" :
                $code eq '$' ? "''" :
                               "undef";
      my $add_to_keys=0;
      my $init=
         ref($field)
         ? $field->[1] eq '@'
           ? do {
                if ($trailing_list) {
                   croak "unexpected options for the trailer-initialized field $name" if $#$field>1;
                   $add_to_keys=-1;
                   $trailing_arg=$index;
                   $code eq '%'
                   ? $keyed_args
                     ? "Polymake::Struct::merge_options({}, \@trailing_list)"
                     : "Polymake::Struct::merge_options({}, splice \@_, $max_arg)"
                   : $keyed_args
                     ? "\\\@trailing_list"
                     : "[ splice \@_, $max_arg ]"
                } else {
                   croak "no trailing list declared in the signature"
                }
             } :
           $code eq '&' && $field->[1] =~ /^->\s*(\w+)(?:\s*\|\|\s*(.+))?$/
           ? do {
                croak "unexpected options for the method field $name" if $#$field>1;
                $add_to_keys=-1;
                if ((my $super_index=get_field_index(UNIVERSAL::can($pkg,"$1"))) >= 0) {
                   if ($2) {
                      $set_filter=eval "$prologue; $2";
                      croak "syntax error compiling method fallback for the field $name: $@" if $@;
                   }
                   unless (exists &{$symtab->{original_object}}) {
                      define_function($symtab, "original_object", \&original_object);
                   }
                   $super_index;
                } else {
                   croak "reference to an unknown field $1 in initializer of the field $name";
                }
             }
           : do {
                croak "odd options list for the field $name" if !($#$field%2);
                my $expr=$field->[1];
                if ($expr =~ s/^\s* weak\s*\( (.*) \)\s*$/$1/x) {
                   $init_deferred_expr="weak(\$this->[$index]);";
                }
                my %options=splice @$field, 2;
                $init_deferred=$set_filter_is_method= $expr =~ /(?<!\\)\$this\b/;
                if ($expr =~ s{(?: (?<=^) | (?<=[\s,(])) \#(?:([\d+]) | (%)) (?= $ | [\s,)])}
                              { $2 ? $keyed_args
                                     ? ($add_to_keys=1, '#%')
                                     : croak("constructor has no keyword arguments")
                                   : $1<$max_arg
                                     ? ($add_to_keys=-1, '$_['.($1-$init_deferred).']')
                                     : croak("constructor argument #$1 out of range") }egx) {
                   if ($add_to_keys>0) {
                      my $get_kname="\$kw[2*$index]";
                      $key_in_expr= $expr ne "#%";
                      if (defined (my $default_arg=delete $options{default})) {
                         $init_deferred ||= $default_arg =~ /(?<!\\)\$this\b/;
                         if ($key_in_expr) {
                            ($deflt=$expr) =~ s/\#%/'$aliases[0]', $default_arg/g;
                         } else {
                            $deflt=$default_arg;
                         }
                      }
                      if ($key_in_expr) {
                         if (defined ($merge_expr=delete $options{merge})) {
                            $merge_expr =~ s/\#%/\@_/ and
                            $merge_expr = "$prologue; sub { my \$this=shift; $merge_expr }";
                         }
                         $expr =~ s/\#%/$get_kname, \$kw[2*$index+1]/g;
                         $expr = "defined($get_kname) ? ($expr) : Polymake::Struct::mark_as_default($deflt)";
                      } else {
                         $expr = "$get_kname ? \$kw[2*$index+1] : Polymake::Struct::mark_as_default($deflt)";
                      }
                   }
                }
                if (keys %options) {
                   croak "unknown or unexpected option(s) ", join(", ", keys %options), " for the field $name";
                }

                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;
                } elsif ($code eq '=') {
                   if ($key_in_expr) {
                      croak "field $name: global variable reference can't be initialized with a keyword argument";
                   }
                   $expr =~ s/^ \s* ([\w:]+) \s* $/"$1"/x;
                   $init_deferred_expr="Polymake::Struct::make_alias(\$this, $index);";
                   $add_to_keys=-1;
                } elsif ($code eq '$' && $expr =~ /^\s*(?:new\s+)?$qual_id_re\s*<\s*$id_re/o) {
                   $expr="($expr)";
                }
                $expr
             }
         : $deflt;

      if ($init_deferred) {
         $init_deferred_expr="\$this->[$index]=$init;";
         $init="undef";
      }
      if ($add_to_keys>0) {
         $keys{$_}=$index for @aliases;
         $keys_changed=1;
      } elsif ($add_to_keys<0 && defined($redefine) && $keyed_args) {
         delete @keys{@aliases};
         $keys_changed=1;
      }
      $set_filter ||= $key_in_expr && do {
         my $expr=$field->[1];
         if ($expr =~ /^\s* \$this \s*->\s* ((?!\d)\w+) \(\s* \#% \s*\) \s*$/x) {
            $1
         } else {
            my $mys= ($set_filter_is_method &&= " : method") && 'my $this=shift; ';
            $expr =~ s{(?: (?<=^) | (?<=[\s,(])) \#% (?= $ | [\s,)])}{\@_}x;
            eval "$prologue; sub$set_filter_is_method { $mys$expr }"
            or croak "syntax error compiling access filter for the field $name: $@";
         }
      };
      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 (defined($init_deferred_expr)) {
            replace_expr($constructor_deferred, $redefine, $init_deferred_expr);
         } elsif ($constructor_deferred) {
            delete_expr($constructor_deferred, $redefine);
         }
         if ($set_filter || defined_scalar($super_symtab->{$aliases[0]})) {
            $accessor=create_accessor($redefine, $code eq '&' ? \&method_call : \&access_field);
            define_function($symtab, $_, $accessor) for @aliases;
            ${$symtab->{$aliases[0]}}=$set_filter;
         }

      } else {
         $constructor .= "$init, ###<$cnt>\n";
         if (defined($init_deferred_expr)) {
            $constructor_deferred .= "$init_deferred_expr ###<$cnt>\n";
         }
         $accessor=create_accessor($cnt, $code eq '&' ? \&method_call : \&access_field);
         define_function($symtab, $_, $accessor) for @aliases;
         if ($set_filter) {
            ${$symtab->{$aliases[0]}}=$set_filter;
         }
         ++$cnt;
      }

      if (defined($merge_expr)) {
         $merger ||= [ ];
         $merger->[$index]=eval $merge_expr;
         if ($@) {
            croak "syntax error compiling merger expression '$merge_expr' for the field $aliases[0]: $@";
         }
         $merger_changed=1;
      }
   }

   if (@_ || $own_signature) {
      if (defined($super_trailing_arg) and !$trailing_list || $trailing_arg!=$super_trailing_arg) {
         if ($super_trailing_arg) {
            my $prev=$super_trailing_arg-1;
            $constructor =~ /\#\#\#<$prev>\n/s;
            pos($constructor)=$+[0];
         } else {
            pos($constructor)=0;
         }
         $constructor =~ s/\G (Polymake::Struct::merge_options\()? .*? (?= ,\s*\#\#\#<$super_trailing_arg>\n)/ $1 ? "{ }" : "[ ]" /xse;
      }
      my ($proc_keys, $post_merge_proc);
      my $new_text= <<"_#_0_#_";
$prologue;
sub __new {
_#_0_#_
      if ($keyed_args) {
         $proc_keys=define_function($pkg, ".process_keywords",
            sub {
               my ($args, $kw, $post_merge, $trailing_list)=@_;
               $#$kw=$cnt-1;
               for (my $i=$max_arg; $i<=$#$args; ++$i) {
                  my $field=$args->[$i];
                  if (is_string($field) && defined (my $k=$keys{$field}) && $i<$#$args) {
                     $kw->[2*$k]=$field; $kw->[2*$k+1]=$args->[++$i];
                  } elsif (ref($field) eq "HASH") {
                     while (my ($kn, $kv)=each %{$field}) {
                        if (defined (my $k=$keys{$kn})) {
                           if (defined($post_merge) && defined($merger->[$k]) && defined($kw->[2*$k])) {
                              push @$post_merge, $k, $kn, $kv;
                           } else {
                              $kw->[2*$k]=$kn; $kw->[2*$k+1]=$kv;
                           }
                        } else {
                           local $Carp::CarpLevel=1;
                           my $accessor=UNIVERSAL::can($pkg,$kn);
                           if (defined($accessor) && get_field_index($accessor)>=0) {
                              croak "$pkg\::new - member $kn can't be initialized with a keyword argument";
                           } else {
                              croak "$pkg\::new - unknown keyword $kn";
                           }
                        }
                     }
                  } elsif (defined $trailing_list) {
                     @$trailing_list=splice @$args, $i;
                     last;
                  } else {
                     local $Carp::CarpLevel=1;
                     my $accessor;
                     croak( "$pkg\::new - ", 
                            $i==$#$args
                            ? "keyword $field without value" :
                            is_string($field)
                            ? ( defined($accessor=UNIVERSAL::can($pkg,$field)) && get_field_index($accessor)>=0
                                ? "member $field can't be initialized with a keyword argument"
                                : "unknown keyword $field" )
                            : "expected keyword or HASH, got ".(ref($field) || "'$field'") );
                  }
               }
            });
         my $post_merge_arg="";
         if (defined($merger)) {
            $new_text .= "   my \@post_merge;\n";
            $post_merge_arg=",\\\@post_merge";
            $post_merge_proc=define_function($pkg, ".post_merge",
               sub {
                  my $this=shift;
                  for (my $i=0; $i<$#_; $i+=3) {
                     my $k=$_[$i];
                     $this->[$k]=$merger->[$k]->($this,@_[$i+1,$i+2],$this->[$k]);
                  }
               });
         }
         if (defined $trailing_arg) {
            $post_merge_arg ||= ",undef";
            $new_text .= <<"_#_1_#_" ;
   my (\@kw,\@trailing_list);
   \$proc_keys->(\\\@_,\\\@kw$post_merge_arg,\\\@trailing_list);
_#_1_#_
         } else {
            $new_text .= <<"_#_2_#_";
   my \@kw;
   \$proc_keys->(\\\@_,\\\@kw$post_merge_arg);
_#_2_#_
         }
      }
      if ($check_arg) {
         $new_text .= <<"_#_3_#_";
   if ($check_arg) {
      Polymake::croak( "usage: new ", ref(\$_[0]) || \$_[0], '($signature)' );
   }
_#_3_#_
      }
      if ($constructor_deferred || defined($post_merge_proc)) {
         my $call_post_merge= defined($post_merge_proc) && "   \$post_merge_proc->(\$this,\@post_merge) if \@post_merge;";
         $new_text .= <<"_#_4_#_";
   my \$this=Polymake::Struct::make_body(
$constructor
   shift);
$constructor_deferred
$call_post_merge
   \$this
_#_4_#_
      } else {
         $new_text .= <<"_#_5_#_";
   Polymake::Struct::make_body(
$constructor
   shift);
_#_5_#_
      }
      $new_text .= <<"_#_6_#_";
}
_#_6_#_

      eval $new_text;
      if ($@) {
         my @lines=(undef, split /(?:\#\#\#<\d+>)?\n/, $new_text);      # leading undef makes the line numbers = array index
         $@ =~ s/at \(eval \d+\) line (\d+)/near line $1: '$lines[$1]'/g;
         croak "syntax error in $pkg\::new: $@";
      }
      if ($merger_changed) {
         define_function($symtab, "merge",
            sub : method {
               my $this=shift;
               for (my $i=0; $i<=$#_; ++$i) {
                  my $field=$_[$i];
                  if (is_string($field) && defined (my $k=$keys{$field}) && $i<$#_) {
                     if (defined($merger->[$k])) {
                        $this->[$k]=$merger->[$k]->($this,$field,$_[++$i],$this->[$k]);
                     } else {
                        $this->$field=$_[++$i];
                     }
                  } elsif (ref($field) eq "HASH") {
                     $this->merge(%$field);
                  } else {
                     local $Carp::CarpLevel=1;
                     croak( "$pkg\::merge - ",
                            $i==$#_ ? "keyword $field without value" :
                            is_string($field) ? "unknown keyword $field" :
                            "expected keyword or HASH, got ".(ref($field) || "'$field'") );
                  }
               }
               $this
            });
      }
   } elsif (!$super) {
      croak "no own fields and no Struct-based super class specified";
   }

   define_function($symtab, ".defined", sub { "$file line $line" });
   define_function($symtab, ".constructor", sub { ($cnt, $constructor, $constructor_deferred, $merger) });
   define_function($symtab, "sizeof", sub { $cnt });
   define_function($symtab, ".signature", sub { ($signature, $min_arg, $max_arg, $trailing_arg) }) if $own_signature;
   if ($keys_changed) {
      define_function($symtab, ".keys", sub { \%keys });
   }
   define_function($symtab, "_new", \&_new);
   if (!$super || UNIVERSAL::can($super, "new")==UNIVERSAL::can($super, "_new")) {
      define_function($symtab, "new", \&_new);
   } elsif ($with_namespaces !~ /^no/) {
      # predeclare for the sake of cleaner syntax in the package's code
      no strict 'refs';
      *{"$pkg\::new"}=UNIVERSAL::can($super, "new");
   }
}

sub _new { &{UNIVERSAL::can($_[0],"__new")} }

sub merge_options {
   my $hash=shift;
   for (my $i=0; $i<=$#_; ++$i) {
      if (ref($_[$i]) eq "HASH") {
         push %$hash, %{$_[$i]};
      } else {
         $hash->{$_[$i]}=$_[$i+1];
         ++$i;
      }
   }
   $hash
}

1

# Local Variables:
# cperl-indent-level:3
# indent-tabs-mode:nil
# End:
