# 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: Customize.pm 7142 2006-03-02 09:37:17Z gawrilow $
use strict;
use namespaces;
require 'Poly/regex.pl';
require Poly::Tempfile;
package Poly::Customize;
use Enum qw( state: undefined saved default changed=4 config=8 config_changed=16 );
declare $default_configured_flag=0;
my $configured_var=0;
use Poly::Ext;
sub help2comment {
my ($text)=@_;
$text =~ s/^\s*$//mg;
$text =~ s/^/\# /mg;
enforce_nl($text) if length($text);
$text;
}
#################################################################################
package Poly::Customize::Var;
use Struct (
[ new => '$$;$' ],
[ '$name' => '#1' ],
[ '$state' => '#2' ],
[ '$help' => '#3' ],
'$appendix',
);
#################################################################################
package Poly::Customize::Scalar;
use Struct (
[ '@ISA' => 'Poly::Customize::Var' ],
[ '$saved_value' => 'undef' ],
[ '$default_value' => 'undef' ],
);
sub TIESCALAR {
my $self=is_object($_[0]) ? shift : _new(shift, undef, $configured_var|$state_saved);
$self->saved_value=$_[0];
$configured_var=$default_configured_flag;
$self;
}
sub re_tie {
my $self=shift;
no strict 'refs';
tie $ {$self->name}, $self, $ {$self->name};
}
sub un_tie {
my $self=shift;
no strict 'refs';
if ($self->state & $state_saved) {
untie $ {$self->name};
$ {$self->name}=$self->saved_value;
$self->state & $state_changed;
} else {
$self->state & $state_config
and defined( $self->saved_value=$ {$self->name} )
and $self->state |= $state_saved; # return TRUE enforcing the customization file to be rewritten
}
}
sub FETCH {
$_[0]->saved_value;
}
sub STORE {
my $self=$_[0];
if ($self->state & $state_config) {
$self->state |= $state_changed | $state_saved;
$self->saved_value=$_[1];
} else {
$self->default_value=$_[1];
}
}
sub new {
no strict 'refs';
my $self=tied ${$_[1]};
if ($self) {
$self->name=$_[1];
$self->help=$_[3];
} else {
$self=&_new;
if (defined ($self->default_value=$ {$self->name})) {
$self->state |= $state_default;
} elsif (!$self->state) {
croak( "undefined custom variable \$", $self->name );
}
}
$self;
}
sub set {
my $self=shift;
no strict 'refs';
if (@_) {
$ {$self->name}=$self->saved_value=$_[0];
} else {
$self->saved_value=$ {$self->name};
}
}
sub reset {
my $self=shift;
undef $self->saved_value;
no strict 'refs';
if ($self->state & $state_config) {
$self->state=$state_config;
undef $ {$self->name};
} else {
$self->state=$state_default;
$ {$self->name}=$self->default_value;
}
}
sub prefix { "\$" }
sub printable_value {
my $self=$_[0];
printable_scalar($self->state & $state_saved ? $self->saved_value : $self->default_value);
}
#################################################################################
package Poly::Customize::Array;
use Struct (
[ '@ISA' => 'Poly::Customize::Var' ],
'@saved_value',
'@default_value',
);
sub TIEARRAY {
my $self=is_object($_[0]) ? shift : _new(shift, undef, $configured_var|$state_saved);
@{$self->saved_value}=@{$_[0]};
$configured_var=$default_configured_flag;
$self;
}
sub re_tie {
my $self=shift;
no strict 'refs';
tie @{$self->name}, $self, \@{$self->name};
}
sub un_tie {
my $self=shift;
no strict 'refs';
if ($self->state & $state_saved) {
untie @{$self->name};
@{$self->name}=@{$self->saved_value};
$self->state & $state_changed;
} else {
$self->state & $state_config
and @{$self->saved_value}=@{$self->name}
and $self->state |= $state_saved; # return TRUE enforcing the customization file to be rewritten
}
}
sub FETCH {
$_[0]->saved_value->[$_[1]];
}
sub FETCHSIZE {
$#{$_[0]->saved_value}+1;
}
sub EXTEND {
my ($self, $n)=@_;
if ($self->state & $state_config) {
$self->state |= $state_changed | $state_saved;
$#{$self->saved_value}=$n-1;
} else {
$#{$self->default_value}=$n-1;
}
}
sub STORE {
my $self=$_[0];
($self->state & $state_config ? $self->saved_value : $self->default_value)->[$_[1]]=$_[2];
}
sub new {
no strict 'refs';
my $self=tied @{$_[1]};
if ($self) {
$self->name=$_[1];
$self->help=$_[3];
} else {
$self=&_new;
if (defined *{$self->name}{ARRAY}) {
@{$self->default_value}=@{$self->name};
$self->state |= $state_default;
} elsif (!$self->state) {
croak( "undefined custom variable \@", $self->name );
}
}
$self;
}
sub set {
my $self=shift;
no strict 'refs';
if (@_) {
@{$self->name}=@_;
@{$self->saved_value}=@_;
} else {
@{$self->saved_value}=@{$self->name};
}
}
sub reset {
my $self=shift;
undef @{$self->saved_value};
no strict 'refs';
if ($self->state & $state_config) {
$self->state=$state_config;
undef @{$self->name};
} else {
$self->state=$state_default;
@{$self->name}=@{$self->default_value};
}
}
sub prefix { '@' }
sub printable_value {
my $self=$_[0];
"( " .
join(", ", map { printable_scalar($_) }
@{ $self->state & $state_saved ? $self->saved_value : $self->default_value }) .
" )"
}
#################################################################################
package Poly::Customize::Hash;
use Struct (
[ '@ISA' => 'Poly::Customize::Var' ],
'%saved_value',
'%default_value',
);
sub TIEHASH {
my $self=is_object($_[0]) ? shift : _new(shift, undef, $configured_var|$state_saved);
%{$self->saved_value}=%{$_[0]};
$configured_var=$default_configured_flag;
$self;
}
sub re_tie {
my $self=shift;
no strict 'refs';
tie %{$self->name}, $self, \%{$self->name};
}
sub un_tie {
my $self=shift;
no strict 'refs';
if ($self->state & $state_saved) {
untie %{$self->name};
%{$self->name}=(%{$self->default_value}, %{$self->saved_value});
$self->state & $state_changed;
} else {
$self->state & $state_config
and do { %{$self->saved_value}=%{$self->name}; keys %{$self->saved_value} }
and $self->state |= $state_saved; # return TRUE enforcing the customization file to be rewritten
}
}
sub FETCH {
$_[0]->saved_value->{$_[1]};
}
sub STORE {
my $self=$_[0];
if ($self->state & $state_config) {
$self->state |= $state_changed | $state_saved;
$self->saved_value->{$_[1]}=$_[2];
} else {
$self->default_value->{$_[1]}=$_[2];
}
}
sub EXISTS {
exists $_[0]->saved_value->{$_[1]};
}
sub FIRSTKEY {
each %{$_[0]->saved_value};
}
*NEXTKEY=\&FIRSTKEY;
sub DELETE {
my $self=$_[0];
if ($self->state & $state_config) {
$self->state |= $state_changed;
delete $self->saved_value->{$_[1]};
} else {
delete $self->default_value->{$_[1]};
}
}
sub CLEAR {
my $self=$_[0];
if ($self->state & $state_config) {
$self->state |= $state_changed;
if (!$default_configured_flag) { # don't delete values from the user's file when merging with the system file
%{$self->saved_value}=();
}
} else {
%{$self->default_value}=();
}
}
sub new {
no strict 'refs';
my $self=tied %{$_[1]};
if ($self) {
$self->name=$_[1];
$self->help=$_[3];
} else {
$self=&_new;
if (defined *{$self->name}{HASH}) {
%{$self->default_value}=%{$self->name};
if (keys %{$self->default_value}) {
$self->state |= $state_default;
}
} elsif (!$self->state) {
die "undefined custom variable %", $self->name, "\n";
}
}
$self;
}
sub set {
my $self=shift;
no strict 'refs';
if (@_==0) {
%{$self->saved_value}=%{$self->name};
} elsif (@_==1) {
$self->saved_value->{$_[0]}=$self->name->{$_[0]};
} elsif (@_==2) {
$self->saved_value->{$_[0]}=$_[1];
$self->name->{$_[0]}=$_[1];
} else {
%{$self->saved_value}=@_;
%{$self->name}=@_;
}
}
sub reset {
my $self=shift;
no strict 'refs';
if (@_) {
foreach my $key (@_) {
delete $self->saved_value->{$key};
if (keys %{$self->saved_value}) {
if (exists $self->default_value->{$key}) {
$self->name->{$key}=$self->default_value->{$key};
} else {
delete $self->name->{$key};
}
}
}
} else {
undef %{$self->saved_value};
if ($self->state & $state_config) {
$self->state=$state_config;
undef %{$self->name};
} else {
$self->state=$state_default;
%{$self->name}=%{$self->default_value};
}
}
}
sub prefix { '%' }
sub printable_value {
my ($self)=@_;
my $h=$self->help;
( join("", map {
my $quoted= /\W/ ? "'$_'" : $_;
($self->state & $state_saved) && exists $self->saved_value->{$_}
? " $quoted => " . printable_scalar($self->saved_value->{$_}) . " ,"
: "# $quoted => " . printable_scalar($self->default_value->{$_}) . " ," ,
$h =~ s/^\s* $_ \s* => \s* (.*)$//xm
? " " . help2comment($1)
: "\n"
} sorted_uniq( sort keys %{$self->saved_value}, keys %{$self->default_value} )
) .
do {
my $rest="";
while ($h =~ s/^\s* (?: (\w+) | (['"])([^"']+)\2) (\s* => .*)$//xm) {
my ($key, $value)=($1 || $2.$3.$2, $4);
$rest .= help2comment(" $key $value");
}
$rest
},
help2comment($h)
);
}
sub printable {
my ($self)=@_;
my ($v, $h)=&printable_value;
$h .= "# \n" if $h =~ /^.*[^\#\s]\s*\E/m;
$h . &printable_decl . "(\n" . $v .
($self->state & ($state_saved | $state_config) ? "" : "# ") . ");\n"
}
#################################################################################
package Poly::Customize::Var;
# A custom variable is tied if it was loaded from the customization file.
# This way we can catch its default value which would otherwise overwrite
# the customized one.
my %prefix_dispatch=( "\$" => 'Poly::Customize::Scalar',
'@' => 'Poly::Customize::Array',
'%' => 'Poly::Customize::Hash' );
sub new {
$prefix_dispatch{substr($_[1],0,1)}->new(substr($_[1],1), $_[2] && $state_config, $_[3] || "undocumented");
}
sub full_name {
my $self=$_[0];
@_>1 && $self->name =~ /^$_[1]::/
? $self->prefix . $'
: $self->prefix . $self->name
}
sub CLEAR { } # precedes the initialization of array or hash, but everything is already prepared in TIE
#################################################################################
sub printable_scalar {
defined($_[0]) ? is_numeric($_[0]) ? $_[0] : "'$_[0]'" : "undef";
}
my $config_prefix= $main::Arch ? "CONFIGURED('$main::Arch') and\n" : "CONFIGURED and\n";
my $config_changed_prefix= $main::Arch ? "ARCH('$main::Arch') and\n" : "";
sub printable_decl {
my $self=$_[0];
( $self->state & $state_config_changed
? $config_changed_prefix :
$self->state & $state_config
? $config_prefix :
$self->state & $state_saved ? "" : "# " ) .
&full_name . "="
}
sub printable {
my $self=$_[0];
help2comment($self->help) . &printable_decl . $self->printable_value . ";\n"
}
#################################################################################
package Poly::Customize::perModule;
use Struct (
[ new => '$' ],
[ '$handler' => '#1' ],
'%per_pkg', # package_name->{"$var_name"}->Var
);
#################################################################################
sub add {
my ($self, $name, $help_text, $config_mode)=@_;
my ($pkg);
my $pkg_end=rindex($name, "::");
if ($pkg_end>=0) {
$pkg= $pkg_end>0 ? substr($name,1,$pkg_end-1) : "main";
} else {
$pkg=caller;
substr($name,1,0).="$pkg\::";
}
$help_text =~ s{^\#\s+}{}mg;
( $self->per_pkg->{$pkg}->{$name} &&= croak( "multiple definition of custom variable '$name'" ) )
||= new Var($name, $config_mode, $help_text);
}
#################################################################################
sub find {
my ($self, $name, $pkg)=@_;
my $pkg_end=rindex($name, "::");
if ($pkg_end>=0) {
$pkg= $pkg_end>0 ? substr($name,1,$pkg_end-1) : "main";
} else {
substr($name,1,0).="$pkg\::";
}
my $dict=$self->per_pkg->{$pkg};
$dict && $dict->{$name};
}
#################################################################################
sub set {
my ($self, $name)=splice @_, 0, 2;
if (defined (my $var=$self->find($name))) {
$var->state |= $state_saved | $state_changed | ($var->state & $state_config)<<1;
$var->set(@_);
$self->handler->need_save=1;
} else {
croak( "unknown custom variable $name" );
}
}
#################################################################################
sub reset {
my ($self, $name)=splice @_, 0, 2;
if (defined (my $var=$self->find($name))) {
$var->reset(@_);
$self->handler->need_save=1;
} else {
croak( "unknown custom variable $name" );
}
}
#################################################################################
sub re_tie {
my ($self, $state_mask)=@_;
foreach my $dict (values %{$self->per_pkg}) {
foreach my $var (values %$dict) {
$var->re_tie if ($var->state & $state_mask);
}
}
}
#################################################################################
sub un_tie {
my ($self, $state_mask)=@_;
$state_mask ||= $state_default | $state_saved | $state_config;
my $changed;
foreach my $dict (values %{$self->per_pkg}) {
foreach my $var (values %$dict) {
$changed |= $var->un_tie if ($var->state & $state_mask);
}
}
$self->handler->need_save ||= $changed;
}
#################################################################################
package Poly::Customize::File;
use Struct (
[ new => '$@' ],
[ '$filename' => '#1' ], # where to save custom variables
'%pieces', # package => file fragment
'$version', # version of polymake which has created this custom file
'$global_config', # time (UTC) when the global configuration files were last read
);
my $configured_arch=!$Switches::reconfigure && ($main::Arch || 1);
sub CONFIGURED {
@_ ? $_[0] eq $configured_arch : $configured_arch
and $configured_var=$state_config
}
sub ARCH {
$_[0] eq $main::Arch
and $configured_var=$state_config|$state_config_changed;
}
sub new {
my $self=&_new;
local $/;
my $filename=$self->filename;
open my $cf, $filename
or die "can't read customization file \"$filename\": $!\n";
my $text=<$cf>;
my $old_configure_style= $text =~ s/\bCONFIGURE:/CONFIGURED and/g;
(my $preamble, %{$self->pieces})=split /^\s* package \s+ ($qual_id_re) \s*; [ \t]*\n/mxo, $text;
foreach my $pkg (keys %{$self->pieces}) {
no strict 'refs';
*{$pkg."::CONFIGURED"}=\&CONFIGURED;
*{$pkg."::ARCH"}=\&ARCH;
}
my ($version, $global_config)=(v0.0, 0);
compile_start();
eval <<"_#_#_#_";
no namespaces; no strict 'vars';
#line 1 "$filename"
$text
1
_#_#_#_
compile_end();
if ($@) {
err_print( beautify_error() );
return;
}
$self->version=$version unless $old_configure_style; # enforce rewriting if old style
$self->global_config=$global_config;
foreach my $pkg (keys %{$self->pieces}) {
no strict 'refs';
unimport_function(*{$pkg."::CONFIGURED"});
unimport_function(*{$pkg."::ARCH"});
}
$self->pieces->{"^"}=$preamble if $main::Arch; # might need it only in multi-architecture installation
$self;
}
#################################################################################
package Poly::Customize;
use Struct (
'$file', # Poly::Customize::File
'@modules', # Module or Application
'$need_save', # boolean
'$global_files', # boolean: some global config files read
);
sub import {
if (@_<2) {
Carp::croak( "usage: use Customize \"filename\", ..." );
}
my $pkg=caller;
if (exists &{get_pkg($pkg)->{custom_handler}}) {
Carp::croak( "attempt to install multiple customization handlers in package \"$pkg\"" );
}
my $self=&_new;
my $user_filename=shift;
define_function($pkg, "custom_handler", sub { $self });
my $last_global_config=0;
if (-f $user_filename) {
if ($self->file=new File($user_filename)) {
$self->need_save= defined $main::Version && $self->file->version lt $main::VersionNumber;
if (($last_global_config=$self->file->global_config)>0) {
$self->global_files=1;
}
eval "END { \$self->save if \$self->need_save }";
} else {
return; # error in the user's custom file
}
} else {
$self->need_save=1;
eval "END { \$self->save(\$user_filename) }";
}
local $default_configured_flag=$state_config; # mark anything inherited from the global config files as 'configured'
foreach (@_) {
if (-f && (stat _)[9] > $last_global_config
and new File($_)) {
$self->global_files=1;
$self->need_save=1;
}
}
}
#################################################################################
# protected:
# before compiling the rules
sub begin_module {
my ($self, $module)=@_;
$self->need_save ||= !exists $self->file->pieces->{$module->pkg};
new perModule(weak($self));
}
#################################################################################
# protected:
# after compiling the rules
sub end_module {
my ($self, $module)=@_;
push @{$self->modules}, $module;
$module->custom->un_tie;
}
#################################################################################
my $preface=<<'.';
#########################################################################
#
# This file contains copies of all customizable variables
# scattered across the rule files.
#
# The assignments can stay commented out as long as you are satisfied
# with the default settings. To change them, either edit this file
# directly or call the user function 'set_custom'.
# To revert to the default values later, simply comment out
# the corresponding assignments or call the user function 'reset_custom'.
#
# Elements of hash arrays can be activated selectively,
# entries with default values may stay commented as long as needed.
# But don't forget the last line with the closing parenthesis!
#
# Be sure to edit this file only after you have finished the
# interactive polymake session, otherwise your changes can be lost.
#
# Some variables come from the rule autoconfiguration sections.
# Their assignments are guarded by the `CONFIGURED' condition.
# If you manually change some setting afterwards and want it to survive
# the `polymake --reconfigure' run, please remove this condition.
# If your change should take effect on one architecture only,
# change the word CONFIGURE to ARCH.
#
# Please be aware that this file is loaded as the very first,
# before any rule file. It gives the settings made here a chance
# to be compiled in the rule code.
# But you cannot refer here to any objects created in the course of parsing
# the rule files, e.g. applications, object types, or preference lists.
# Please use another file in this directory "prefer.pl" for these
# purposes.
#
#########################################################################
.
if (defined $main::Version) {
$preface .= <<".";
# The rule files are rescanned for new custom variables as soon as you
# run a polymake version newer than recorded here, or use an application
# for the first time.
# If you have introduced new custom variables in the rules and want them
# to appear here right now, comment out the following line and run polymake.
\$version=v$main::Version;
.
}
# dummy module for parsing the preamble
package Poly::Customize::Preamble;
sub custom { shift }
sub pkg { "" }
sub find { shift }
sub appendix : lvalue { $ {shift()} }
sub new { my $text=""; bless \$text; }
package Poly::Customize;
# private:
sub recycle_piece {
my ($module, $cf)=@_;
while (pos() < length()) {
/\G (?: ^\s*\n )+ /xmgc; # empty lines
my $start_comments=pos();
/\G (?: ^[ \t]* \#.*\n )+ /xmgc; # leading comments
if (/\G ^[ \t]* $assignment_re .*\n /xomgc) {
# unconditional assignment - either stored in the module's dictionary or obsolete
next;
}
my $print_nl="";
my $start_stmt=pos();
while (/\G ^[ \t]* (?:CONFIGURED|ARCH) (?: \((['"]) (.*?) \1\) )? \s*and\s*
^[ \t]* $assignment_re .*\n /xomgc) {
my ($arch, $varname)=($2, $3);
if (index($varname, "::")<0) {
substr($varname,0,1) .= $module->pkg . "::";
}
if (my $var=$module->custom->find($varname)) {
if ($arch and $arch ne $main::Arch) {
# value configured for other architecture
$var->appendix .= substr($_,$start_stmt,pos()-$start_stmt);
}
} else {
# unknown configuration variable - it might stem from a rulefile with failed autoconfiguration;
# it should be kept in the file in order to give a chance for manual change and reconfiguration
print $cf substr($_,$start_comments,pos()-$start_comments);
$print_nl="\n";
}
$start_comments=$start_stmt=pos();
}
print $cf $print_nl;
if (/\G ^[ \t]* [^\#\s] .* \n/xmgc) {
warn_print( "suspicious code in custom file: ", $& );
print $cf $&;
}
}
}
my $sep_line="########################\n";
sub save {
my ($self, $filename)=@_;
unless (defined($filename)) {
die "no customization file to save\n" unless $self->file;
$filename=$self->file->filename;
}
my $tempfile=new OverwriteFile($filename);
open my $cf, ">", $tempfile
or die "can't create temporary file \"$filename\" for user settings: $!\n";
print $cf $preface;
my $pieces=$self->file && $self->file->pieces;
local $_=$pieces && delete $pieces->{"^"};
if ($self->global_files) {
print $cf <<".";
# When the global configuration files were read the last time:
$config_prefix\$global_config=$^T;
.
if ($_) {
my $p=new Preamble();
recycle_piece($p, $cf);
print $cf $p->appendix;
}
print $cf "\n";
}
foreach my $module (@{$self->modules}) {
my ($tree, $mod_pkg, $hh)=($module->custom->per_pkg, $module->pkg, $module->help);
print $cf $sep_line, "package $mod_pkg;\n\n";
if ($pieces and $_=delete $pieces->{$mod_pkg}) {
recycle_piece($module, $cf);
}
foreach my $pkg (sort { $a eq $mod_pkg ? -1 : $b eq $mod_pkg ? 1 : $a cmp $b } keys %$tree) {
if (defined (my $pkg_help=$hh->get([ 'customize', $pkg ]))) {
print $cf help2comment($pkg_help), "\n";
}
while (my ($name, $var)=each %{$tree->{$pkg}}) {
print $cf $var->printable($mod_pkg), $var->appendix, "\n";
$var->state &= ~$state_changed;
}
}
}
if ($pieces) {
while (my ($pkg, $orphan)=each %$pieces) {
print $cf "package $pkg;\n", $orphan;
}
}
close $cf;
$self->need_save=0;
}
1
syntax highlighted by Code2HTML, v. 0.9.1