# 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: User.pm 7560 2007-01-15 14:04:09Z gawrilow $
use strict;
use namespaces;
package Poly::UserSettings;
BEGIN {
declare $dir="$ENV{HOME}/.polymake";
if (!-d $dir) {
mkdir $dir, 0755
or die "can't per-user directory $dir: $!\n";
warn_print( "directory $dir created for keeping individual user settings" );
}
}
##################################################################################
package Poly::User;
declare $this;
declare $application;
BEGIN {
declare @start_applications; declare $default_application;
declare @lookup_applications;
declare @lookup_rules; declare @lookup_scripts;
}
my @imported;
package Poly::User::_secret;
sub unimport_app {
if (@imported) {
unimport_function(\%Poly::User::, @imported);
}
}
sub import_app {
@imported=();
# import user functions, predeclare user methods so as to be caught up by AUTOLOAD
while (my ($func, $attr)=each %{$application->EXPORT}) {
next if $attr eq "func";
package Poly::User; no strict 'refs';
if (!exists &$func) {
*$func= is_code($attr)
? $attr :
$attr eq "user" || $attr eq "pref"
? namespaces::lookup_sub($application->pkg,$func)
: \&$func;
push @imported, $func;
}
}
}
package Poly::User;
##################################################################################
#
# application
#
sub application {
if (@_>1) {
die "usage: application [ \"name\" ]\n";
} elsif (@_) {
my $new_app=shift;
$new_app=add Application($new_app) unless ref($new_app);
if (defined($application)) {
return if $application == $new_app;
Poly::User::_secret::unimport_app;
readwrite($application);
}
$application=$new_app;
readonly($application);
Poly::User::_secret::import_app;
} else {
# tell the current application
$application;
}
}
####################################################################################
sub AUTOLOAD {
my ($method_name)=$AUTOLOAD =~ /::([^:]+)$/;
if ($application and my $attr=$application->EXPORT->{$method_name}) {
if ($attr eq "func") {
# not explicitly exported, but allowed
my $sub=namespaces::lookup_sub($application->pkg, $method_name);
push @imported, $method_name;
no strict 'refs';
*$method_name=$sub;
&$sub;
}
if ($attr eq "prop" || $attr eq "meth") {
if (defined($this)) {
$this->$method_name(@_);
} else {
die "there is no default '\$this' object currently\n";
}
} else {
croak( "$attr function $method_name is not available" );
}
} else {
croak( "undefined subroutine $method_name" );
}
}
####################################################################################
sub include {
is_object($INC[0])
? $INC[0]==$application || (local $INC[0]=$application)
: local_unshift(@INC, $application);
if (@lookup_rules) {
@_=map {
my $path=$_;
if (! -f) {
foreach my $dir (@lookup_rules) {
if (-f "$dir/$_") {
$path="$dir/$_"; last;
}
}
}
$path;
} @_;
}
$application->include_rules(@_);
}
#################################################################################
# my %file2var;
# sub Poly::Shell::file2var {
# my ($name)=@_;
# no strict 'refs';
# my $varname;
# if (defined ($varname=$file2var{$name}) && defined($$varname)) {
# return $varname;
# }
# $file2var{$name}= do {
# $varname=$name;
# $varname =~ s/\.\w+$//;
# $varname =~ s/[^\w]/_/g;
# $varname =~ s/^(?=\d)/N/;
# my $ph;
# if (defined (my $obj=$$varname)
# and !UNIVERSAL::isa($obj, "Poly::Object") ||
# !defined ($ph=$obj->persistent) ||
# $ph->filename ne $name) {
# for (my $i=1; 1; ++$i) {
# if (!defined(${"$varname\_$i"})) {
# $varname.="_$i";
# last;
# }
# }
# }
# # declare the variable
# declare *$varname=\( my $init="" );
# $varname;
# };
# }
sub load {
my ($name)=@_;
my $filename=$name;
unless (-f $filename
or
defined($application) && $filename !~ /\./ &&
-f ($filename .= "." . $application->file_suffix)) {
if (my @files=glob "$name.*") {
warn_print( "wildcard $name.* matches more than one file" ) if @files>1;
$filename=$files[0];
} else {
die "no such file: $name\n";
}
}
my $obj=load Object($filename);
if (defined wantarray) {
application $obj->prototype->application if !defined $application;
return $obj;
}
# no strict 'refs';
# my $varname=Poly::Shell::file2var($name);
# if (defined (my $old_obj=$$varname)) {
# my $ph=$old_obj->persistent;
# die "unsaved changes in \$$name would be lost\n" if !defined($ph) or $old_obj->changed;
# return unless $ph->need_reload;
# }
# $$varname=$obj;
$this=$obj;
application $obj->prototype->application;
}
#################################################################################
#
# save
#
sub save {
my ($obj, $filename, $force)=@_;
$obj ||= $this or do {
err_print( "no object specified" );
return;
};
if (! $obj->persistent) {
if (defined $filename) {
if ($filename !~ /\.\w+$/) {
$filename .= "." . $obj->prototype->application->file_suffix;
}
if (!$force && -f $filename) {
err_print( "File $filename already exists;\n",
"please choose another file name or delete the existing file (unlink \"$filename\")" );
return;
}
} elsif (length($obj->name)) {
$filename=$obj->name.".".$obj->prototype->application->file_suffix;
if (!$force && -f $filename) {
if ($Poly::Object::suppress_save) {
# end cleanup phase - no chance more to speak with the user
unless (rename $filename, "$filename~") {
err_print( "can't create a backup copy $filename~: $!" );
return;
}
if ($Switches::v) {
warn_print( "previous object ".$obj->name." stored in a backup file $filename~" );
}
} else {
err_print( "File $filename already exists;\n",
"please specify a different name as the second argument or delete the existing file (unlink \"$filename\")" );
return;
}
}
} else {
for (my $i=1;
-f ($filename=($obj->name=$obj->prototype->name."_$i".".".$obj->prototype->application->file_suffix));
++$i) {
}
warn_print( "saving object as $filename" );
}
$obj->persistent=new File($filename);
$obj->changed=1;
} elsif (! $obj->changed) {
if ($obj->persistent->need_reload) {
$obj->changed=1;
} else {
warn_print( "no changes need to be saved" ) if !$Poly::Object::suppress_save;
return;
}
}
$obj->save;
}
#################################################################################
#
# prefer
#
sub prefer {
$application->prefs->add_preference("@_");
}
sub prefer_now {
$application->prefs->set_temp_preference($main::scope, @_);
}
# an alias, for the sake of symmetry
*set_preference=\&prefer;
sub reset_preference {
if ($_[0] eq "all" || $_[0] eq "*") {
$application->prefs->handler->reset_all;
} else {
$application->prefs->reset(@_);
}
}
####################################################################################
# prepare for custom variables and preferences
package Poly::Module;
use Poly::Customize "$Poly::UserSettings::dir/customize.pl", "$main::InstallTop/configured.pl";
use Poly::Preference "$Poly::UserSettings::dir/prefer.pl";
package Poly::User;
foreach (@lookup_applications, @lookup_rules, @lookup_scripts) {
# treate relative paths as starting at $HOME
s{^(?!/)}{$ENV{HOME}/};
}
if ((my $ph=Poly::Module::prefs_handler)->need_save) {
unless (@start_applications) {
@start_applications=map { m{ ([^/]+) $ }x } grep { -d "$_/rules" } glob("$main::InstallTop/apps/*");
}
$default_application ||= $main::DefaultAppName;
my $l_app_c= !@lookup_applications && "# ";
my $l_rul_c= !@lookup_rules && "# ";
my $l_scr_c= !@lookup_scripts && "# ";
$ph->orphans->{BEGIN}=<<".";
#
# Settings common for all applications
# start with these applications:
\@start_applications=qw( @start_applications );
# assume this application for scripts and objects created from scratch:
\$default_application="$default_application";
# look for applications in the following directories:
$l_app_c\@lookup_applications=qw( @lookup_applications );
# look for additional rules in the following directories:
$l_rul_c\@lookup_rules=qw( @lookup_rules );
# look for scripts in the following directories:
$l_scr_c\@lookup_scripts=qw( @lookup_scripts );
.
}
1
syntax highlighted by Code2HTML, v. 0.9.1