# 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
syntax highlighted by Code2HTML, v. 0.9.1