#  Copyright (c) 1997-2007
#  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: Module.pm 7560 2007-01-15 14:04:09Z gawrilow $

use strict;
use namespaces;
use re 'eval';

require 'Poly/regex.pl';
require Poly::Help;
require Poly::Overload;
require Poly::Scope;
require Poly::Prototype;
require Poly::Preference;

package Poly::Module;

my %repository;
declare @lookup;

#################################################################################
#
#  Constructor:
#
#  new Module('name', [ "rule file" ]);
#
use Struct (
   [ new => '$' ],
   [ '$name' => '#1' ],		# module name
   '$top',			# top module directory
   '$installTop',		# installation directory
   '%rulefiles',		# 'basename' => load errors
   '@myINC',			# directories with perl modules
   '@compile_preamble',		# lines to include at the beginning of every source file "require"d from the subtree
   '%types',			# 'name' => Prototype
   '$default_type',		# Prototype:  either the first type explicitly declared in the rules, or = 'name'
   '$custom',			# Customize::perModule (if Customize loaded)
   [ '$prefs' => 'new Preference::perModule' ],
   [ '$help' => 'new Help' ],
   '%used',			# 'name' => Module
   '%EXPORT',			# names and attributes of user functions and methods
   [ '$compile_scope' => 'undef' ],
   '%CONFIGURE',		# 'rulefile' => [ \&CONFIGURE, ... ]
   [ '$declared' => '0' ],
);

#################################################################################
sub new {
   my $self=&_new;
   foreach my $dir (@lookup) {
      if (-d "$dir/modules/".$self->name) {
	 $self->installTop=$dir;
	 $self->top="$dir/modules/".$self->name;
	 last;
      }
   }
   croak( "unknown module '", $self->name, "'" ) unless $self->top;

   define_function($self->pkg, "application", sub { $self }, 1);
   if (-d (my $dir=$self->top."/perllib")) {
      push @{$self->myINC}, $dir;
   }
   push @_, "main.rules" if $#_<1;
   $self->init_include_rules(@_[1..$#_]);
   $self;
}
#################################################################################
#
#  Register a module
#
#  add('Name', [ rule file names ])
#
sub add {
   $repository{$_[1]} ||= &new;
}
#################################################################################
sub include_rule {
   my ($self, $rulename)=@_;
   my $filename=$rulename;
   if (defined (my $rc=$self->rulefiles->{$rulename})) {
      $rc;
   } elsif (-f $filename  or  -f ($filename=$self->top."/rules/".$rulename)) {
      $self->rulefiles->{$rulename}=1;
      dbg_print( "reading rules from $filename" ) if $Switches::v>1;
      require "rules:$filename";

   } else {
      croak( "rule file ", $self->name, "::$rulename does not exist" );
   }
}
#################################################################################
sub include_rules {
   my $self=shift;
   local_scalar($self->compile_scope, new Scope());
   eval {
      foreach my $rulename (@_) {
	 if (! include_rule($self, $rulename)) {
	    err_print( "rule file ", $self->name, "::$rulename is excluded by autoconfiguration" );
	 }
      }
   };
   if ($@) {
      undef $reconfigure_hint;
      die beautify_error();
   }
}
#################################################################################
my $partial_reconfig_re;

# protected:
sub init_include_rules {
   my $self=$_[0];
   if (@Switches::reconfigure_rules && !defined($partial_reconfig_re)) {
      foreach (@Switches::reconfigure_rules) {
	 if (/(?:^|\w)\*|\*$/) {
	    # looks like a shell glob
	    s/\*/.*/g;
	    s/\./\\./g;
	 }
	 unless (/(?:\.\w+|\*)$/) {
	    $_ .= "(?:\\.rules?)?";
	 }
	 $_="(?:$_)";
      }
      local $"="|";
      $partial_reconfig_re=qr{^@Switches::reconfigure_rules$};
   }
   if (-d (my $ruledir=$self->top."/rules")) {
      ref($INC[0]) ? (local $INC[0]=$self) : local_unshift(\@INC, $self);
      @{$self->compile_preamble}=( "use namespaces \"".$self->pkg."\";\n" );

      my $ch=$self->can("custom_handler");
      $ch &&= $ch->();
      if ($ch) {
	 $self->custom=$ch->begin_module($self);
	 my $preconfigured=\%{get_pkg($self->pkg)->{rulefiles}};
	 while (my ($rulename, $good)=each %$preconfigured) {
	    if (defined($partial_reconfig_re) && $rulename =~ $partial_reconfig_re) {
	       delete $preconfigured->{$rulename};
	    } elsif (!$good) {
	       $self->rulefiles->{$rulename}=0;
	    }
	 }
      }

      &include_rules;
      $ch->end_module($self) if $ch;
      $self->prefs->end_compile_mode($self);
   }
}
#################################################################################
# private:
sub check_package_existence {
   my $pkg=shift;
   foreach my $part (@_) {
      if (do { no strict 'refs'; ! exists $ {"$pkg\::"}{"$part\::"}}) {
	 return undef;
      }
      $pkg .= "::$part";
   }
   return $pkg;
}
#################################################################################
sub find_object_type {
   my ($self, $object_type)=@_;
   my $pkg;
   my @object_type=split /::/, $object_type;

   if (! ( @object_type>1  and
	   $pkg=check_package_existence("main", @object_type))  and
       ! ($pkg=check_package_existence($self->pkg, @object_type))) {
      foreach my $module (values %{$self->used}) {
	 $pkg=check_package_existence($module->pkg, @object_type)  and  last;
      }
   }
   $pkg;
}
#################################################################################
sub find_prototype {
   my ($self, $proto_name)=@_;
   if ($proto_name eq "default") {
      $self->default_type
   } else {
      $self->types->{$proto_name} ||= do {
	 my $proto;
	 foreach my $u (values %{$self->used}) {
	    $proto=$u->types->{$proto_name}
	    and last;
	 }
	 $proto or return undef;
      }
   }
}
#################################################################################
sub find_custom_var {
   my ($self, $name)=@_;
   $self->custom->find($name, $self->pkg)  or do {
      my $var;
      foreach my $module (values %{$self->used}) {
	 $var=$module->custom->find($name, $module->pkg)
	 and return $var;
      }
      $var;
   }
}
#################################################################################
sub get_help {
   my $self=shift;
   $self->help->get(@_) || "no help available\n";
}
#################################################################################
sub pkg {
   "Modules::" . (shift->name)
}
#################################################################################
# perl module reading facility

package Poly::Module::PrologueFilter;
use Struct (
   [ new => '$@' ],
   [ '$handle' => '#1' ],
   '@buffer',
);

sub new {
   my $self=&_new;
   shift;
   if (@_>1) {
      @{$self->buffer}=@_;
   } else {
      @{$self->buffer}=split /(?<=\n)/, shift;
   }
   (\&get, $self);
}

sub get {
   my ($maxlen, $self)=@_;
   if (@{$self->buffer}) {
      $_ .= shift @{$self->buffer};
   } else {
      $_ .= readline $self->handle;
   }
   return length;
}

#################################################################################
#
#   Rule parser

package Poly::Module::RuleFilter;

use Struct (
   [ new => '$$$@' ],
   [ '$handle' => '#1' ],
   [ '$module' => '#2' ],
   [ '$path' => '#3' ],
   '@buffer',
   '$body',			# 1 - declaration section, 2 - start of a production rule
   [ '$gap' => '1' ],		# 1 - empty line, 2 - comment block
   '$start_comments',
   '$len_comments',
   '@header',
   '@trailer',
   '$filter',
   '$header_line',
);


sub new {
   my $self=&_new;
   splice @_, 0, 3;
   if (@_>2) {
      @{$self->buffer}=@_;
   } else {
      @{$self->buffer}=split /(?<=\n)/, shift;
   }
   (\&get, $self);
}

sub get {
   my ($maxlen, $self)=@_;
   unless (@{$self->buffer}) {
      namespaces::temp_disable();
      fill($self);
   }
   print STDERR ">>> ", $self->buffer->[0] if $Switches::d > 3;
   $_ .= shift @{$self->buffer};
   return length;
}
#################################################################################

declare %rule_headers=(
   USE => sub {
      my ($self, $header)=@_;
      $self->body=1;
      push @{$self->buffer}, "BEGIN { default::application()->use_modules(qw($header\n";
      push @{$self->trailer}, ")) }\n";
   },

   INCLUDE => sub {
      my ($self, $header)=@_;
      $self->body=1;
      push @{$self->buffer}, "default::application()->include_rule(\$_) for (qw($header\n";
      push @{$self->trailer}, "));\n";
   },

   CONFIGURE => \&start_autoconfig,

   object => sub {
      my ($self, $header)=@_;
      $self->body=0;
      if ($header =~ /^($id_re) (?: \s*:\s* ($ids_re) | \s* (;) )? \s*$/xo) {
	 if (my $proto=$self->module->find_prototype($1)) {
	    push @{$self->buffer},
	         $3 ? "package ".$proto->object_type.";\n"
		    : "die 'multiple declaration of object type $1';\n";
	 } elsif ($3) {
	    push @{$self->buffer},
	         "die 'object type $1 not declared';\n";
	 } else {
	    push @{$self->buffer},
	         "package ".$self->module->pkg."::$1;\n",
	         "BEGIN { default::application()->add_object('$1', '$2', <<'_#_#_#_');\n",
		 splice(@{$self->buffer}, $self->start_comments, $self->len_comments),
		 "_#_#_#_\n",
		 "#line $.\n",
		 "}\n",
		 "#line ".($.+1)."\n";
	 }
      } else {
	 push @{$self->buffer}, "die 'invalid object declaration';\n";
      }
   },

   property => sub {
      my ($self, $header)=@_;
      if ($header =~ /^($id_re) (?: \s*=\s* ($id_re))? $/xo) {
	 if (defined $2) {
	    push @{$self->buffer},
	         "Prototype()->add_property_alias('$1', '$2');\n";
	    $self->body=0;
	 } else {
	    push @{$self->buffer},
	         "{\n",
		 @Poly::Property::decl_prologue,
		 "#line ".($.+1)."\n";
	    push @{$self->trailer},
	         "Prototype()->add_property_description('$1', $Poly::Property::decl_args, <<'_#_#_#_');\n",
		 splice(@{$self->buffer}, $self->start_comments, $self->len_comments),
		 "_#_#_#_\n",
		 "}\n";
	    $self->body=1;
	 }
      } else {
	 push @{$self->buffer}, "die 'invalid property declaration';\n";
      }
   },

   custom => sub {
      my ($self, $header)=@_;
      $self->body=1;
      push @{$self->buffer}, "#line $.\n";
      my $varname;
      my $config="";
      if ($header =~ /^[\$\@%] $id_re (?!:) (?= \s*=)?/xo) {
	 substr($header,0,0)="declare ";
	 $varname=$&;
	 $config=", \$config_mode" unless $1;
	 push @{$self->buffer}, "$header\n";
      } elsif ($header =~ /^[\$\@%] $qual_id_re (?= (\s*=))?/xo) {
	 $varname=$&;
	 if ($1) {
	    push @{$self->buffer}, "$header\n";
	 } else {
	    $config=", \$config_mode";
	 }
      } else {
	 push @{$self->buffer}, "die 'invalid custom variable name'; $header\n";
	 return;
      }
      push @{$self->trailer},
           "default::application()->custom->add('$varname', <<'_#_#_#_'$config);\n",
	   splice(@{$self->buffer}, $self->start_comments, $self->len_comments),
	   "_#_#_#_\n";

      # must collect embedded comments in the hashes
      if ($header =~ /% $qual_id_re \s*=\s* \(/xo) {
	 $self->filter=\&custom_hash_filter;
      }
   },

   label => sub {
      my ($self, $header)=@_;
      $self->body=0;
      if ($header =~ $id_only_re) {
	 push @{$self->buffer},
            "default::application()->add_label('$1', <<'_#_#_#_');\n",
	    splice(@{$self->buffer}, $self->start_comments, $self->len_comments),
	    "_#_#_#_\n",
	    "#line ".($.+1)."\n";
      } else {
         push @{$self->buffer}, "BEGIN { die 'invalid label name' }\n";
      }
   },

   prefer => sub {
      my ($self, $header)=@_;
      $self->body=0;
      $header =~ s/\s+$//;
      push @{$self->buffer}, "default::application()->prefs->add_preference('$header', 3);\n";
   },

   function => sub {
      prepare_function(@_, "", "", 0);
   },

   method => sub {
      prepare_function(@_, " : method", "", 0, "check_default_pkg(0); ");
   },

   user_function => sub {
      prepare_function(@_, "", "", 1, "check_default_pkg(1); ");
   },

   user_method => sub {
      prepare_function(@_, " : method", "", 1, "");
   },

   global_method => sub {
      prepare_function(@_, " : method", "_global", 0, "check_default_pkg(0); ");
   },

   file_suffix => sub {
      my ($self, $header)=@_;
      $self->body=0;
      if ($header =~ /(\w+)\s*$/) {
	 $self->module->file_suffix=$1;
      } else {
	 push @{$self->buffer}, "die 'invalid file suffix'\n";
      }
   },

   default_object => sub {
      my ($self, $header)=@_;
      $self->body=0;
      if ($header =~ $id_only_re) {
	 push @{$self->buffer},
	      "default::application()->default_type=default::application()->find_prototype('$1') or die 'unknown object type';\n";
      } else {
	 push @{$self->buffer}, "die 'invalid type name'\n";
      }
   },
);

#################################################################################
sub convert_signature {
   my $kw="";
   $_[0] =~ s/(?:^|,\s*)? ( (?: \\?% | \{ ) .*)/ %/x	# strip off the keywords
      and
   ($kw=", $1") =~ s/(?<! \\) \s* %/\\%/gx;	# pass hash references, not copies
   if (defined($_[0])) {
      $_[0]="default::application()->prepare_signature('$_[0]')$kw,";
   }
}

my $funcnt="aaa000";

sub prepare_function {
   my ($self, $header, $method, $global, $user, $context_check)=@_;
   $self->body=1;
   if (my ($labels, $name, $signature)= $header =~ $labeled_sub_re) {
      $header=$';
      my @add2help;
      if (defined($signature)) {
	 push @add2help, "# signature: $signature\n" if $user;
	 convert_signature($signature);
      }
      if (defined($labels)) {
	 $labels="default::application()->prepare_labels('$labels'),";
      }
      if ($user) {
	 my $topic=$method ? "'objects', pkg_to_object_name(), 'methods', '$name'" : "'functions', '$name'";
	 push @{$self->buffer},
	      "default::application()->help->add_function([$topic], <<'_#_#_#_');\n",
	      splice(@{$self->buffer}, $self->start_comments, $self->len_comments),
	      @add2help,
              "_#_#_#_\n",
	      "#line ".$self->header_line."\n";
	 $self->module->EXPORT->{$name} ||= $method ? "meth" : "user";
      } elsif (!$method) {
	 $self->module->EXPORT->{$name} ||= "func";
      }
      if (defined($signature) || defined($labels)) {
	 $context_check &&= "BEGIN { $context_check }";
	 ++$funcnt;
	 push @{$self->buffer},
	      "$context_check add$global Overload $labels '$name', $signature \\&__${name}__OV__$funcnt; sub __${name}__OV__$funcnt$method $header\n";
      } elsif ($global) {
	 push @{$self->buffer}, "BEGIN { die 'global method must have signature and/or labels' }\n";
      } else {
	 push @{$self->buffer},
	      "BEGIN { $context_check exists &$name and multiple_definition() } sub $name$method $header\n";
      }
   } else {
      push @{$self->buffer}, "BEGIN { die 'invalid function header' }\n";
   }
}
#################################################################################
sub custom_hash_filter {
   my ($self, $line)=@_;
   if ($line =~ /^\s* (?: (\w+) | (['"])(.*?)\2 ) \s* => .*? \#/x) {
      # insert just before the _#_#_#_ end marker
      splice @{$self->trailer}, -1, 0, ($1 || $3)." => $'";
   } elsif ($line =~ /^\s*\#\s*\S/) {
      splice @{$self->trailer}, -1, 0, $line;
   }
}
#################################################################################
declare %prod_rule_subheaders=(
   WEIGHT => sub {
      my ($self, $header)=@_;
      if ($header =~ s/^WEIGHT \s+ (\d+)\.(\d+) \s*/WEIGHT/x) {
         push @{ @{$self->header} ? $self->buffer : $self->trailer }, "[$1, $2],\n";
      }
      if ($header =~ /:/) {
	 start_prod_fragment($self, $header, "is_dyn_weight");
      } elsif ($header eq "WEIGHT") {
         &start_prod_rule_body;
      } else {
         push @{$self->buffer}, "die('invalid WEIGHT specification'),\n";
      }
   },

   PRECONDITION => sub {
      start_prod_fragment(@_, "is_precondition");
   },

   BODY => sub {
      &start_prod_rule_body;
      $_[0]->body=1;
   },
);

sub start_prod_rule {
   my ($self, $header)=@_;
   if ($header =~ /^CONFIGURE \s*:\s* (?: ($id_re) :: (\S*) | (\S+) ) \s*$/xo) {
      start_autoconfig($self, $header, $1, $2, $3);
   } else {
      push @{$self->buffer}, "new Rule(Prototype(), '$header',\n";
      push @{$self->header}, "sub {\n", @Poly::Rule::prologue;
      push @{$self->trailer}, "#line ".$self->header_line."\n", "});\n";
      $self->body=2;
   }
}

sub start_prod_fragment {
   my ($self, $header, $kind)=@_;
   if (!@{$self->header}) {
      push @{$self->buffer}, @{$self->trailer};
   }
   push @{$self->buffer},
        "special Rule(Prototype(), '$header', \$Poly::Rule::$kind, sub {\n",
	@Poly::Rule::prologue,
	"#line ".($.+1)."\n";
   @{$self->header}=();
   @{$self->trailer}=( "#line $.\n", "}),\n" );
}

sub start_prod_rule_body {
   my ($self)=@_;
   if (!@{$self->header}) {
      push @{$self->buffer}, @{$self->trailer};
      push @{$self->header}, "sub {\n", @Poly::Rule::prologue;
   }
   @{$self->trailer}=( "#line ".$self->header_line."\n", "});\n" );
}

sub start_autoconfig {
   my ($self, $header, @as_rule)=@_;
   $self->body=1;
   $self->path =~ m{ / ([^/]+)$ }x;
   if (exists get_pkg($self->module->pkg)->{rulefiles}->{$1}) {
      push @{$self->buffer}, "#CONFIGURE {\n";
      $self->filter=sub { $_[1] =~ s/^/\#/ };
   } else {
      if (@as_rule) {
	 $self->body=0;
	 push @{$self->buffer},
	      "default::application()->store_configured('$1', " .
	      ( $as_rule[0] ? "default::application()->used->{$as_rule[0]}->rulefiles->{'".($as_rule[1] || $1)."'}"
	                    : "default::application()->rulefiles->{'$as_rule[2]'}" ) .
	      ") || return 1;\n";
      } else {
	 push @{$self->buffer},
	      "BEGIN { \$config_mode=1 } default::application()->store_configured('$1', sub $header\n";
	 push @{$self->trailer},
	      ") || return 1; \$config_mode=0;\n";
      }
   }
}
#################################################################################
# it should be a lexical variable, but (?{ }) seems sometimes to be unable to assign to lexicals
declare $header_sub;

sub fill {
   my $self=shift;
   $self->start_comments=$self->len_comments=0;
 READ: {
      my $line=readline $self->handle;
      if (!length($line)) {
	 # EOF
	 my $lastline=$.;
	 close $self->handle or die "Syntax error near the end of file at ", $self->path, ", line ", $self->header_line, "\n";
	 if (@{$self->trailer}) {
	    my $firstline=$lastline-@{$self->buffer}+1;
	    unshift @{$self->buffer}, @{$self->trailer}, "#line $firstline\n";
	 }
	 push @{$self->buffer}, "1\n", "__END__\n";
	 $self->header_line=$lastline;
	 last;
      }

      if ($line !~ /\S/) {
	 # empty line
	 if ($self->gap==2) {
	    if ($self->buffer->[$self->start_comments] =~ m|^\#\s*topic:\s*((functions/)?.*\S)\s*$|i) {
	       my $help_path=
	          $1 eq "application"
		  ? "''" :
		  $1 eq "file"
		  ? '"rulefiles/".__FILE__'
		  : "'$1'";
	       my $function=$2 && $self->buffer->[$self->start_comments+1] =~ /\bcategory:/i && "_function";
	       $self->buffer->[$self->start_comments]="default::application()->help->add$function($help_path, <<'_#_#_#_');\n";
	       $line="_#_#_#_\n";
	       $self->start_comments=$self->len_comments=0;
	    }
	 }
	 $self->gap=1;
	 push @{$self->buffer}, $line;
	 redo;
      }

      if ($line =~ /^\#/) {
	 # comment line
	 if ($self->gap) {
	    if ($self->gap==1) {
	       # ... after an empty line - starts a new comment block
	       $self->start_comments=@{$self->buffer}; $self->len_comments=0;
	       $self->gap=2;
	    }
            push @{$self->buffer}, $line;
	    ++$self->len_comments;
            redo;
	 }
         # comments amidst the code
         if ($self->filter) {
	    $self->filter->($self, $line);
         }
         push @{$self->buffer}, $line;
         last;
      }

      undef $header_sub;   ### Bug in perl? Should be: my $header_sub;
      use re 'eval';

      if ($self->body==2 &&
	  $line =~ m{^($id_re) (?(?{ $header_sub=$prod_rule_subheaders{$1} }) [\s:] | (?! $|.) )}xo) {
	 chomp $line;
	 $header_sub->($self, $line);
	 $self->gap=0;
	 last;
      }
	  
      if ($self->body) {
         if ($line =~ /^[ \t]/ || !$self->gap) {
	    # indented line or body continued
            if ($self->filter) {
	       $self->filter->($self, $line);
            }
            if (@{$self->header}) {
               push @{$self->buffer}, splice(@{$self->header}, 0), "#line $.\n";
            }
            push @{$self->buffer}, $line;
	    $self->gap=0;
            last;
         }
      }

      $self->gap=0;
      if ($line !~ /^[ \t]/) {
         # non-indented line after an empty line or comment block - start of a new section

         if (my $tr=@{$self->trailer}) {
            # pending trailer belongs to the previous section, therefore put it before the empty lines
            # and comment blocks gathered in the meanwhile
            my $firstline=$.-@{$self->buffer};
            unshift @{$self->buffer}, splice(@{$self->trailer}, 0), "#line $firstline\n";
	    $self->start_comments+=$tr+1;
         }
         undef $self->filter;

         if ($line =~ m{^(?: ($hier_id_re) \s* [,:]
			 | ($id_re) (?(?{ $header_sub=$rule_headers{$2} }) (?: $|\s+) | (?! $|.)) )}xo) {
            # header recognized
            $line=$' if $2;
	    $self->header_line=$.;

            # concatenate header continuation lines
            for (;;) {
               chomp $line;
               last if substr($line,-1,1) ne '\\';
               if (defined (my $cont=readline($self->handle))) {
		  $cont =~ s/^\s{2,}/ /;
		  substr($line,-1,1)=$cont;
	       } else {
		  push @{$self->buffer}, "die 'unexpected EOF after continuation mark';\n";
		  return;
	       }
            }
            if ($header_sub) {
               $header_sub->($self, $line);
            } else {
               start_prod_rule($self, $line);
            }
            last;
         }
         $self->body=0;
      }
      # some perl code
      push @{$self->buffer}, $line;
   }
}

#################################################################################
#
#  methods needed to fill up the application
#  primarily expected to be called from the transformed rules

package Poly::Module;

declare $reconfigure_hint;

END {
   if ($reconfigure_hint && !$Switches::reconfigure && !@Switches::reconfigure_rules) {
      warn $reconfigure_hint;
   }
}

sub store_configured {
   my ($self, $filename, $what)=@_;
   if (is_code($what)) {
      push @{$self->CONFIGURE->{$filename}}, $what;
      $what=eval { &$what };
      if ($@) {
	 warn_print( $self->name, "::$filename - autoconfiguration failed:\n", $@ );
	 $reconfigure_hint ||= <<'.';
 * Remember to run `polymake --reconfigure-rules RULENAME ... '
 * or just `polymake --reconfigure'
 * as soon as you have changed the customization file
 * or installed the missing software!
.
	 $@="";
      }
   }
   $self->rulefiles->{$filename}=
   get_pkg($self->pkg)->{rulefiles}->{$filename}=$what ? 1 : 0;	# normalize to bool
}

sub repeat_configure {
   my ($self, $filename)=@_;
   my $success=1;
   $self->custom->re_tie($Poly::Customize::state_config);
   foreach my $sub (@{$self->CONFIGURE->{$filename}}) {
      $success=eval { &$sub } or last;
   }
   get_pkg($self->pkg)->{rulefiles}->{$filename}=$success;
   $self->rulefiles->{$filename}=$success;
   $self->custom->un_tie($Poly::Customize::state_config);
   return $success;
}

#################################################################################
sub use_module {
   my ($self, $mod)=@_;
   push @{$self->myINC}, @{$mod->myINC};
   push %{$self->EXPORT}, %{$mod->EXPORT};
   $self->prefs->inherit($mod->prefs);
   $self->help->merge($mod->help);

   # flatten the %used
   while (my ($othername, $other)=each %{$mod->used}) {
      $self->used->{$othername}=$other;
   }
   $self->used->{$mod->name}=$mod;
   namespaces::using($self->pkg, $mod->pkg);
}

sub use_modules {
   my $self=shift;
   my @modules;
   foreach my $modname (@_) {
      if ($modname =~ /($id_re) (?: \( (.*?) \) )?/xo) {
	 push @modules, add Module($1, split /,/, $2);
      } else {
	 croak( "invalid module name '$modname'" );
      }
   }

  USED:
   for (my $i=0; $i<=$#modules; ++$i) {
      my $mod=$modules[$i];
      next if $self->used->{$mod->name};
      for (my $j=$i+1; $j<=$#modules; ++$j) {
	 if ($modules[$j]->used->{$mod->name}) {
	    splice @modules, $i--, 1;
	    next USED;
	 }
      }
      $self->use_module($mod);
   }
}
#################################################################################
sub add_object {
   my ($self, $proto_name, $super, $help_text)=@_;
   if (find_prototype($self, $proto_name)) {
      croak( "multiple declaration of object type '$proto_name'" );
   }
   my $object_type=$self->pkg . "::$proto_name";
   my $proto=new Prototype(
      $proto_name, $object_type, $self,
      map { find_prototype($self, $_) || croak( "unknown object type '$_'" ) } split /\s*,\s*/, $super
   );
   $self->default_type ||= $proto;
   $self->help->add([ "objects", $proto_name ], $help_text);

   # define the convenience constructor function
   $self->EXPORT->{$proto_name}=sub {
      croak( "need some initial properties" ) if @_ < 2;
      unshift @_, $object_type;
      Modules::returnObject(&Poly::Object::new);
   };
   $self->types->{$proto_name}=$proto;
}
#################################################################################
sub add_label {
   my ($self, $name, $help_text)=@_;
   $self->help->add([ "preferences", $name ], $help_text);
   $self->prefs->add_label($name);
}
#################################################################################
sub prepare_signature {
   my ($self, $signature)=@_;
   $signature =~ s{$unqual_id_re(?!['"])}{
      exists $main::{"$&::"} ? $& : $self->find_object_type($&)
      or croak( "unknown type '$&'" );
   }geo;
   $signature;
}
#################################################################################
sub prepare_labels {
   my ($self, $labels)=@_;
   [ map { $self->prefs->find_label($_, 1) or croak( "unknown label '$_'" ) } split /\s*,\s*/, $labels ]
}
#################################################################################
my $start_decls=<<'_#_#_#_';
declare %rulefiles;
application()->custom->add('%rulefiles', <<'.', 1);
Rulefiles with autoconfiguration sections and their exit codes.
Value 0 denotes configuration failure, which disables the corresponding rulefile.
.
_#_#_#_

# private:
# must be qualified, otherwise would land in main::
sub Poly::Module::INC {
   my ($self, $filename)=@_;
   if ($filename =~ s/^rules://) {
      open my $handle, $filename or die "can't read rule file $filename: $!\n";
      my $mod_pkg=$self->pkg;
      $self->compile_scope->begin_locals;
      local *default::=get_pkg($mod_pkg);
      $self->compile_scope->end_locals;
      my $decls=!($self->declared++) && <<"_#_#_#_";
$start_decls
package $mod_pkg;
_#_#_#_
      return new RuleFilter($handle, $self, $filename, <<"_#_#_#_");
use namespaces '$mod_pkg';
my \$config_mode;
package $mod_pkg;
$decls#line 1 "$filename"
_#_#_#_

   } else {
      foreach my $dir (@{$self->myINC}) {
	 if (-f (my $path="$dir/$filename")) {
	    open my $handle, $path or die "can't load $path: $!\n";
	    return new PrologueFilter($handle, @{$self->compile_preamble}, "#line 1 \"$path\"\n");
	 }
      }
   }
   undef;
}

#################################################################################
package Modules;
using namespaces 'Poly';

sub Prototype {
   croak( "This declaration is allowed only in an object definition scope" );
}

sub multiple_definition {
   croak( "Multiple definition of a non-overloaded function");
}

sub check_default_pkg {
   my $equal=$_[0];
   if (compiling_in(\%default::) != $equal) {
      croak( "This declaration ",
	     $equal ? "is allowed only" : "is not allowed",
	     " on the application level (package default)" );
   }
}

sub pkg_to_object_name {
   my $pkg=caller;
   UNIVERSAL::isa($pkg, "Poly::Object")
   ? $pkg =~ /::($id_re)$/o :
   UNIVERSAL::isa($pkg, "Visual::Object")
   ? $pkg
   : Prototype();
}

####################################################################################
package Poly;
sub croak {
   my ($pkg, $file, $line, $sub);
   my $i=0;
   if (is_object($INC[0]) && defined($INC[0]->compile_scope)) {
      do {
	 ($pkg, $file, $line, $sub)=caller(++$i);
      } while ($pkg =~ /^Poly::/);

   } else {
      do {
	 ($pkg, $file, $line, $sub)=caller(++$i);
	 if (!defined $pkg || $pkg eq "main") {
	    # not clear where we came from
	    local $Carp::CarpLevel=1;
	    &Carp::confess;
	 }
      } while ($pkg !~ /^Poly::User\b/  or  $i==1 && $sub =~ /\bAUTOLOAD$/);

      if ($file =~ m'(?:^\(eval|/User.pm$)' || $sub eq "(eval)") {
	 # compatibility mode or command line script
	 die @_, "\n";
      }
   }
   local $_=join("", @_);
   s/(?=\.?$)/ at $file line $line/m;
   die enforce_nl($_);
}

sub beautify_error {
   if (!$Switches::d) {
      $@ =~ s/ at \(eval \d+\)(?:\[.*?:\d+\])? line 1(\.)?/$1/g;
      $@ =~ s/, <\$?$id_re> line \d+\.//go;
      $@ =~ s/^(?:Compilation failed in require |BEGIN failed--|BEGIN not safe after errors--).*\n//mg;
      $@ =~ s/^(.*)(?<!\bcalled) at (\S+) (?(?{-f $2})(line \d+)|(?!.))(?:,( near .*))?\.?\n/"$2", $3: $1$4\n/mg;
      $@ =~ s/((".*?", line \d+:).*\n)(?:\2 syntax error near ".*?"\n)/$1/mg;
   }
   $@;
}


1