# 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: File.pm 7370 2006-05-23 21:16:03Z gawrilow $
use strict;
use namespaces;
require Poly::Application;
require Poly::Tempfile;
package Poly::File;
declare $strict;
#################################################################################
#
# Constructor: new Poly::File('filename');
#
use Struct (
[ new => '$' ],
[ '$filename' => '#1' ],
'$timestamp',
'$line',
'@errors',
);
#################################################################################
sub need_reload {
my ($self)=@_;
return (stat $self->filename)[9] > $self->timestamp;
}
#################################################################################
sub load {
my ($self, $object, $file_version)=@_;
# FIXME: in XML era it will be recognized from the file contents
my $app_name ||= $Poly::User::default_application;
$self->timestamp=(stat $self->filename)[9];
open P, $self->filename or die "error reading file '", $self->filename, "': $!\n";
my ($proto);
@{$self->errors}=();
# determine the application
# first, try at the file begin (since v2.0)
while (<P>) {
s/^\s+//;
if (/^ _application \s+ ($id_re) \s*$/xo) {
$app_name=$1;
last;
}
if (/^ _version \s+ (\S+) \s*$/x) {
# it is probably v1.4
$file_version=eval "v$1";
last;
}
if (substr($_,0,1) eq '#') {
next;
}
if (/\S/) {
# try at the file end (v1.5)
seek P, -40, 2;
local $/;
$_=<P>;
if (/^\s* _application \s+ ($id_re) \s*$/xmo) {
$app_name=$1;
}
if (/^\s* _version \s+ (\S+) \s*$/xm) {
$file_version=eval "v$1";
}
seek P, 0, 0;
$.=1;
last;
}
}
if (defined($file_version) && $file_version lt v1.5) {
$app_name="polytope";
}
my $app=add Application($app_name)
or return undef;
if (!defined $object->name) {
my ($object_name)= $self->filename =~ $filename_re;
if (defined (my $suffix=$app->file_suffix)) {
$object_name =~ s/\.$suffix$//;
}
$object->name=$object_name;
}
INPUT:
while (<P>) {
s/^\s+//;
next if $_ eq "";
if (substr($_,0,1) eq '#') {
next;
}
if (/^(_?dependenci?es)\s*$/i) {
while (<P>) { # skip the DEPENDENCES from old versions
last unless /\S/;
}
} elsif (/^ _version \s+ (\S+) \s*$/x) {
$file_version=eval "v$1";
} elsif (/^ _application \s+ ($id_re) \s*$/xo) {
next;
} elsif (/^ _type \s+ ($type_re) \s*$/xo) {
$self->line=$.;
unless ($proto=$app->types->{$1}) {
$proto=$app->default_type;
$self->report_warning("unknown type '$1', default type '", $proto->name, "' assumed");
}
bless $object, $proto->object_type;
next;
} elsif (my ($negated, $prop_name, $attr)=/^(!)? ($id_re) (?(1) | (\([\w+]*\))?) \s*$/xo) {
$self->line=$.;
if (! $proto) {
$proto=$app->default_type;
bless $object, $proto->object_type;
}
my $data=[ ];
while (<P>) {
next if /^\s*\#/;
if (/\S/) {
push @$data, $_;
} else {
last;
}
}
enforce_nl($data->[-1]) if $#$data>=0;
my ($prop, $unknown)=$proto->property($prop_name);
if ($unknown && $strict) {
report_error($self, "unknown property '$prop_name' not allowed in strict mode");
} elsif ($prop->temporary) {
report_warning($self, "discarding temporary property '$prop_name'");
} else {
if ($negated) {
if ($file_version le v2.0) {
if (@$data) {
$self->report_warning("ignoring data in a negated property '!$prop_name'");
}
$data= $prop->type eq "boolean" ? [ 0 ] : undef;
} else {
report_error($self, "obsolete syntax for an undefined property: '!$prop_name'");
undef $data;
}
} elsif (!@$data) {
if ($file_version le v2.0 and $prop->type eq "boolean") {
# In v1.3 booleans were encoded as attributes (true) and (false),
# while in v1.4 .. v2.0 as empty or negated sections.
$data->[0]= $attr ne "(false)";
}
} elsif ($file_version gt v2.0 and @$data==1 and $data->[0] =~ $Poly::PropertyValue::UNDEF_re) {
undef $data;
}
if (my $upgrade=$prop->upgrade and $file_version lt $main::VersionNumber) {
for (my $i=0; $i<$#$upgrade; $i+=2) {
if ($file_version le $upgrade->[$i]) {
my @upgraded=eval { select_method($upgrade->[$i+1], $object)->($data) };
if ($@) {
report_parse_error($self, "error upgrading property '$prop_name'");
next INPUT;
}
if (@upgraded==1) {
# the property stays the same
$data=shift @upgraded; last;
} else {
# replaced with new properties
my $orig_prop_name=$prop_name;
while (($prop_name, $data)=splice @upgraded, 0, 2) {
($prop, $unknown)=$proto->property($prop_name);
if ($unknown) {
if ($strict) {
report_error($self, "old property '$orig_prop_name' upgraded to unknown '$prop_name' not allowed in strict mode");
last;
} else {
report_warning($self, "old property '$orig_prop_name' upgraded to unknown '$prop_name'");
}
}
eval { $object->add($prop, $data) };
if ($@) {
report_parse_error($self, "error upgrading property '$orig_prop_name' to '$prop_name'");
last;
}
}
next INPUT;
}
}
}
}
eval { $object->add($prop, $data) };
if ($@) {
report_parse_error($self, "error reading property '$prop_name'");
}
}
report_warning($self, "unknown property '$prop_name'") if $unknown and $Switches::v;
} else {
$self->line=$.; chomp;
report_error($self, "ill-formed section header '$_'");
while (<P>) { # skip the rest of the malformed sektion
last unless /\S/;
}
}
}
close P;
die @{$self->errors} if @{$self->errors};
}
#################################################################################
sub report_warning {
my $self=shift;
warn_print( "\"", $self->filename, "\", line ", $self->line, ": ", @_ );
}
#################################################################################
sub report_error {
my ($self, $text)=@_;
push @{$self->errors}, "\"".$self->filename."\", line ".$self->line.": $text\n";
}
#################################################################################
sub report_parse_error {
my ($self, $my_text)=@_;
my ($where, $text)= $@ =~ /^(?: (.*?) \t)? (.*)/x;
$where ||= 0;
$where+=$self->line;
push @{$self->errors}, "\"".$self->filename."\", line $where: $my_text: $text\n";
}
#################################################################################
sub save {
my ($self, $object)=@_;
my $tempfile=new OverwriteFile($self->filename);
open my $tmp, ">", $tempfile
or die "can't create temporary file \"$tempfile\" for object ", $object->name, ": $!\n";
my $proto=$object->prototype;
print $tmp "_application ", $proto->application->name, "\n",
"_version $main::Version\n",
"_type ", $proto->name, "\n\n";
foreach my $pv (@{$object->contents}) {
next if !defined $pv;
print $tmp $pv->property->name, "\n", $pv->toStringArray, "\n"
or die "error writing to temporary file '$tempfile': $!\n";
}
close $tmp
or die "error writing to temporary file '$tempfile': $!\n";
$object->changed=0;
}
#################################################################################
package Poly::File::Discard;
sub new { my $dummy; bless \$dummy, shift }
sub load { }
sub save { }
1
syntax highlighted by Code2HTML, v. 0.9.1