# file KLEIDER/web/src/kalender/XMLDataWriter.pm
# Daten als XML ausgeben
# 2013-02-15 Herbert Schiemann <h.schieman@herbaer.de>
# GPL Version 2 oder neuer

# 2020-04-17 open: default STDOUT für out
# 2020-07-29 "Herbaer::*" - Objekte wie HASH
# 2020-12-01 open: Rückgabewert 0 bei Fehler

package Herbaer::XMLDataWriter;

use POSIX qw(strftime);

sub new {
   my ($class, $parm, $encoding, $xmlns, $xslt) = @_;
   my $self = {
      "parm"       => $parm,
      "encoding"   => ($encoding || "utf-8"),
      "xmlns"      => $xmlns,
      "cur_xmlns"  => undef,  # durch "open" für ein Dokument überschrieben
      "xslt"       => $xslt,
      "hout"       => undef,
      "meta"       => {},
      "is_open"    => 0,
      "close_hout" => 0,      # muss hout geschlossen werden?
      "open_elts"  => [],
      "errormsg"   => "",
      "reignore"   => undef,  # RegEx der write-Namen, die ignoriert werden
   };
   return bless ($self, $class);
} # new

# Vorsicht: existierende Datei wird überschrieben
sub open {
   my ($self, $out, $encoding, $xmlns, $xslt) = @_;
   $self -> close () if $self -> {"is_open"};
   $self -> {"encoding"} ||= $encoding;
   $self -> {"xmlns"}    ||= $xmlns;
   $self -> {"xslt"}     ||= $xslt;
   $out      //= "-";
   $encoding ||= $self -> {"encoding"};
   $self -> {"cur_xmlns"} = $xmlns || $self -> {"xmlns"};
   
   my $meta = $self -> {"meta"};
   $meta -> {"date"} = strftime ("%Y-%m-%dT%H:%M:%S", localtime ());

   my $hout;   # Handle der Ausgabe
   $self -> {"close_hout"} = 0;
   if (ref ($out) eq "GLOB") {
      $hout = $out;
      binmode ($hout, ":raw:encoding($encoding)");
   }
   elsif ($out eq "-") {
      $hout = STDOUT;
      binmode ($hout, ":raw:encoding($encoding)");
   }
   elsif ( open ($hout, ">:encoding($encoding)", $out) ) {
      $meta -> {"file"} = $out;
      $self -> {"close_hout"} = 1;
   }
   else {
      $self -> {"errormsg"} .= "CANNOT OPEN OUTPUT \"$out\": $!\n";
      $hout = undef;
   }
   if ($hout) {
      $self -> {"hout"}    = $hout;
      $self -> {"is_open"} = 1;
      $self -> {"indent"}  = "";
      print $hout "<?xml version=\"1.0\" encoding=\"$encoding\"?>\n";
      $xslt ||= $self -> {"xslt"};
      print $hout "<?xml-stylesheet href=\"$xslt\" type=\"application/xml\"?>\n"
         if $xslt && $xslt ne "none";
      $self -> {"bol"} = 1;   # am Anfang einer Zeile
      $self -> {"open_elts"} = [];
   }
   else {
      return 0;
   }
   $self;
} # open

sub close {
   $self = shift;
   if ($self -> {"is_open"}) {
      my $hout      = $self -> {"hout"};
      my $open_elts = $self -> {"open_elts"};
      if (@$open_elts) {
         my $indent = $self -> {"indent"};
         my $elt;
         for $elt (@$open_elts) {
            $indent =~ s/^  //;
            print $hout "$indent</$elt>\n";
         }
      }
      close ($hout) if $self -> {"close_hout"};
   }
   $self -> {"hout"}       = undef;
   $self -> {"is_open"}    = 0;
   $self -> {"close_hout"} = 0;
   $self -> {"open_elts"}  = [];
   $self;
} # close

sub attributes {
   my ($self, $att) = @_;
   my $hout = $self -> {"hout"};
   my ($an, $av);
   while ( ($an, $av) = each %$att ) {
      next unless defined $av;
      $av =~ s/&/&amp;/g;
      $av =~ s/</&lt;/g;
      $av =~ s/>/&gt;/g;
      $av =~ s/"/&quot;/g;
      print $hout " $an=\"$av\"";
   }
   $self;
} # attributes

sub open_element {
   my ($self, $elt, $att) = @_;
   if (!$self -> {"is_open"}) {
      $self -> {"errmsg"} .= "OUTPUT NOT OPEN in open_element $elt\n";
   }
   else {
      my $hout   = $self -> {"hout"};
      my $indent = $self -> {"indent"};
      my $open_elts = $self -> {"open_elts"} || [];
      print $hout "\n" unless $self -> {"bol"};
      print $hout ("$indent<$elt");
      if (!@$open_elts && $self -> {"cur_xmlns"}) {
         $att -> {"xmlns"} ||= $self -> {"cur_xmlns"};
      }
      $self -> attributes ($att);
      print $hout ">";
      unshift (@$open_elts, $elt);
      $self -> {"indent"} = "$indent  ";
      $self -> {"bol"}    = 0;
   }
   $self;
} # open_element

sub close_element {
   my ($self, $elt) = @_;
   my $open_elts = $self -> {"open_elts"};
   my $el = shift @$open_elts;
   if (!$el) {
      $self -> {"errormsg"} .= "NO OPEN ELEMENT in close_element $elt\n";
   }
   elsif ($el ne $elt) {
      $self -> {"errormsg"} .= "ELEMENT MISMATCH $elt $el\n";
   }
   if (!$self -> {"is_open"}) {
      $self -> {"errormsg"} .= "OUTPUT NOT OPEN in close_element $elt\n";
   }
   else {
      my $hout = $self -> {"hout"};
      $self -> {"indent"} =~ s/  $//;
      my $indent = $self -> {"indent"};
      print $hout $indent if $self -> {"bol"};
      print $hout "</$elt>\n";
      $self -> {"bol"} = 1;
   }
   $self;
} # close_element

sub write {
   my ($self, $name, $att, $cont) = @_;
   my $parm   = $self -> {"parm"};
   my $hout   = $self -> {"hout"};
   my $indent = $self -> {"indent"};
   my $reign  = $self -> {"reignore"};
   my $pl;
   $self -> open () if !$self -> {"is_open"};
   if (!defined $cont) {
      return $self;
   }
   elsif ($reign && $name =~ $reign) {
      return $self;
   }
   elsif (!$self -> {"is_open"}) {
      $self -> {"errormsg"} .= "OUTPUT NOT OPEN in write $name\n";
   }
   elsif (ref ($cont) eq "HASH" || ref ($cont) =~ /^Herbaer::/ ) {
      $pl = $parm -> {"\%$name"};
      my $ca;      # Attribute des Kindelements
      my $katt;    # Attributname für den HASH-Schlüssel
      my $pelt;    # umhüllendes Element
      my $kelt;    # Element oder Attribut für die HASH-Schlüssel
      my $celt;    # Element für den HASH-Eintrag
      my $empty;   # Option zur Ausgabe eines leeren HASH
      my ($k, $v); # Schlüssel/Wert-Paar
      if (!$pl) {
         $pelt = $name;
      }
      elsif ($pl eq "IGNORE") {
         return $self;
      }
      elsif (ref ($pl) eq "ARRAY") {
         ($pelt, $celt, $kelt, $empty) = @$pl;
         $empty = 0 unless $empty && $empty eq "WRITE_EMPTY";
      }
      else {
         $self -> {"errormsg"} .= "UNKNOWN HASH OUTPUT OPTION $name $pl\n";
         $pelt = $name;
      }
      if (!%$cont) {
         if ($empty) {
            $pelt ||= $name;
         }
         elsif (! $parm -> {"[empty_hash]"}) {
            return $self;
         }
      }
      if ($pelt) {
         $self -> open_element ($pelt, $att);
         $ca = {};
      }
      else {
         $ca = $att;
      }
      if ($kelt) {
         $celt ||= $name;
         if ($kelt =~ s/^@//) {
            $katt = $kelt;
            while ( ($k, $v) = each %$cont ) {
               $ca -> {$katt} = $k;
               $self -> write ($celt, $ca, $v);
            }
            delete $ca -> {$katt};
         }
         else {
            while ( ($k, $v) = each %$cont ) {
               $v -> {$kelt} = $k
                  if ( ref ($v) eq "HASH" || ref ($v) =~ /^Herbaer::/ );
               $self -> write ($celt, $ca, $v);
               delete $v -> {$kelt}
                  if ( ref ($v) eq "HASH" || ref ($v) =~ /^Herbaer::/ );
            }
         }
      }
      else {
         while ( ($k, $v) = each %$cont ) {
            $self -> write ($celt || $k, $ca, $v);
          }
      }
      $self -> close_element ($pelt) if $pelt;
   }
   elsif ( ref ($cont) eq "ARRAY" ) {
      $pl = $parm -> {"\@$name"};
      my $pelt;
      my $celt;
      my $ca;     # Attribute eines Elements zu einem einzelnen Eintrag
      my $v;
      my $empty;  # Option zur Ausgabe eines leeren ARRAY
      if (!$pl) {}
      elsif (ref ($pl) eq "ARRAY") {
         ($pelt, $celt, $empty) = @$pl;
         $empty = 0 unless $empty && $empty eq "WRITE_EMPTY";
      }
      elsif ( $pl eq "IGNORE" ) {
         return $self;
      }
      else {
         $self -> {"errormsg"} .= "UNKNOWN ARRAY OUTPUT OPTION $name $pl\n";
      }
      if (!@$cont) {
         return $self unless $empty;
         $pelt ||= $name;
      }
      $celt ||= $name;
      if ($pelt) {
         $self -> open_element ($pelt, $att);
      }
      else {
         $ca = $att;
      }
      if (ref ($celt) eq "ARRAY") {
         my $i = 0;
         my $iend = @$celt - 1;
         for $v (@$cont) {
            $self -> write ($celt -> [$i], $ca, $v);
            ++$i if $i < $iend;
         }
      }
      else {
         for $v (@$cont) {
            $self -> write ($celt, $ca, $v);
         }
      }
      $self -> close_element ($pelt) if $pelt;
   }
   else {
      $pl = $parm -> {"\$$name"};
      my $pelt;
      my $type;
      if (!$pl) {}
      elsif (ref ($pl) eq "ARRAY") {
         ($pelt, $type) = @$pl;
      }
      elsif ( $pl eq "IGNORE" ) {
         return $self;
      }
      else {
         $type = $pl;
      }
      $pelt ||= $name;
      if ($type && $type eq "empty") {
         print $hout $self -> {"indent"};
         print $hout "<$pelt";
         $self -> attributes ($att);
         print $hout "/>\n";
         $self -> {"bol"} = 1;
      }
      else {
         $self -> open_element ($pelt, $att);
         if (!$type) {
            $cont =~ s/&/&amp;/g;
            $cont =~ s/</&lt;/g;
            $cont =~ s/>/&gt;/g;
            print $hout $cont;
         }
         elsif ($type eq "time") {
            print $hout strftime ("%Y-%m-%dT%H:%M:%S", localtime ($cont));
         }
         else {
            $self -> {"errormsg"} .= "UNKNOWN TYPE $name $type\n";
            $cont =~ s/&/&amp;/g;
            $cont =~ s/</&lt;/g;
            $cont =~ s/>/&gt;/g;
            print $hout $cont;
         }
         $self -> close_element ($pelt);
      }
   }
} # write

sub comment {
   my ($self, $text) = @_;
   if (!$self -> {"is_open"}) {
      $self -> {"errmsg"} .= "OUTPUT NOT OPEN in comment\n";
   }
   else {
      my $hout   = $self -> {"hout"};
      my $indent = $self -> {"indent"};
      print $hout "\n" unless $self -> {"bol"};
      $text =~ s/--/-*-/g;
      print $hout ("$indent<!-- $text -->\n");
      $self -> {"bol"} = 1;
   }
   $self;
} # comment

sub write_meta {
   my ($self, $attributes) = @_;
   $self -> write ("meta", $attributes, $self -> {"meta"});
} # write_meta

sub meta {
   my $self = shift;
   $self -> {"meta"};
} # meta

sub ignore {
   my ($self, $regex) = @_;
   if (defined $regex) {
      $self -> {"reignore"} = qr/$regex/;
   }
   else {
      $self -> {"reignore"} = undef;
   }
   $self;
} # ignore

sub errormsg {
   my $self = shift;
   my $errormsg = $self -> {"errormsg"};
   $self -> {"errormsg"} = "";
   $errormsg;
} # errormsg

1;
# end of file KLEIDER/web/src/kalender/XMLDataWriter.pm