#  Copyright (c) 1997-2004
#  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,v 1.10.2.1 2004/12/14 17:41:32 gawrilow Exp $

use strict;
use namespaces;

package Poly::File;

use Poly::Application;
use Poly::Tempfile;

#################################################################################
#
#  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 ||= $main::DefaultAppName;

   $self->timestamp=(stat $self->filename)[9];

   open P, $self->filename  or  die "error reading file '", $self->filename, "': $!\n";

   my ($proto, @comment);
   @{$self->errors}=();

   # determine the application
   # first, try at the file begin (since v2.0)
   while (<P>) {
      s/^\s+//;
      if (/^ _application \s+ ((?!\d)\w+) \s*$/x) {
	 $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 '#') {
	 push @comment, $_;
	 next;
      }
      if (/\S/) {
	 # try at the file end (v1.5)
	 seek P, -40, 2;
	 local $/;
	 $_=<P>;
	 if (/^\s* _application \s+ ((?!\d)\w+) \s*$/xm) {
	    $app_name=$1;
	 }
	 if (/^\s* _version \s+ (\S+) \s*$/xm) {
	    $file_version=eval "v$1";
	 }
	 seek P, 0, 0;
	 @comment=();  $.=1;
	 last;
      }
   }

   if (defined($file_version) && $file_version lt v1.5) {
      $app_name="polytope";
   }
   my $app=add Poly::Application $app_name
   or return undef;

   if (!defined $object->name) {
      my $object_name=$self->filename;
      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 '#') {
	 push @comment, $_;
	 next;
      }

      if (/^(_?dependenci?es)\s*$/i) {
	 read_block(\*P);	# skip the DEPENDENCES from old versions
      } elsif (/^ _version \s+ (\S+) \s*$/x) {
	 $file_version=eval "v$1";
      } elsif (/^ _application \s+ ((?!\d)\w+) \s*$/x) {
	 next;
      } elsif (/^ _type \s+ ((?!\d)\w+) \s*$/x) {
	 $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)=/^(!)? ((?!\d)\w+) (?(1) | (\([\w+]*\))?) \s*$/x) {
	 $self->line=$.;

	 if (! $proto) {
	    $proto=$app->default_type;
	    bless $object, $proto->object_type;
	 }

	 my ($data, $intersperced_comments)=read_block(\*P);
	 push @comment, @$intersperced_comments;

	 my ($prop, $unknown)=$proto->property($prop_name);
	 if ($prop->temporary) {
	    $self->report_warning("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 {
		  $self->report_error("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] =~ /^\s*==UNDEF==\s*$/) {
	       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 $upgrade_sub=$upgrade->[$i+1];
		     my @upgraded=eval {
			is_method($upgrade_sub) ? $object->$upgrade_sub($data)
			                        : $upgrade_sub->($data)
		     };
		     if ($@) {
			$self->report_parse_error("error upgrading property '$prop_name'");
			next INPUT;
		     }

		     if (@upgraded==1) {
			# the property stays the same
			$data=$upgraded[0]; 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);
			   $self->report_warning("old property '$orig_prop_name' upgraded to unknown '$prop_name'") if $unknown;
			   eval { $object->add($prop, $data) };
			   if ($@) {
			      $self->report_parse_error("old property '$orig_prop_name' upgraded to invalid '$prop_name'");
			      last;
			   }
			}
			next INPUT;
		     }
		  }
	       }
	    }

	    eval { $object->add($prop, $data, \@comment) };
	    if ($@) {
	       $self->report_parse_error("error reading property '$prop_name'");
	    }
	 }
	 $self->report_warning("unknown property '$prop_name'") if $unknown and $Switches::v;
	 @comment=();

      } else {
         $self->line=$.;  chomp;
	 $self->report_error("ill-formed section header '$_'");
	 read_block(\*P);	# skip the rest of the malformed sektion
      }
   }

   die @{$self->errors} if @{$self->errors};
   close P;
}
#################################################################################
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 ($dir)= $self->filename =~ m|^(.*/)[^/]+$|;
   my $tempfile= $dir . basename Poly::Tempfile;
   open my $tmp, ">$tempfile"  or  die "can't create temporary file '$tempfile': $!\n";

   eval {
      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;
	 (!ref($pv->comment)  ||  print $tmp @{$pv->comment})
	 &&
	 print $tmp $pv->property->name, "\n", $pv->toStringArray, "\n"
	 or die "can't write to temporary file '$tempfile': $!\n";
      }
      close $tmp;
      rename $tempfile, $self->filename
      or die "can't rename temporary file '$tempfile' to '", $self->filename, "': $!\n";
   };
   $object->changed=0;
   if ($@) {
      unlink $tempfile;
      die $@;
   }
}
#################################################################################

package Poly::File::Discard;

sub new { my $dummy; bless \$dummy, shift }
sub load { }
sub save { }

1
