# Copyright (c) 1997-2006
# Ewgenij Gawrilow, Michael Joswig (Technische Universitaet Berlin, Germany)
# http://www.math.tu-berlin.de/polymake, mailto:polymake@math.tu-berlin.de
#
# This program is free software; you can redistribute it and/or modify it
# under the terms of the GNU General Public License as published by the
# Free Software Foundation; either version 2, or (at your option) any
# later version: http://www.gnu.org/licenses/gpl.txt.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#-----------------------------------------------------------------------------
# $Project: polymake $$Id: Struct.pm 7540 2006-12-21 21:04:18Z gawrilow $
use integer;
use strict;
use Poly;
use namespaces 'Poly';
package Struct;
use Poly::Ext;
use Carp;
$Carp::Internal{Struct}=1;
sub import {
shift; # drop the own package name
my $cnt=0;
my ($pkg, $file, $line)=caller(0);
if (my $def=$pkg->can(".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 $merger="";
my ($signature, $own_signature, $check_arg, $min_arg, $max_arg, $keyed_args, %keys, $keys_changed, $trailing_list,
$super, $super_symtab, $redefine, $merge_seen);
my $with_namespaces=namespaces::uses($pkg);
my $prologue="use strict;\n" . (!$with_namespaces && "no namespaces;\n") . "package $pkg";
while (ref($_[0])) {
if ($_[0]->[0] eq '@ISA') {
my $isa=shift;
shift @$isa;
{ no strict 'refs';
@{"$pkg\::ISA"}=@$isa; }
foreach my $s (@$isa) {
if (defined (my $super_constructor=UNIVERSAL::can($s, ".constructor"))) {
$super=$s;
($cnt, $constructor, $constructor_deferred, $merger)=$super_constructor->();
if (!$own_signature && defined (my $super_signature=UNIVERSAL::can($super, ".signature"))) {
($signature, $min_arg, $max_arg, $trailing_list)=$super_signature->();
}
if (my $k=UNIVERSAL::can($s, ".keys")) {
$keyed_args=1;
%keys=%{$k->()};
}
$redefine=1;
if ($with_namespaces && namespaces::uses($super)) {
namespaces::using($pkg, $super);
}
$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=$4 && $max_arg;
if (defined $2) {
if (!$4) {
$check_arg .= ($min_arg>0 && " or ") ."\@_ > $max_arg";
}
} elsif ($3) {
$keyed_args=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 $accessor=UNIVERSAL::can($pkg,$name);
if (defined($redefine)) {
if (!defined($accessor) || ($redefine=get_field_index($accessor))<0) {
undef $redefine; # new field or an occasionaly overwritten non-field method
}
} elsif (get_field_index($accessor)>=0) {
croak "multiple definition of field $name";
}
my @aliases=split /\s*\|\s*/, $name;
my ($kname, $get_kname);
if ($keyed_args) {
if (@aliases>1) {
$kname='$kname';
$get_kname=<<"_#_#_#_";
do {
undef \$kname;
exists \$kw{\$_} and (\$kname=\$_, last) for (qw(@aliases))
}
_#_#_#_
} else {
$kname="'$name'";
$get_kname="exists \$kw{$name}";
}
}
my ($key_in_expr, $set_filter, $set_filter_is_method, $init_deferred, $merge_expr);
my $deflt=$code eq '@' ? "[]" :
$code eq '%' ? "{}" :
$code eq '&' ? "undef" :
"''";
my $add_to_keys=$keyed_args;
my $init=
ref($field)
? $field->[1] eq '##'
? do {
croak "unexpected options for the uninitialized field $name" if $#$field>1;
undef $get_kname; $add_to_keys=-1;
$deflt
} :
$field->[1] eq '@'
? do {
if (defined($trailing_list)) {
croak "unexpected options for the trailer-initialized field $name" if $#$field>1;
undef $get_kname; $add_to_keys=-1;
$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];
my %options=splice @$field, 2;
$init_deferred=$set_filter_is_method= $expr =~ /(?<!\\)\$this\b/;
if ($expr =~ s{(?: (?<=^) | (?<=[\s,(])) \#(?:([\d+]) | (%)) (?= $ | [\s,)])}
{ $2 ? $keyed_args ? ($key_in_expr=1, "$kname, #%") : croak("constructor has no keyword arguments")
: $1<$max_arg
? ($add_to_keys=-1, "\$_[$1]")
: croak("constructor argument #$1 out of range") }egx) {
if ($key_in_expr) {
if (defined (my $default_arg=delete $options{default})) {
$init_deferred ||= $default_arg =~ /(?<!\\)\$this\b/;
($deflt=$expr) =~ s/\#%/$default_arg/g;
}
$expr =~ s/\#%/delete \$kw{$kname}/g;
$expr = "$get_kname ? ($expr) : Struct::mark_as_default($deflt)";
}
if (defined (my $merge_arg=delete $options{merge})) {
$merge_arg =~ s/\#%/$kname, delete \$kw{$kname}/;
$merge_expr="$get_kname and $merge_arg";
$merge_seen=1;
}
undef $get_kname;
}
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;
}
$expr
}
: $deflt;
if ($get_kname) {
$init="$get_kname ? delete \$kw{$kname} : Struct::mark_as_default($init)";
}
if ($init_deferred) {
$init_deferred=$init;
$init="undef";
}
if ($add_to_keys>0) {
@keys{@aliases}=();
$keys_changed=1;
} elsif ($add_to_keys<0 && $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)) {
use re 'eval';
if ($redefine) {
my $prev=$redefine-1;
$constructor =~ /\#\#\#<$prev>\n/s;
pos($constructor)=$+[0];
}
$constructor =~ s/\G .*? (?= ,\s*\#\#\#<$redefine>\n)/$init/xs;
if ($init_deferred) {
$constructor_deferred =~ s{(^ | \#\#\#<(\d+)>\n) (?(?{ $2!=$redefine }) .*? | (?!.)) (?= ;\s*\#\#\#<$redefine>\n)}
{$1\$this->[$redefine]=$init_deferred}xs
or
$constructor_deferred .= "\$this->[$redefine]=$init_deferred; ###<$redefine>\n";
} elsif ($constructor_deferred) {
$constructor_deferred =~ s/(^ | \#\#\#<(\d+)>\n) (?(?{ $2!=$redefine }) .*? | (?!.)) ;\s*\#\#\#<$redefine>\n/$1/xs;
}
if ($set_filter || defined(${$super_symtab->{$aliases[0]}})) {
$accessor=create_accessor($redefine, $code eq '&');
define_function($symtab, $_, $accessor) for @aliases;
${$symtab->{$aliases[0]}}=$set_filter;
}
if ($merge_expr) {
$merger =~ s/(^ | \#\#\#<(\d+)>\n) (?(?{ $2!=$redefine }) .*? | (?!.)) (?= ;\s*\#\#\#<$redefine>\n)/$1$merge_expr/xs
or
$merger .= "$merge_expr; ###<$redefine>\n";
}
} else {
$constructor .= "$init, ###<$cnt>\n";
if ($init_deferred) {
$constructor_deferred .= "\$this->[$cnt]=$init_deferred; ###<$cnt>\n";
}
$accessor=create_accessor($cnt, $code eq '&');
define_function($symtab, $_, $accessor) for @aliases;
if ($set_filter) {
${$symtab->{$aliases[0]}}=$set_filter;
}
if ($merge_expr) {
$merger .= "$merge_expr; ###<$cnt>\n";
}
++$cnt;
}
}
if (@_ || $own_signature) {
my $new_text= <<"_#_0_#_";
$prologue;
sub {
_#_0_#_
if ($keyed_args) {
$new_text .= <<"_#_1_#_";
my (%kw,\$kname);
_#_1_#_
if (defined($trailing_list)) {
$new_text .= <<"_#_2_#_";
my \@trailing_list;
for (my \$i=$max_arg; \$i<=\$#_; ) {
if (Poly::is_hash(\$_[\$i])) {
push %kw, %{\$_[\$i++]};
} elsif (!ref(\$_[\$i]) && exists \$keys{\$_[\$i]}) {
\$kw{\$_[\$i]}=\$_[\$i+1];
\$i+=2;
} else {
\@trailing_list=splice \@_, \$i;
last;
}
}
_#_2_#_
} else {
$new_text .= <<"_#_3_#_";
for (my \$i=$max_arg; \$i<=\$#_; ) {
if (Poly::is_hash(\$_[\$i])) {
push %kw, %{\$_[\$i++]};
} else {
\$kw{\$_[\$i]}=\$_[\$i+1];
\$i+=2;
}
}
_#_3_#_
}
}
if ($check_arg) {
$new_text .= <<"_#_4_#_";
if ($check_arg) {
Poly::croak( "usage: new \$_[0] (" . '$signature' . ")" );
}
_#_4_#_
}
if ($keyed_args) {
$new_text .= <<"_#_5_#_";
my \$this=Poly::inherit_class( Struct::start_compile_constructor(), [
$constructor
], shift);
$constructor_deferred
if (keys %kw) {
Poly::croak( ref(\$this), "::new - unknown keywords: ", join(", ", keys %kw) );
}
\$this
_#_5_#_
} else {
$new_text .= <<"_#_8_#_";
Poly::inherit_class([
$constructor
], shift);
_#_8_#_
}
$new_text .= <<"_#_9_#_";
}
_#_9_#_
my $_new=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: $@";
}
define_function($symtab, "__new", $_new);
if ($merge_seen) {
my $merge_text=<<"_#_#_#_";
$prologue;
sub {
my (\$this, %kw)=\@_;
my \$kname;
$merger
if (keys %kw) {
Poly::croak( ref(\$this), "::merge - unknown or non-mergeable field(s): ", join(", ", keys %kw) );
}
\$this
}
_#_#_#_
my $_merge=eval $merge_text;
if ($@) {
my @lines=(undef, split /(?:\#\#\#<\d+>)?\n/, $new_text);
$@ =~ s/at \(eval \d+\) line (\d+)/near line $1: '$lines[$1]'/g;
croak "syntax error in $pkg\::merge: $@";
}
define_function($symtab, "merge", $_merge);
}
} 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_list) }) 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) {
# 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")} }
1;
syntax highlighted by Code2HTML, v. 0.9.1