#  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: Module.pm,v 1.28.2.4 2004/12/17 16:17:34 gawrilow Exp $

use strict;
use namespaces;

package Poly::Module;
use Poly::Help;
use Poly::Overload;
use Poly::Scope;
use Poly::Prototype;
require Poly::Preference;

my %repository;

declare @lookup;

#################################################################################
#
#  Constructor:
#
#  new Poly::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
   '%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 Poly::Preference::perModule' ],
   [ '$help' => 'new Poly::Help' ],
   '%used',			# 'name' => Module
   '%EXPORT',			# names and attributes of user functions and methods
   '$compile_scope',
   '%CONFIGURE',		# 'rulefile' => [ \&CONFIGURE, ... ]
);

#################################################################################
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;
      }
   }
   die "unknown module '", $self->name, "'\n" unless $self->top;

   define_function($self->pkg, "application", sub { $self }, 1);
   if (-d (my $dir=$self->top."/perllib")) {
      push @{$self->myINC}, $dir;
   }
   ref($INC[0]) ? (local $INC[0]=INCluder($self)) : (local @INC=(INCluder($self), @INC));
   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;
   my $rc;
   if (defined ($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 Poly::Scope);
   foreach my $rulename (@_) {
      if (! include_rule($self, $rulename)) {
	 err_print( "rule file ", $self->name, "::$filename is excluded by autoconfiguration" );
      }
   }
}
#################################################################################
# protected:
sub init_include_rules {
   my $self=$_[0];
   if (-d (my $ruledir=$self->top."/rules")) {
      my $ch=$self->can("custom_handler");
      $ch &&= $ch->();
      if ($ch) {
	 $self->custom=$ch->begin_module($self);
	 $self->get_configured_rulefiles;
      }
      &include_rules;
      if ($self->custom) {
	 $ch->end_module($self);
      }
      $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)=@_;
   $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 get {
   my ($maxlen, $self)=@_;
   if (@{$self->buffer}) {
      $_ .= shift @{$self->buffer};
   } else {
      $_ .= readline $self->handle;
   }
   return length;
};

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

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

# an identifier (alphanumeric, first character not a digit)
my $id_re=qr{(?> (?!\d)\w+ )}x;

# a list of identifiers (separated by commas)
my $ids_re=qr{(?> $id_re (?: \s*,\s* $id_re)* )}x;

# hierarchical identifier (identifiers connected with dots)
my $hier_id_re=qr{(?> (?!\d\.)[.\w]+ )}x;

# a list of hierarchical identifiers (separated by commas)
my $hier_ids_re=qr{(?> $hier_id_re (?: \s*,\s* $hier_id_re)* )}x;

# a lone identifier
my $id_only_re=qr{ ($id_re) \s*$ }x;

# fully qualified perl name
my $qual_id_re=qr{(?> (?!\d)[\w:]+ )}x;

# unqualified perl name
my $unqual_id_re=qr{(?<!::) (?<!\w) $id_re (?! :: )}x;

my $balanced_re;
$balanced_re=qr{ (?: (?> [^(\[{}\])]+ ) | (?<! \\ ) \\ [(\[{}\])] |
                     \( (??{ $balanced_re }) \) |
                     \[ (??{ $balanced_re }) \] |
                     \{ (??{ $balanced_re }) \}
                 )* }x;
                     
# function declaration: labels, name, prototype
my $sub_re=qr{ (?:($hier_ids_re)\s*:\s*)? ($id_re) \b (?: \s*\( ($balanced_re) \) )? }x;

#################################################################################
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)=@_;
   fill($self) unless @{$self->buffer};
   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*$/x) {
	 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)=@_;
      $self->body=1;
      if ($header =~ $id_only_re) {
	 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";
      } else {
	 push @{$self->buffer}, "die 'invalid property name';\n";
      }
   },

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

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

declare $header_sub;

#################################################################################
sub prepare_function {
   my ($self, $header, $method, $global, $user, $context_check)=@_;
   $self->body=1;
   if (my ($labels, $name, $signature)= $header =~ $sub_re) {
      my @add2help;
      push @add2help, "# signature: $signature\n" if $user && $signature;
      $header=$';
      if ($labels || $signature) {
	 my $kw="";
	 $signature =~ s/(?:,\s*)? ( (?: \\?% | \{ ) .*)/ %/x	# strip off the keywords
	    and
	 ($kw=", $1") =~ s/(?<! \\) \s* %/\\%/gx;	# pass hash references, not copies
	 $labels &&= "default::application()->prepare_labels('$labels'),";
	 $signature &&= "default::application()->prepare_signature('$signature')$kw,";
	 $context_check &&= "BEGIN { $context_check }";
	 push @{$self->buffer},
	      "$context_check add$global Poly::Overload $labels '$name', $signature sub$method $header\n";
	 push @{$self->trailer}, ";\n";
      } elsif ($global) {
	 push @{$self->buffer}, "die 'global method must have signature and/or labels'; sub dummy {\n";
      } else {
	 push @{$self->buffer},
	      "BEGIN { $context_check exists &$name and multiple_definition() } sub $name$method $header\n";
      }
      if ($user) {
	 my $topic=$method ? "'objects', pkg_to_object_name(__PACKAGE__), 'methods', '$name'" : "'functions', '$name'";
	 splice @{$self->buffer}, -1, 0, "#line $.\n";
	 push @{$self->trailer},
	      "default::application()->help->add_function([$topic], <<'_#_#_#_');\n",
	      splice(@{$self->buffer}, $self->start_comments, $self->len_comments),
	      @add2help,
              "_#_#_#_\n";
	 $self->module->EXPORT->{$name}= $method ? "meth" : "user";
      } elsif (!$method) {
	 $self->module->EXPORT->{$name}="func";
      }
   } else {
      push @{$self->buffer}, "die 'invalid function header'; sub dummy {\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*$/x) {
      start_autoconfig($self, $header, $1, $2, $3);
   } else {
      push @{$self->buffer}, "new Poly::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 Poly::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 ($self->module->rulefile_is_configured($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";
      }
   }
}
#################################################################################

sub fill {
   my $self=shift;
   $self->start_comments=$self->len_comments=0;
 READ: {
      my $line=readline $self->handle;
      if (!length($line)) {
	 # EOF
	 unshift @{$self->buffer}, @{$self->trailer};
	 push @{$self->buffer}, "1\n", "__END__\n";
	 close $self->handle;
	 last;
      }

      if ($line !~ /\S/) {
	 # empty line
	 if ($self->gap==2) {
	    if ($self->buffer->[$self->start_comments] =~ /^\#\s*topic:\s*(.*\S)\s*$/i) {
	       $self->buffer->[$self->start_comments]="default::application()->help->add('$1', <<'_#_#_#_');\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;
      use re 'eval';

      if ($self->body==2 &&
	  $line =~ m{^($id_re) (?(?{ defined($header_sub=$prod_rule_subheaders{$1}) }) [\s:] | (?! $|.) )}x) {
	 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) (?(?{ defined($header_sub=$rule_headers{$2}) }) (?: $|\s+) | (?! $|.)) )}x) {
            # header recognized
            $line=$' if $2;
	    $self->header_line=$.;

            # concatenate header continuation lines
            for (;;) {
               chomp $line;
               last if substr($line,-1,1) ne '\\';
               my $cont=readline($self->handle)
	       or do { push @{$self->buffer}, "die 'unexpected EOF after continuation mark';\n"; return };
               $cont =~ s/^\s{2,}/ /;
               substr($line,-1,1)=$cont;
            }
            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;

my $custom_rulefiles_comment=<<'.';
Rulefiles with autoconfiguration sections and their exit codes.
Value 0 denotes configuration failure, which disables the corresponding rulefile.
.

sub get_configured_rulefiles {
   my ($self)=@_;
   my $hashname=$self->pkg . "::rulefiles";
   if (defined (my $configured=do { no strict 'refs'; *{$hashname}{HASH}})) {
      $self->custom->add("%$hashname", $custom_rulefiles_comment, 1);
      while (my ($filename, $good)=each %$configured) {
	 $self->rulefiles->{$filename}=0 unless $good;
      }
      no strict 'refs';
      *$hashname=\%$hashname;
   }
}
#################################################################################
sub rulefile_is_configured {
   my ($self, $filename)=@_;
   my $hashname=$self->pkg . "::rulefiles";
   if (defined (my $configured=do { no strict 'refs'; *{$hashname}{HASH}})) {
      $configured->{$filename}
   } else {
      no strict 'refs';
      declare *$hashname={ };
      %$hashname=();
      $self->custom->add("%$hashname", $custom_rulefiles_comment, 1);
      undef;
   }
}
#################################################################################
declare $reconfigure_hint;

END {
   warn $reconfigure_hint if $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=<<'.' unless defined($reconfigure_hint);
 * Remember to run `polymake --reconfigure'
 * as soon as you have changed the customization file
 * and/or installed the missing software!
.
	 $@="";
      }
   }
   my $hashname=$self->pkg . "::rulefiles";
   no strict 'refs';
   $self->rulefiles->{$filename}=
   $hashname->{$filename}=$what ? 1 : 0;	# normalize to bool
}

sub repeat_configure {
   my ($self, $filename)=@_;
   my $success=1;
   foreach my $sub (@{$self->CONFIGURE->{$filename}}) {
      $success=eval { &$sub } or last;
   }
   my $hashname=$self->pkg . "::rulefiles";
   no strict 'refs';
   $self->custom->reset("%$hashname",$filename);
   $hashname->{$filename}=$success;
   $self->custom->refresh;
   $self->rulefiles->{$filename}=$success;
}

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

  USED:
   for (my $i=0; $i<=$#modules; ++$i) {
      my $u=$modules[$i];
      my $modname=$u->name;
      next if $self->used->{$modname};
      for (my $j=$i+1; $j<=$#modules; ++$j) {
	 if ($modules[$j]->used->{$modname}) {
	    splice @modules, $i--, 1;
	    next USED;
	 }
      }
      push @{$self->myINC}, @{$u->myINC};
      push %{$self->EXPORT}, %{$u->EXPORT};
      $self->prefs->inherit($u->prefs);
      $self->help->merge($u->help);

      # flatten the %used
      while (my ($othername, $other)=each %{$u->used}) {
	 $self->used->{$othername}=$other;
      }
      $self->used->{$modname}=$u;
      namespaces::using($self->pkg, $u->pkg);
   }
}
#################################################################################
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 Poly::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)=@_;
   my $label=$self->prefs->add_label($name);
   $self->help->add([ "preferences", $name ], $help_text);
   $self->EXPORT->{$name}=sub {
      my $self=$label;
      foreach my $sublevel (&Poly::Shell::get_chained) {
	 $self=( $self->children->{$sublevel}
		 or die "unknown label " . $self->full_name . ".$sublevel\n" );
      }
      $self->set_temp_preferred($main::scope);
      ();	# suppress output
   };
   $label;
}
#################################################################################
sub prepare_signature {
   my ($self, $signature)=@_;
   $signature =~ s{$unqual_id_re}{
      exists $main::{"$&::"} ? $& : $self->find_object_type($&)
      or croak( "unknown type '$&'" );
   }ge;
   $signature;
}
#################################################################################
sub prepare_labels {
   my ($self, $labels)=@_;
   [ map { $self->prefs->find_label($_, 1) or croak( "unknown label '$_'" ) } split /\s*,\s*/, $labels ]
}
#################################################################################
# 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;
      no strict 'refs';
      $self->compile_scope->begin_locals;
      local *default::=\%{"$mod_pkg\::"};
      $self->compile_scope->end_locals;
      return new Poly::Module::RuleFilter($handle, $self, $filename, <<"_#_#_#_");
use namespaces '$mod_pkg';
my \$config_mode;
package $mod_pkg;
#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";
	    my $mod_pkg=$self->pkg;
	    return new Poly::Module::PrologueFilter($handle, <<"_#_#_#_");
use namespaces '$mod_pkg';
#line 1 "$path"
_#_#_#_
	 }
      }
   }
   undef;
}

sub oldINC { unshift @_, (shift(@_)->[1]); &Poly::Module::INC }

*INCluder= $^V lt v5.8 ? sub { [ \&oldINC, shift ] } : sub { shift };

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=shift;
   compiling_in(\%default::) == $equal
   or croak( "This declaration ",
	     $equal ? "is allowed only" : "is not allowed",
	     " on the application level (package default)" );
}

sub pkg_to_object_name{
   $_[0]->isa("Poly::Object")
   ? $_[0] =~ /::($id_re)$/ :
   $_[0]->isa("Visual::Object")
   ? $_[0]
   : Prototype();
}

1
