#  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: Preference.pm 7188 2006-03-10 11:51:32Z gawrilow $

use strict;
use namespaces;
use integer;

####################################################################################

package Poly::Preference::Label;

use Struct (
   [ new => '$;$$$$$' ],
   [ '$name' => '#1' ],
   [ '$parent' => '#3' ],	# Label higher in the hierarchy
   [ '$wildcard_name' => '#4 || "*"' ],
   '%children',			# Labels lower in the hierarchy
   '%controls',			# control list -> number of items in this list
   [ '$clock' => '#5' ],	# sequential number of the last 'prefer' command
   [ '$rank' => '#6' ],		# rank in this command
   [ '$id' => '#2' ],		# from perModule object which has defined this label
);

# Structure of a control list:
# for i=0..#{involved Labels}-1
#   [i*2]   -> stored item
#   [i*2+1] -> Label
# [-1]  -> order count: number of leading items which are known to be ordered due to
#          the active preferences. The trailing items are in arbitrary order.
#          Thus, a control list without any active preferences applied has
#          the order count == 0.

####################################################################################
sub child {
   my ($self, $name, $id)=@_;
   $self->children->{$name} ||=
      new Label( $name, $id, weak($self), $self->wildcard_name.".$name", $self->clock, $self->rank );
}
####################################################################################
sub add_control {
   my ($self, $list, $item)=@_;
   ++$self->controls->{$list};
   if (@$list) {
      my $pos=-1;
      if (defined($self->clock)) {
	 if ($list->[-1]==0  or
	     (my $clock_diff=$list->[1]->clock - $self->clock) < 0) {
	    $pos=0;
	    $list->[-1]=2;
	 } elsif ($clock_diff==0) {
	    for ($pos=0;
		 $pos<$list->[-1] && $list->[$pos+1]->rank <= $self->rank;
		 $pos+=2) { }
	    $list->[-1]+=2;
	 }
      }
      splice @$list, $pos, 0, $item, $self;
   } else {
      @$list=($item, $self, defined($self->clock)*2);
   }
}
####################################################################################
sub register_copy {
   my ($new, $old)=@_;
   for (my $i=1; $i<$#$old; $i+=2) {
      ++($old->[$i]->controls->{$new});
   }
}
####################################################################################
sub dup_control {
   my ($list)=@_;
   my @new_list=@$list;
   register_copy(\@new_list, $list);
   \@new_list;
}
####################################################################################
sub copy_control {
   my ($new, $old)=@_;
   @$new=@$old;
   register_copy($new, $old);
   $new;
}
####################################################################################
sub merge_controls {
   my ($dst, $src)=@_;
   register_copy($dst, $src);

   if (!$src->[-1]  ||
       $dst->[-1] && $dst->[1]->clock > $src->[1]->clock) {
      # src unordered - attach to the tail
      splice @$dst, -1, 0, @$src[0..$#$src-1];

   } elsif (!$dst->[-1]  ||
	    $src->[-1] && $dst->[1]->clock < $src->[1]->clock) {
      # dst unordered - push the new items to the front
      splice @$dst, 0, 0, @$src[0..$#$src-1];
      $dst->[-1]=$src->[-1];

   } else {
      # both ordered: merge carefully
      my $dord=$dst->[-1];
      my ($s, $d);
      for (($s,$d)=(1,1);  $s<$src->[-1] && $d<$dord;  $d+=2) {
	 if ($dst->[$d]->rank > $src->[$s]->rank) {
	    splice @$dst, $d-1, 0, @$src[$s-1,$s];
	    $s+=2;
	    $dord+=2;
	 }
      }
      $dst->[-1]+=$src->[-1];
      # insert the unordered rest
      splice @$dst, $dord, 0, @$src[$s-1..$#$src-1];
   }
}
####################################################################################
sub forget_control {
   my $list=shift;
   for (my $i=1; $i<$#$list; $i+=2) {
      delete $list->[$i]->controls->{$list};
   }
}
####################################################################################
sub describe_control_item {
   my $item=shift;
   if (is_code($item)) {
      $item=$item->() if sub_file($item) =~ m|Poly/Overload\.pm$|;
      (is_method($item) ? "method " : "sub ").method_owner($item)."::".method_name($item)."(".prototype($item).")"
   } else {
      "rule of ".method_owner($item->code)->prototype->name." ".$item->header." from ".sub_file($item->code)." line ".sub_firstline($item->code);
   }
}
####################################################################################
# return all items from a control list, removing duplicates
sub get_items {
   my $list=shift;
   my (%seen, @items);
   for (my $i=0; $i<$#$list; $i+=2) {
      push @items, $list->[$i] unless $seen{$list->[$i]}++;
   }
   @items;
}
####################################################################################
# return the items from a control list, sorted by rank
# each bag starts with the rank value
# the last bag always contains unordered items (and rank is undef)
sub get_items_by_rank {
   my $list=shift;
   my (%seen, @bags);
   my $i;
   for ($i=0; $i<$list->[-1]; $i+=2) {
      my $cur_rank=$list->[$i+1]->rank;
      if (!@bags) {
	 push @bags, [ $cur_rank ];
      } elsif (@{$bags[-1]}==0) {
	 $bags[-1]->[0]=$cur_rank;
      } elsif ($bags[-1]->[0]<$cur_rank) {
	 push @bags, [ $cur_rank ];
      }
      push @{$bags[-1]}, $list->[$i] unless $seen{$list->[$i]}++;
   }
   if ($i<$#$list) {
      if (!@bags || @{$bags[-1]}>1) {
	 push @bags, [ undef ];
      } else {
	 undef $bags[-1]->[0];
      }
      for (; $i<$#$list; $i+=2) {
	 push @{$bags[-1]}, $list->[$i] unless $seen{$list->[$i]}++;
      }
   }
   @bags;
}
####################################################################################
# clock, rank =>
sub set_preferred {
   my $self=shift;
   my @out_of_effect;
   if (defined $self->clock) {
      if ($self->clock==$_[0]) {
	 die $self->full_name, " occurs in the preference list at positions ", $self->rank, " and $_[1]\n";
      }
      push @out_of_effect, $self->clock;
   }
   ($self->clock, $self->rank)=@_;

 CONTROLS:
   while (my ($list, $cnt)=each %{$self->controls}) {
      if ($list->[-1]) {
	 my $clock_cmp=$list->[1]->clock <=> $self->clock;
	 if ($clock_cmp<0) {
	    # obsolete
	    push @out_of_effect, $list->[1]->clock;
	    $list->[-1]=0;
	 } elsif ($clock_cmp>0) {
	    push @out_of_effect, $self->clock;
	    next CONTROLS;
	 } elsif ($list->[1]==$self) {
	    # kept his position
	    $list->[-1]=2*$cnt;
	    next CONTROLS;
	 }
      }
      my $new_pos=$list->[-1]+1;
      $list->[-1]+=2*$cnt;
      for (my $pos=$new_pos; $pos < $#$list; $pos+=2) {
	 if ($list->[$pos] == $self) {
	    if ($pos != $new_pos) {
	       splice @$list, $new_pos-1, 0, splice @$list, $pos-1, 2;
	    }
	    next CONTROLS unless --$cnt;
	    $new_pos+=2;
	 }
      }
      confess( "corrupted control list for label ", $self->full_name );
   }

   (@out_of_effect, map { $_->set_preferred(@_) } values %{$self->children});
}
####################################################################################
sub neutralize_controls {
   my ($self, $deep)=@_;
   my %warned;
   foreach my $list (keys %{$self->controls}) {
      if ($list->[-1]>0 && $list->[1]==$self) {
	 if (!$warned{$list->[0]}++) {
	    warn_print( describe_control_item($list->[0]), " is still the default choice" );
	 }
	 $list->[-1]=0;
      }
   }

   if ($deep) {
      foreach my $c (values %{$self->children}) {
	 neutralize_controls($c, $deep);
      }
   }
}
####################################################################################
sub set_temp_preferred {
   my ($self, $scope)=@_;
   while (my ($list, $cnt)=each %{$self->controls}) {
      next if $#$list == $cnt*2; 	# no competitors
      my @temp_list=@$list;
      $temp_list[-1]=0;
      for (my $i=1;  $i<$#temp_list;  $i+=2) {
	 if ($list->[$i] == $self) {
	    if ($i-1 != $temp_list[-1]) {
	       # put the controlled item in the first position
	       splice @temp_list, $temp_list[-1], 0, splice @temp_list, $i-1, 2;
	    }
	    $temp_list[-1]+=2;
	    last unless --$cnt;
	 }
      }
      if ($Switches::v>=2) {
	 dbg_print( $self->full_name, " temporarily preferred over ",
		    join(", ", map { $temp_list[$_*2+1]->full_name } $self->controls->{$list}..($#temp_list/2-1)) );
      }
      confess( "corrupted control list for label ", $self->full_name ) if $cnt;
      $scope->begin_locals;
      local_array($list, \@temp_list);
      local_scalar($self->rank, 0);
      $scope->end_locals;
   }

   foreach my $c (values %{$self->children}) {
      $c->set_temp_preferred($scope);
   }
}
####################################################################################
sub full_name {
   my $self=shift;
   my $n=$self->name;
   while (defined($self=$self->parent)) {
      $n=$self->name.".$n";
   }
   $n
}

sub parent_name {
   my $self=shift;
   $self=$self->parent while defined($self->parent);
   $self->name
}
####################################################################################
#
#  Subtraction of preference lists

# => 1 - nothing more in effect
# => 0 - partially (not all controls or not all children)
# => 2 - fully
sub status {
   my ($self)=@_;
   my $status=3;
   foreach my $list (keys %{$self->controls}) {
      $status &= ($list->[-1]>0 && $list->[1]->clock==$self->clock) ? 2 : 1
      or return 0;
   }

   foreach my $c (values %{$self->children}) {
      $status &= status($c)
      or last;
   }

   $status
}
####################################################################################
sub add_to_pref_tree {
   my ($self, $list)=@_;
   if (is_ARRAY($list)) {
      push @$list, $self;
   } else {
      while (my ($name, $c)=each %{$self->children}) {
	 if (!exists $list->{$name} || is_ARRAY($list->{$name})) {
	    push @{$list->{$name}}, $c;
	 } elsif ($list->{$name}) {
	    add_to_pref_tree($c, $list->{$name});
	 }
      }
   }
}
####################################################################################
sub subtract {
   my ($self, $clock, $new_wildcard, $wildcard_cmp, $tree)=@_;

   if ($self->clock != $clock) {
      # already involved in the new pref list - nothing to do
      return;
   }

   if (defined (my $subtree=$tree->{$self->name})) {
      if ($subtree) {
	 # positive result already known
	 add_to_pref_tree($self, $subtree);
      } else {
	 # negative result already known
	 neutralize_controls($self, 1);
      }
      return;
   }

   if ($wildcard_cmp<=0  and
       ($wildcard_cmp=prefix_cmp($self->wildcard_name, $new_wildcard)) == 2) {
      # no intersection with new pref list - remains in effect
      $tree->{$self->name}=[ $self ];
      return;
   }

   my $status=status($self);
   if ($status & 1) {
      # completely out of control
      $tree->{$self->name}=0;
      neutralize_controls($self, 1);

   } elsif ($status) {
      if ($wildcard_cmp>0) {
	 # this branch has survived
	 $tree->{$self->name}=[ $self ];
      }

   } else {
      # injured - handle children individually
      my $subtree=$tree->{$self->name}={ };
      neutralize_controls($self);
      subtract($_, $clock, $new_wildcard, $wildcard_cmp, $subtree) for values %{$self->children};
   }
}
####################################################################################

package Poly::Preference::List;

use Struct (
   [ new => '$$' ],
   [ '$clock' => '#1' ],
   [ '$mask' => '0' ],
   [ '@labels' => '#2' ],
);

sub new {
   my $self=&_new;
   $self->mask |= $_->id for @{$self->labels};
   $self;
}

sub activate {
   my $self=shift;
   my $rank=0;
   map { $_->set_preferred($self->clock, $rank++) } @{$self->labels};
}
####################################################################################
sub compare {
   my ($p1, $p2)=@_;
   my $l=$#{$p1->labels};
   return 2 if $l != $#{$p2->labels};
   my $result=0;
   for (my $i=0; $i<=$l; ++$i) {
      if ($p1->labels->[$i] != $p2->labels->[$i]) {
	 my $cmp=prefix_cmp($p1->labels->[$i]->full_name, $p2->labels->[$i]->full_name);
	 return 2 if $cmp==2  or  $result && $result != $cmp;
	 $result=$cmp;
      }
   }
   $result;
}
####################################################################################
sub subtract {
   my ($self, $new_wildcard)=@_;
   my (@result, %tree);
   $_->subtract($self->clock, $new_wildcard, -1, \%tree) for @{$self->labels};
   my @sublists=values %tree;
   for (my $i=0; $i<=$#sublists; ++$i) {
      my $list=$sublists[$i];
      if (is_ARRAY($list)) {
	 push @result, new List($self->clock, $list);
      } elsif ($list) {
	 push @sublists, values %$list;
      }
   }
   @result;
}
####################################################################################
sub toString {
   my $self=shift;
   if (@{$self->labels}==1) {
      '"'.$self->labels->[0]->full_name.'"'
   } else {
      '"' . $self->labels->[0]->wildcard_name . " " . join(", ", map { $_->parent_name } @{$self->labels}) . '"'
   }
}
####################################################################################

package Poly::Preference::perModule;

my $id_cnt=0;
my $clock=100000;
my $compile_clock=0;

use Struct (
   '$id',
   '$mask',
   '$handler',
   '%labels',
   '@super',
   '@default_prefs',
);

sub new {
   my $self=&_new;
   $self->id=$self->mask=1 << $id_cnt++;
   $self;
}
####################################################################################
sub add_label {
   my ($self, $name)=@_;
   ( $self->labels->{$name} &&=
     croak( "multiple definition of label $name" ) ) ||=
   new Label($name, $self->id);
}
####################################################################################
sub find_label {
   my ($self, $name, $create)=@_;
   my @name=split /\./, $name;
   $name=shift @name;
   my $label=$self->labels->{$name};
   if (!$label) {
      foreach my $super (@{$self->super}) {
	 $label=$super->labels->{$name}  and  last;
      }
      return undef unless $label;
   }
   foreach $name (@name) {
      $label= $create ? $label->child($name, $self->id) : $label->children->{$name}
      or return undef;
   }
   $label;
}
####################################################################################
# $compile_mode & 1 => allow to create new sublevels
# $compile_mode & 2 => 'prefer' command comes from the rules
# $compile_mode & 4 => 'prefer' command comes from the preference file
sub add_preference {
   my ($self, $expr, $compile_mode)=@_;
   my (@err, @l);

   # parse the labels
   if ($expr =~ /^ $hier_id_re $/xo) {
      if (defined (my $label=$self->find_label($expr, $compile_mode & 1))) {
	 @l=($label);
      } else {
	 push @err, $expr;
      }
   } elsif (my ($sublevel, $list)= $expr =~ /^ \*\.($hier_id_re) \s+ ($hier_ids_re) $/xo) {
      @l=map { $self->find_label("$_.$sublevel", $compile_mode & 1) or
	       push @err, "$_.$sublevel"
	 } split /\s*,\s*/, $list;
   } else {
      croak( "syntax error in preference list" );
   }

   if (@err) {
      if ($compile_mode & 4 and $main::Arch) {
	 warn_print( "stored preference statements for label", @err>1 && "s", " @err\n",
		     "are not in effect - probably excluded by auto-configuration" ) if $Switches::v;
      } else {
         croak( "unknown label", @err>1 && "s", " @err" );
      }
   }

   my $pref=new List($compile_mode & 2 ? ++$compile_clock : ++$clock, \@l);

   if ($compile_mode & 2) {
      push @{$self->default_prefs}, $pref;
      return;
   }

   if ($compile_mode & 4) {
      push @{$self->handler->active_prefs}, $pref;
      $pref->activate;

   } else {
      if (!$compile_mode) {
	 foreach my $p2 (@{$self->handler->active_prefs}) {
	    my $cmp=$p2->compare($pref);
	    if ($cmp <= 0) {
	       warn_print( "preference list ", $pref->toString, " ignored since another list ", $p2->toString, " is already in effect" );
	       return;
	    } elsif ($cmp==1) {
	       # has absorbed some existing preference list - can't have duplicates
	       last;
	    }
	 }
      }
      $self->handler->activate(0,$pref);
   }
}
####################################################################################
sub set_temp_preference {
   my ($self, $scope, $expr)=@_;
   if ($expr =~ /^ $hier_ids_re $/xo) {
      if (defined (my $label=$self->find_label($expr, 0))) {
	 $label->set_temp_preferred($scope);
      } else {
	 croak( "unknown label $expr" );
      }
   } else {
      croak( "syntax error in label name" );
   }
}
####################################################################################
sub matching_default_prefs {
   my ($self, $expr)=@_;
   my @matched;
   if ($expr =~ /^ $hier_id_re $/xo) {

      if (defined (my $label=$self->find_label($expr, 0))) {
	 foreach my $pm (@{$self->super}, $self) {
	    if ($label->id & $pm->mask) {
	       foreach my $pref (@{$pm->default_prefs}) {
		  if ($pref->labels->[0] == $label) {
		     return $pref;
		  } elsif ((my $cmp=prefix_cmp($expr, $pref->labels->[0]->full_name))==-1) {
		     push @matched, $pref;
		  } elsif ($cmp==1) {
		     return new List(++$clock, [ $label ]);
		  }
	       }
	    }
	 }
      } else {
	 croak( "unknown label $expr" );
      }

   } elsif ($expr =~ /^ \*\.$hier_id_re $/xo) {

      foreach my $pm (@{$self->super}, $self) {
	 foreach my $pref (@{$pm->default_prefs}) {
	    my $cmp=prefix_cmp($expr, $pref->labels->[0]->wildcard_name);
	    if ($cmp==0) {
	       return $pref;
	    } elsif ($cmp==-1) {
	       push @matched, $pref;
	    } elsif ($cmp==1) {
	       my @sublevel=split /\./, substr($expr, length($pref->labels->[0]->wildcard_name)+1);
	       my @sublabels=map {
				my $l=$_;
				foreach my $s (@sublevel) {
				   $l=$l->children->{$s} or last;
				}
				defined($l) ? $l : ();
			     } @{$pref->labels};
	       if (@sublabels) {
		  return new List(++$clock, \@sublabels);
	       }
	    }
	 }
      }

   } else {
      croak( "syntax error in label name" );
   }
   @matched;
}

sub reset {
   if (my @prefs=&matching_default_prefs) {
      $_[0]->handler->activate(1,@prefs);
   } else {
      croak( "no default preferences matching $_[1]" );
   }
}
####################################################################################
sub end_compile_mode {
   my ($self, $module)=@_;
   my $key=do { ref($module) =~ /([^:]+)$/; lc($1) } . " " . $module->name;
   if (my $ph=$module->can("prefs_handler")) {
      $ph=$ph->();
      if (!$self->handler) {
	 $self->handler=weak($ph);
	 push @{$ph->modules}, $module;
      }

      my $text=delete $ph->orphans->{$key};
      my @stored_prefs;
      push @stored_prefs, $2 while ($text =~ s/^[ \t]* prefer \s+ (['"])?(.*?)(?(1)\1) [ \t]* ;? (?= \s*$ )//xm);

      if ($ph->version_bumped) {
	 $ph->activate(0,@{$self->default_prefs});
	 foreach my $pref (@stored_prefs) {
	    add_preference($self, $pref, 1);
	 }

      } elsif (@stored_prefs) {
	 foreach my $pref (@stored_prefs) {
	    add_preference($self, $pref, 5);
	 }

      } elsif (!defined($text)) {
	 # prefer.pl was probably deleted
	 foreach my $pref (@{$self->default_prefs}) {
	    push @{$ph->active_prefs}, $pref;
	    $pref->activate;
	    $ph->need_save=1;
	 }
      }

      if ($text =~ $significant_line_re) {
	 local $Poly::User::application=$module;
	 Poly::Shell::eval_expr($text);
	 if ($@) {
	    die $@;
	 } else {
	    $ph->user_commands->{$key}=$text;
	 }
      }
   }
   $self;
}
####################################################################################
sub inherit {
   my $self=shift;
   my %seen;
   foreach my $s (@_) {
      ++$seen{$s};
      ++$seen{$_} for (@{$s->super});
      $self->mask |= $s->mask;
   }
   push @{$self->super}, grep { --$seen{$_}==0 } @_, map { @{$_->super} } @_;
}
####################################################################################

package Poly::Preference;

use Struct (
   [ new => '$' ],
   [ '$file' => '#1' ],		# where to save preference lists
   '@modules',			# Module or Application
   '%orphans',			# package => file fragment
   '%user_commands',		# package => perl text
   '$version_bumped',		# boolean
   '$need_save',		# boolean
   '@active_prefs',
);

my $sep_line="\n#########################################\n";

my $preface=<<'.';
#########################################################################
#
#  This file contains preference settings that were in effect
#  as you closed your last polymake session.
#
#  Initially it contains copies of "prefer" commands scattered over the
#  rule files.  They are commented out, since they come into action
#  as soon as the rule files are loaded.
#
#  Later on, each interactive "prefer" command you type in the polymake
#  shell is also recorded here, in the chronological order.
#  Prior commands having lost any effect are wiped out from the file
#  automatically.
#
#  You can also edit this file manually, including or deleting "prefer"
#  commands, or even other commands recognized by the interactive shell.
#  But never edit it while polymake processes are running, otherwise
#  you risk to do it in vain, all your changes may be overwritten.
#
#  To revert to the default preferences later, comment out or delete
#  your changes, or execute the interactive command 'reset_preference'.
#
#  Please be aware that this file is interpreted by polymake after all
#  rule files, unlike "customize.pl".
#
# **********************************************************************
#  If you have written your own rule files and want them be included
#  each time you start polymake, put commands like this:
#     include 'my.rules';
#  or
#     include qw( my.rules other.rules );
#  in the appropriate section of this file - after the declaration of
#  the application these rules belong to.
#
#  Specify the rule files either as absolute paths or relatively to one
#  of the directories stored in the variable @lookup_rules below.
#########################################################################
.

if (defined $main::Version) {
   $preface .= <<".";
#
# The rule files are rescanned for new preference lists as soon as you
# run a polymake version newer than recorded here, or use an application
# for the first time.
# If you have inserted new "prefer" commands in the rules and want them
# to appear here right now, comment out the following line and rerun polymake.
\$version=v$main::Version;
.
}

sub import {
   if (@_!=2) {
      Carp::croak( "usage: use Preference \"filename\"" );
   }
   my $pkg=caller;
   if (exists &{get_pkg($pkg)->{prefs_handler}}) {
      Carp::croak( "attempt to install multiple preference handlers in package \"$pkg\"" );
   }
   my $handler=&_new;
   define_function($pkg, "prefs_handler", sub { $handler });
   eval "package $pkg; END { \$handler->save if \$handler->need_save }";
   if (-f $handler->file) {
      $handler->read_file;
   } else {
      $handler->need_save=1;
   }
}
#################################################################################
sub read_file {
   my ($self, $filename)=@_;
   $filename ||= $self->file;
   open my $pf, $filename
   or die "can't read preferences file \"$filename\": $!\n";
   local $_;
   my ($key, $body, $version)=("BEGIN", <<".");
package Poly::User;
#line 1 \"$filename\"
.
   while (<$pf>) {
      if (/^\s* (application|module) \s+ ($id_re); \s*$/xo) {
	 $self->orphans->{$key}=$body;
	 $key="$1 $2";
	 my $l=$.+1;
	 $body="#line $l \"$filename\"\n";
	 next;
      }
      $body.=$_;
   }
   $self->orphans->{$key}=$body;

   eval $self->orphans->{BEGIN};
   if ($@) {
      err_print( beautify_error() );
      return;
   }
   $self->need_save=$self->version_bumped=
      defined $main::Version && (!defined($version)  ||  $version lt $main::VersionNumber);
}
####################################################################################
sub activate {
   my ($self, $incr_clock)=splice @_, 0, 2;
   foreach my $pref (@_) {
      push @{$self->active_prefs}, $pref;
      $pref->clock=++$clock if $incr_clock;

      if (my %old_clocks=map { $_=>1 } $pref->activate) {
	 my $new_wildcard=$pref->labels->[0]->wildcard_name;
	 for (my $i=$#{$self->active_prefs}; $i>=0; --$i) {
	    my $old_pref=$self->active_prefs->[$i];
	    if ($old_clocks{$old_pref->clock}) {
	       splice @{$self->active_prefs}, $i, 1, $old_pref->subtract($new_wildcard);
	    }
	 }
      }
   }
   $self->need_save=1;
}
####################################################################################
sub reset_all {
   my ($self)=@_;
   foreach my $module (@{$self->modules}) {
      activate($self, 1, @{$module->prefs->default_prefs});
   }
}
#################################################################################
sub clean_borders {
   local $_=shift;
   if (defined($_)) {
      s/\A (?: $empty_or_separator_line )+ //xom;
      s/(?: $empty_or_separator_line )+ \Z//xom;
   }
   $_;
}

sub save {
   my ($self)=@_;
   my $tempfile=new OverwriteFile($self->file);
   open my $pf, ">", $tempfile
      or die "can't create temporary file \"$tempfile\" for user preferences: $!\n";

   (my $text=$self->orphans->{BEGIN}) =~ s/\A(?s:.*?) ^[ \t\#]*\$version\b .*\n//xom;
   print $pf $preface, $sep_line, clean_borders($text), $sep_line;

   my @active_prefs=@{$self->active_prefs};
   foreach my $module (@{$self->modules}) {
      ref($module) =~ /([^:]+)$/;
      my $key=lc($1)." ".$module->name;
      print $pf "$key;\n";

      my $pm=$module->prefs;
      for (my $i=0; $i<=$#active_prefs; ) {
	 my $pref=$active_prefs[$i];
	 if ($pref->mask & $pm->id  and  ($pref->mask & $pm->mask)==$pref->mask) {
	    print $pf "\nprefer ", $pref->toString, ";\n";
	    splice @active_prefs, $i, 1;
	 } else {
	    ++$i;
	 }
      }

      if (defined ($text=clean_borders($self->user_commands->{$key}))) {
	 print $pf "\n", $text;
      }
      print $pf $sep_line;
   }

   while ((my $key, $text)=each %{$self->orphans}) {
      next if $key eq "BEGIN";
      $text =~ s/^\#line.*\n//mg;
      print $pf "$key;\n$text";
   }

   close $pf;
   $self->need_save=0;
}

1

# Local Variables:
# c-basic-offset:3
# End: