#  Copyright (c) 1997-2009
#  Ewgenij Gawrilow, Michael Joswig (Technische Universitaet Darmstadt, Germany)
#  http://www.polymake.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: XMLfile.pm 9526 2010-03-04 16:47:54Z gawrilow $

use XML::LibXML;
use XML::SAX::Base;
use XML::Writer;

require Cwd;

use strict;
use namespaces;

my $pmns="http://www.math.tu-berlin.de/polymake/#3";
my ($rngschema, $DOMparser, $XSLT, @all_transforms, $no_transforms);

my $xml_id_attr="{$XML::NamespaceSupport::NS_XML}id";

#############################################################################################
#
#  XML Parser
#

package Polymake::Core::XMLhandler;

use Polymake::Struct (
   [ new => '$$' ],
   [ '$filename' => '#1' ],
   [ '$nsprefix' => 'undef' ],
   '$trusted',
   [ '@cur_object' => '( #2 )' ],
   '@cur_proto',
   '@cur_property',
   '@cur_value',
   [ '$cols' => 'undef' ],
   '$text',
   [ '$transforms' => 'undef' ],
   [ '$doc_tree' => 'undef' ],
);

declare $force_verification;

#############################################################################################
sub applicable_transforms {
   my $v=shift;
   unless (@all_transforms) {
      @all_transforms=map { m|/upgrade-(.*)\.xslt$|; [ eval("v$1"), $_, undef ] } glob("$InstallTop/xml/upgrade-*.xslt");
      $no_transforms=!@all_transforms;
   }
   grep { $v lt $_->[0] } @all_transforms
}

sub apply_transforms {
   my ($self)=@_;
   foreach my $tr (sort { $a->[0] cmp $b->[0] } @{$self->transforms}) {
      $tr->[2] ||= $XSLT->parse_stylesheet_file($tr->[1]);
      dbg_print( "transforming ", $self->filename, " with ", ($tr->[1] =~ $filename_re)[0] ) if $Verbose::files;
      $self->doc_tree=$tr->[2]->transform($self->doc_tree);
   }
}

sub parse_file {
   my ($self, $fh)=@_;
   my $parser=new XML::LibXML( Handler => new XML::SAX::Base( ContentHandler => $self ) );
   eval { $parser->parse_fh($fh) };
   if ($@) {
      if (index($@,"\eTRANSFORM")==0) {
	 seek($fh,0,0);
	 $self->doc_tree=$DOMparser->parse_fh($fh);
	 apply_transforms($self);
	 $parser=XML::LibXML::SAX::Parser->new( ContentHandler => $self );
	 $parser->generate($self->doc_tree);
	 undef $self->doc_tree;
	 $@="";
      } else {
	 die $@;
      }
   }
}

sub parse_string {
   my $self=shift;
   require XML::LibXML::SAX::Parser;
   $DOMparser ||= new XML::LibXML;
   $self->doc_tree=$DOMparser->parse_string(@_);
   my $parser=XML::LibXML::SAX::Parser->new( ContentHandler => $self );
   eval { $parser->generate($self->doc_tree) };
   if ($@) {
      if (index($@,"\eTRANSFORM")==0) {
	 apply_transforms($self);
	 $parser->generate($self->doc_tree);
	 $@="";
      } else {
	 die $@;
      }
   }
   undef $self->doc_tree;
}

#############################################################################################
sub start_element : method {
   my ($self, $elem)=@_;
   my $tag="start_".$elem->{LocalName};
   if (!defined($self->nsprefix)) {
      die "file ", $self->filename, " is not encoded in the current polymake XML namespace\n" if $elem->{NamespaceURI} ne $pmns;
      my $attrs=$elem->{Attributes};

      if (!$no_transforms) {
	 if (exists $attrs->{"{}version"}) {
	    # check this as the very first thing:
	    # if we need to transform the input file, any state changes should be avoided
	    my $version=eval("v".$attrs->{"{}version"}->{Value});
	    if ($version lt $VersionNumber and
		my @transforms=applicable_transforms($version)) {
	       $self->transforms=\@transforms;

	       require XML::LibXSLT;
	       require XML::LibXML::SAX::Parser;
	       $DOMparser ||= new XML::LibXML;
	       $XSLT ||= XML::LibXSLT->new();
	       die "\eTRANSFORM";
	    }
	 }
      }

      $self->nsprefix=$elem->{Prefix};
      my $object=$self->cur_object->[0];
      my $is_object= $tag eq "start_object";
      if (exists $attrs->{"{}ext"}) {
	 unless (my $ext=load Extension($attrs->{"{}ext"}->{Value})) {
	    die "Can't process the data file: missing extension ", $attrs->{"{}ext"}->{Value}, "\n",
	        !defined($ext) && "Please retry in interactive mode\n";
	 }
      }
      $attrs->{"{}type"}->{Value} =~ /^($id_re)::($type_re)$/o
         or die "invalid type of top-level object\n";
      my $proto=(add Application(downgradeUTF8($1)))->eval_type(($is_object ? "objects::" : "props::").downgradeUTF8($2));

      if (instanceof Object($object)) {
	 $is_object or die "top-level element must be `object'\n";
	 bless $object, $proto->pkg;
	 if (exists $attrs->{"{}name"}) {
	    $object->name=$attrs->{"{}name"}->{Value};
	 }
      } else {
	 !$is_object or die "top-level element must be `data'\n";
	 push @{$self->cur_value},
	      [ exists $attrs->{"{}value"} ? downgradeUTF8($attrs->{"{}value"}->{Value}) : () ];
      }
      push @{$self->cur_proto}, $proto;

      if (!$force_verification && exists $attrs->{"{}tm"}) {
	 my $tm=hex($attrs->{"{}tm"}->{Value});
	 my ($fsize, $mtime)=(stat $self->filename)[7,9];
	 $self->trusted= $tm==($mtime^$fsize) || $tm==($mtime-1^$fsize);
	 if (!$self->trusted) {
	    $self->filename =~ $filename_re;
	    if (-f "$`.svn/text-base/$1.svn-base") {
	       my ($base_size, $base_mtime)=(stat _)[7,9];
	       # let's hope that the check-out of a single testcase subdirectory can always be completed in 20 seconds
	       $self->trusted= $fsize==$base_size && $mtime<=$base_mtime+20;
	    }
	 }
      }
      if (!$self->trusted) {
	 $rngschema ||= new XML::LibXML::RelaxNG(location => $InstallTop."/xml/datafile.rng");
	 if (defined($self->doc_tree)) {
	    $rngschema->validate($self->doc_tree);
	 } else {
	    dbg_print( "validating XML file ", $self->filename ) if $Verbose::files;
	    $DOMparser ||= new XML::LibXML;
	    $rngschema->validate($DOMparser->parse_file($self->filename));
	    dbg_print( "XML validation succeeded" ) if $Verbose::files;
	 }
	 $PropertyType::trusted_value=0;
	 $object->begin_transaction;
      }
   } elsif ($self->trusted || $self->nsprefix eq $elem->{Prefix}) {
      $self->$tag($elem);
   } else {
      die "element from an unknown XML namespace";
   }
}

sub end_element : method {
   my ($self, $elem)=@_;
   my $etag="end_".$elem->{LocalName};
   $self->$etag();
}

sub extract_type {
   my ($self, $attrs, $is_object)=@_;
   if (defined (my $type=$attrs->{"{}type"}->{Value})) {
      if ($type eq "text") {
	 $type
      } else {
	 $type =~ /^(?:($id_re)::)?($type_re)/o
            or die "invalid type '$type'";
	 (defined($1) ? add Application(downgradeUTF8($1))
	              : $self->cur_proto->[-1]->application
	 )->eval_type(($is_object ? "objects::" : "props::").downgradeUTF8($2));
      }
   } else {
      undef;
   }
}

sub start_object : method {
   my ($self, $elem)=@_;
   my $prop=$self->cur_property->[-1]->[0];
   my $attrs=$elem->{Attributes};
   if (exists $attrs->{"{}ext"}) {
      unless (my $ext=load Extension($attrs->{"{}ext"}->{Value})) {
	 if (defined $ext) {
	    ### FIXME: skip the subtree
	 } else {
	    die "Can't process the property ", $prop->name, ": missing extension ", $attrs->{"{}ext"}->{Value}, "\n",
	        "Please retry in interactive mode\n";
	 }
      }
   }
   my $expected=$prop->concrete($self->cur_object->[-1])->type;
   my $type=extract_type($self,$attrs,1);
   if (defined($type)) {
      $type=$expected->local_type($type) if $prop->flags & $Property::is_locally_extended;
   } else {
      $type=$expected;
   }
   my $sub_obj=Object::new($type->pkg);
   if (exists $attrs->{"{}name"}) {
      $sub_obj->name=$attrs->{"{}name"}->{Value};
   }
   $sub_obj->parent=$self->cur_object->[-1];	# during the subobject construction
   push @{$self->cur_object}, $sub_obj;
   push @{$self->cur_proto}, $type;
}

sub end_object : method {
   my ($self)=@_;
   pop @{$self->cur_proto};
   my $obj=pop @{$self->cur_object};
   if (@{$self->cur_value}) {
      push @{$self->cur_value->[-1]}, $obj;
      undef $obj->parent;
   }
}

sub start_property : method {
   my ($self, $elem)=@_;
   my $attrs=$elem->{Attributes};
   if (exists $attrs->{"{}ext"}) {
      unless (my $ext=load Extension($attrs->{"{}ext"}->{Value})) {
	 if (defined $ext) {
	    ### FIXME: skip the subtree
	 } else {
	    die "Can't process the property ", $prop->name, ": missing extension ", $attrs->{"{}ext"}->{Value}, "\n",
	        "Please retry in interactive mode\n";
	 }
      }
   }
   my $prop=$self->cur_proto->[-1]->property(downgradeUTF8($attrs->{"{}name"}->{Value}));
   my $type=extract_type($self,$attrs,0);
   push @{$self->cur_property}, [ $prop, $type ];
   push @{$self->cur_value},
        [ exists $attrs->{"{}value"} ? downgradeUTF8($attrs->{"{}value"}->{Value}) :
	  exists $attrs->{"{}undef"} ? undef : () ];
   $self->text="";
}

sub end_property : method {
   my ($self)=@_;
   my ($prop, $type)=@{ pop @{$self->cur_property} };
   my $value_ptr=pop @{$self->cur_value};
   if (defined $type) {
      if (ref($type)) {
	 $self->cur_object->[-1]->_add($prop, PropertyType::new_object($type,$value_ptr->[0]), $self->trusted);
      } else {
	 # $type eq "text"
	 # this value may contain any funny Unicode characters, don't downgrade!
	 $self->cur_object->[-1]->_add($prop, $self->text, $self->trusted);
      }
   } elsif ($prop->flags & $Property::is_multiple) {
      $self->cur_object->[-1]->_add_multis($prop, $value_ptr, $self->trusted);
   } else {
      $self->cur_object->[-1]->_add($prop, $value_ptr->[0], $self->trusted);
   }
}

sub start_attachment {
   my ($self, $elem)=@_;
   my $attrs=$elem->{Attributes};
   my $name=downgradeUTF8($attrs->{"{}name"}->{Value});
   my $type=extract_type($self,$attrs,0);
   push @{$self->cur_property}, [ $name, $type ];
   push @{$self->cur_value},
        [ exists $attrs->{"{}value"} ? downgradeUTF8($attrs->{"{}value"}->{Value}) : () ];
   $self->text="";
}

sub end_attachment : method {
   my ($self)=@_;
   my ($name, $type)=@{ pop @{$self->cur_property} };
   my ($value)=@{ pop @{$self->cur_value} };
   if (defined($type)) {
      if (ref($type)) {
	 if ($type->cppoptions && !$type->cppoptions->default_constructor) {
	    $value=$type->construct->($self->cur_object->[-1], $value);
	 } else {
	    $value=PropertyType::new_object($type,$value);
	 }
      } elsif ($type eq "text") {
	 $value=$self->text;
      }
   }
   $self->cur_object->[-1]->attachments->{$name}=$value;
}

sub end_data : method {
   my ($self)=@_;
   my $type=pop @{$self->cur_proto};
   my ($value)=@{ pop @{$self->cur_value} };
   $self->cur_value=PropertyType::new_object($type, $value);
}

sub start_description : method {
   my ($self)=@_;
   $self->text="";
}

sub end_description : method {
   my ($self)=@_;
   $self->cur_object->[-1]->description=$self->text;
}

sub start_credit : method {
   my ($self, $elem)=@_;
   push @{$self->cur_property}, $elem->{Attributes}->{"{}product"}->{Value};
   $self->text="";
}

sub end_credit : method {
   my ($self)=@_;
   my $product=pop @{$self->cur_property};
   $self->cur_object->[-1]->credits->{$product}= $self->cur_proto->[-1]->application->credits->{$product} || $self->text;
}

sub start_v : method {
   my ($self, $elem)=@_;
   my $attrs=$elem->{Attributes};
   my $value=[ ];
   if (exists $attrs->{"{}dim"}) {
      set_sparse_dim($value, $attrs->{"{}dim"}->{Value});
   } elsif (defined($self->cols)) {
      set_sparse_dim($value, $self->cols);
   } elsif (exists $attrs->{"{}i"}) {
      push @{$self->cur_value->[-1]}, $attrs->{"{}i"}->{Value}+0;
   }
   push @{$self->cur_value}, $value;
   $self->text="";
}

sub end_v : method {
   my ($self)=@_;
   my $list=pop @{$self->cur_value};
   if (!@$list && $self->text =~ /\S/) {
      if ($self->text =~ /['"]/) {
	 $self->text=downgradeUTF8($self->text);
	 while ($self->text =~ /\G\s* (?: (['"]) (.*?) \1 | (\S+))/xg) {
            push @$list, defined($1) ? $2 : $3;
         }
      } else {
	 $self->text =~ s/^\s+//;
	 @$list=split /\s+/, downgradeUTF8($self->text);
      }
   }
   push @{$self->cur_value->[-1]}, $list;
   $self->text="";
}

sub start_m : method {
   my ($self, $elem)=@_;
   my $attrs=$elem->{Attributes};
   my $value=[ ];
   if (exists $attrs->{"{}cols"}) {
      $self->cols=$attrs->{"{}cols"}->{Value}+0;
   } elsif (exists $attrs->{"{}dim"}) {
      set_sparse_dim($value, $attrs->{"{}dim"}->{Value});
   }
   push @{$self->cur_value}, $value;
}

sub end_m : method {
   my ($self)=@_;
   my $list=pop @{$self->cur_value};
   push @{$self->cur_value->[-1]}, $list;
   undef $self->cols;
}

sub start_e : method {
   my ($self, $elem)=@_;
   my $attrs=$elem->{Attributes};
   if (exists $attrs->{"{}i"}) {
      push @{$self->cur_value->[-1]}, $attrs->{"{}i"}->{Value}+0;
   }
   $self->text="";
}

sub end_e : method {
   my ($self)=@_;
   push @{$self->cur_value->[-1]}, downgradeUTF8($self->text);
}

sub start_t : method {
   my ($self)=@_;
   push @{$self->cur_value}, [ ];
   $self->text="";
}

*end_t=\&end_v;

sub characters : method {
   my ($self, $elem)=@_;
   $self->text .= $elem->{Data};
}

#############################################################################################
package Polymake::Core::XMLfile;

use Polymake::Struct (
   [ new => '$' ],
   [ '$filename' => 'Cwd::abs_path( #1 )' ],
);

sub load {
   my ($self, $object)=@_;
   open my $fh, $self->filename or die "can't open file ".$self->filename.": $!\n";
   local $_;
   while (<$fh>) {
      if (/^\s*<\?xml/) {
	 seek($fh,0,0);
	 last;
      }
      next if /^\s*$/;

      require Polymake::Core::PlainFile;
      my $plf=new PlainFile($self->filename);
      seek($fh,0,0);
      $object->begin_transaction;
      $plf->load($object, $fh);
      $object->transaction->changed=1;
      $object->transaction->commit($object);
      return;
   }
   my $handler=new XMLhandler($self->filename, $object);
   local $PropertyType::trusted_value=1;
   $handler->parse_file($fh);
   unless ($PropertyType::trusted_value) {
      $object->transaction->changed=1;
      $object->transaction->commit($object);
   }
}
#############################################################################################
sub load_data {
   my ($self)=@_;
   open my $fh, $self->filename or die "can't open file ".$self->filename.": $!\n";
   my $handler=new XMLhandler($self->filename, new LooseData());
   local $PropertyType::trusted_value=1;
   $handler->parse_file($fh);
   if (!$handler->trusted && -w $self->filename) {
      save_data($self, $handler->cur_value, $handler->cur_object->[0]->description);
      $handler->trusted=1;
   }
   wantarray ? ($handler->cur_value, $handler->cur_object->[0]->description) : $handler->cur_value;
}
#############################################################################################
package Polymake::Core::XMLfile::LooseData;

use Polymake::Struct (
   '$description',
);

sub begin_transaction {}

#############################################################################################
#
#  XML Writer
#

package Polymake::Core::XMLwriter;

my @writer_init=( PREFIX_MAP => { $pmns=>"" }, NAMESPACES => 1,
		  DATA_MODE => 1, DATA_INDENT => 2, ENCODING => 'utf-8', UNSAFE => !$DeveloperMode );

sub new {
   new XML::Writer(OUTPUT => $_[1], @writer_init, @_[2..$#_]);
}

sub add_ext {
   my ($writer, $ext_list)=@_;
   grep { not $writer->{":ext"}->{$_}++ } map { $_->URI } (is_object($ext_list) ? $ext_list : @{$ext_list});
}

sub type_attr {
   my ($writer, $type, $owner)=@_;
   my @ext;
   if (!defined($owner) && $type->application->installTop ne $InstallTop) {
      my $URI=(lookup Extension($type->application->installTop))->URI;
      push @ext, $URI;
      $writer->{":ext"}={ $URI => 1 };
   }
   push @ext, add_ext($writer, $type->extension) if defined $type->extension;
   ( type => ( not(defined($owner) && exists $owner->type->application->imported->{$type->application->name}) &&
	       $type->application->name."::" ) . $type->XML_name,
     @ext ? (ext => join(";",@ext)) : () );
}

sub write_subobject {
   my ($writer, $object, $parent, $expected_type)=@_;
   my $type=$object->type;
   $writer->startTag( "object",
		      length($object->name) ? (name => $object->name) : (),
		      $type != $expected_type ? type_attr($writer,$type,$parent) : () );
   write_object_contents($writer,$object);
   $writer->endTag("object");
}

sub write_object_contents {
   my ($writer, $object)=@_;
   if (length($object->description)) {
      $writer->cdataElement("description", $object->description);
   }
   while (my ($product, $credit)=each %{$object->credits}) {
      $writer->cdataElement("credit", is_object($credit) ? $credit->toFileString : $credit, "product" => $product);
   }
   foreach my $pv (@{$object->contents}) {
      next if !defined $pv;
      my @ext=add_ext($writer, $pv->property->extension) if defined($pv->property->extension);
      if (instanceof Object($pv)) {
	 $writer->startTag( "property", name => $pv->property->name, @ext ? (ext => @ext) : () );
	 write_subobject($writer,$pv,$object,$pv->property->type);
	 $writer->endTag("property");
      } elsif ($pv->flags & $PropertyValue::is_ref) {
	 # TODO: handle explicit references to other objects some day...
      } elsif ($pv->property->flags & $Property::is_multiple) {
	 $writer->startTag( "property", name => $pv->property->name, @ext ? (ext => @ext) : () );
	 write_subobject($writer,$_,$object,$pv->property->type) for @{$pv->values};
	 $writer->endTag("property");
      } elsif (defined($pv->value)) {
	 my $type=$pv->property->type;
	 my @show_type;
	 if (is_object($pv->value)) {
	    if (ref($pv->value) ne $type->pkg) {
	       $type=$pv->value->type;
	       @show_type=type_attr($writer,$type,$object);
	    }
	 } elsif (!$type->parse) {
	    @show_type=(type => "text");
	 }
	 if (@ext) {
	    if (@show_type==4) {
	       $show_type[3].=";@ext";
	    } else {
	       push @show_type, ext => @ext;
	    }
	 }
	 if (defined($type->toXML)) {
	    $writer->startTag( "property", name => $pv->property->name, @show_type );
	    $type->toXML->($pv->value, $writer);
	    $writer->endTag("property");
	 } else {
	    $writer->emptyTag( "property", name => $pv->property->name, @show_type,
			       value => $type->toString->($pv->value) );
	 }
      } else {
	 $writer->emptyTag( "property", name => $pv->property->name, @ext ? (ext => @ext) : (), undef => "true" );
      }
   }
   while (my ($name, $value)=each %{$object->attachments}) {
      if (ref($value)) {
	 my $type=$value->type;
	 if (defined($type->toXML)) {
	    $writer->startTag( "attachment", name => $name, type_attr($writer,$type,$object) );
	    $type->toXML->($value, $writer);
	    $writer->endTag("attachment");
	 } else {
	    $writer->emptyTag( "attachment", name => $name, type_attr($writer,$type,$object), value => $value );
	 }
      } elsif (length($value)>100 || $value =~ /\n/) {
	 $writer->cdataElement("attachment", $value, name => $name, type => "text");
      } else {
	 $writer->emptyTag( "attachment", name => $name, value => $value );
      }
   }
}

sub save {
   my ($output, $object, @attrs)=@_;
   my $writer=new XMLwriter($output);
   $writer->xmlDecl;
   $writer->startTag( [ $pmns, "object" ],
		      defined($object->name) ? (name => $object->name) : (),
		      type_attr($writer,$object->type),
		      version => $Version,
		      @attrs,
		    );
   write_object_contents($writer, $object);
   $writer->endTag("object");
   $writer->end;
}

sub save_data {
   my ($output, $data, $description, @attrs)=@_;
   my $writer=new XMLwriter($output);
   $writer->xmlDecl;
   my $type=$data->type;
   $writer->startTag( [ $pmns, "data" ],
		      type_attr($writer,$type),
		      version => $Version,
		      defined($type->toXML) ? () : (value => $type->toString->($data)),
		      @attrs,
		    );
   if (length($description)) {
      $writer->cdataElement("description", $description);
   }
   if (defined($type->toXML)) {
      $type->toXML->($data, $writer);
   }
   $writer->endTag("data");
   $writer->end;
}

package Polymake::Core::XMLfile::AttrTell;
use Polymake::Struct (
   [ new => '$$$' ],
   [ '$name' => '#1' ],
   [ '$filler' => '#2' ],
   [ '$handle' => '#3' ],
   '$pos',
);

use overload '""' => sub {
   my $self=shift;
   $self->pos=tell($self->handle)+length($self->name)+3;	# + space in front of the name and ="
   $self->filler
};

sub propagate {
   my $self=shift;
   ($self->name, $self)
}

sub write {
   my ($self, $value)=@_;
   my $of=$self->handle;
   seek $of, $self->pos, 0;
   printf $of $value;
}

package Polymake::Core::XMLfile;

sub save {
   my ($self, $object)=@_;
   my ($of, $of_k)=new OverwriteFile($self->filename);
   binmode $of, ":utf8";

   my $tm_attr=new AttrTell(tm => "0"x8, $of);
   XMLwriter::save($of, $object, $tm_attr->propagate);
   my $size=tell($of);
   $tm_attr->write(sprintf "%08x", time^$size);
   close $of;
}

sub save_data {
   my ($self, $data, $description)=@_;
   my ($of, $of_k)=new OverwriteFile($self->filename);
   binmode $of, ":utf8";

   my $tm_attr=new AttrTell(tm => "0"x8, $of);
   XMLwriter::save_data($of, $data, $description, $tm_attr->propagate);
   my $size=tell($of);
   $tm_attr->write(sprintf "%08x", time^$size);
   close $of;
}

#############################################################################################
package Polymake::Core::XMLstring;
use Encode;

sub load {
   shift;
   my $object=shift;
   my $handler=new XMLhandler("<input string>", $object);
   local $PropertyType::trusted_value=0;
   $handler->parse_string(@_);
   $object->transaction->changed=1;
   $object->transaction->commit($object);
}

sub save {
   shift;
   my $string="";
   XMLwriter::save(\$string, @_);
   encode("utf8", $string);
}

sub save_data {
   shift;
   my $string="";
   XMLwriter::save_data(\$string, @_);
   encode("utf8", $string);
}

1
