#  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