#!/usr/bin/perl -w
# file KLEIDER/web/src/addstory/imgindex.pl
# Bewertet Bilder abhängig von der Beschreibung
# 2014-04-21 Herbert Schiemann <h.schiemann@herbaer.de>
# GPL Version 2 oder neuer

# 2012-01-31 Wort "wttl" im Bildtitel für Puppen in Umgebung
# 2012-05-21 Rock .. von ...kleid  geringer bewertet
# 2012-07-12 angepasst an geänderte Verzeichnis-Struktur
# 2012-08-22 Bilder mit "kleinerer" Position bevorzugt
# 2012-09-06 "wttl" aus Bildtitel entfernen
# 2013-06-14 Hochformat vor Querformat, noch vor Position, sectno
#            "Slip" nicht besonders bewertet
# 2013-06-15 rank + 10, wenn Bildtitel "kleid" nicht enthält
# 2013-09-06 Bilder, die die "Story" repräsentieren: repr, numrepr
# 2014-04-21 neue Bewertung für Bilder von einer Seite oder von hinten

package HB_ImageRank;
use utf8;
use Fcntl;                    # O_RDONLY
use File::Spec::Functions
  qw(catfile file_name_is_absolute splitpath catpath rel2abs abs2rel);
use POSIX qw(strftime);       # Zur Ausgabe der Zeit
use XML::SAX::ParserFactory ;

=pod
Ein SAX-Handler:

Bilder bekommen einen unterschiedlichen "Rang" (natürliche Zahl).
Eine kleine Zahl als Rang bedeutet,
dass ein Bild bevorzugt "indiziert" wird.
Jeder Abschnitt einer Bildergeschichte soll möglichst genau ein Bild
mit Rang 1 enthalten.
=cut
sub new {
   my ($class, $args) = @_;
   $class = ref($class) || $class;
   my $self = {};
   $self -> {"verbose"}  = $args -> {"[cnt]verbose"};
   $self -> {"parser"}   = XML::SAX::ParserFactory -> parser (Handler => $self);
   $self -> {"images"}   = {};
   $self -> {"count"}    = 0;
   $self -> {"prevalt"}  = "";  # Titel des vorhergehenden Bildes im Abschnitt
   return bless ($self, $class);
} # new

sub clear {
   my $self = shift;
   $self -> {"images"} = {};
   $self -> {"count"}  = 0;
} # clear

=pod
Bewertet Bilder einer Bildergeschichte

Paramter:
fnin:   Dateipfad der "Bildgeschichte"
=cut
sub add_story {
   my ($self, $fnin) = @_;
   -d $fnin and $fnin = catfile ($fnin, "story.xml");
   my $fhin;   # Dateihandle (Eingabe)
   my $verbose = $self -> {"verbose"};
   sysopen ($fhin, $fnin, O_RDONLY) or do {
      print STDERR "Kann Datei \"$fnin\" nicht lesen: $!\n" if $verbose;
      return undef;
   };
   $verbose && print STDERR "Datei $fnin\n";
   $self -> {"storyfile"}  = $fnin;  # Dateipfad der Bildergeschichte
   eval ( '$self -> {"parser"} -> parse_file ($fhin); 1;' ) or do {
      $self -> {"parser"} = XML::SAX::ParserFactory -> parser (Handler => $self);
      close ($fhin);
      print STDERR "Kann Datei \"$fnin\" nicht lesen: $!\n" if $verbose;
      return undef;
   };
   close ($fhin);
} # add_story

=pod
Schreibt die Ausgabe als XML

Parameter:
$fnout: Dateipfad der Ausgabedatei
$args:  HASHREF weiterer Argumente
=cut
sub  write_xml {
   my ($self, $fnout, $args, $meta) = @_;
   my $verbose = $self -> {"verbose"};
   $meta ||= {
      "filename" => $fnout,
      "time"     => strftime ("%Y-%m-%dT%H:%M:%S", localtime()),
   };
   my $fh;      # Dateihandle
   my $images  = $self -> {"images"};
   my ($k, $v); # Schlüssel/Wert-Paar
   my $xslt    = $args -> {"xslt"};
   if ($xslt ne "none" && file_name_is_absolute ($xslt)) {
      ($k, $v) = splitpath (rel2abs ($fnout));
      $xslt = abs2rel ($xslt, catpath ($k, $v, ""));
   }
   open ($fh, ">:encoding(utf-8)", $fnout) or do {
      print STDERR "Kann Datei \"$fnout\" nicht schreiben: $!\n" if $verbose;
      return;
   };
   print STDERR "Erstelle Datei \"$fnout\"\n" if $verbose;
   print $fh "<?xml version=\"1.0\" encoding=\"utf-8\"?>\n";
   print $fh "<?xml-stylesheet href=\"$xslt\" type=\"application/xml\"?>\n"
       if $xslt && $xslt ne "none"
   ;
   print $fh "<imgindex xmlns = \"http://herbaer.de/xmlns/20110902/imgindex\">\n";
   print $fh "<meta>\n";
   # wir sehen hier von "char escaping" ab (Prinzip Hoffnung)
   while ( ($k, $v) = each %$meta ) {
      replace_xmlchars (\$v);
      print $fh "<$k>$v</$k>\n";
   }
   print $fh "</meta>\n";
   $k = "numrepr";
   $v = $self -> {$k};
   print $fh "<$k>$v</$k>\n";
   while ( ($k, $v) = each %$images ) {
      print $fh "<image>\n";
      print $fh "<key>$k</key>\n";
      while ( ($k1, $v1) = each %$v ) {
         replace_xmlchars (\$v1);
         print $fh "<$k1>$v1</$k1>\n";
      }
      print $fh "</image>\n";
   }
   print $fh "</imgindex>\n";
} # write_xml

# Hilfsfunktion: Zeichen mit besonderer XML-Bedeutung ersetzen
# Der Parameter ist eine Referenz auf eine Zeichenkette
sub replace_xmlchars {
   my $v = shift;
   $$v =~ s/&/&amp;/g;
   $$v =~ s/</&lt;/g;
   $$v =~ s/>/&gt;/g;
   $$v =~ s/"/&quot;/g;
} # replace_xmlchars

# SAX-Handler-Methoden
sub start_document { 
   my $self = shift;
   $self -> {"images"} = {};
   $self -> {"sectno"} = 0;
} # start_document

sub start_element {
   my ($self, $el) = @_;
   my $attr = $el -> {'Attributes'};
   my $ln   = $el -> {'LocalName'};
   my $role = $attr -> {'{}role'} -> {'Value'} || "";
   if ($ln eq 'section') {
      $self -> {"cursect"} = {};   # noch kein bevorzugtes Bild für diesen Abschnitt
      $self -> {"prevalt"} = "";   # noch kein vorhergehendes Bild
      ++ $self -> {"sectno"};
      return;
   }
   return if $ln ne 'jpg';

   my $cs = $self -> {"cursect"};
   $attr -> {'{}src'} -> {'Value'} =~ /^([a-z0-9_]*)$/;
   my $h   = ($cs -> {$1} //= {}) ;
   $attr -> {'{}alt'} -> {'Value'} =~ /^(.*)$/;
   my $alt     = $1;
   my $prevalt = $self -> {"prevalt"};
   my $rank =
      $alt =~ /\b(?:Profil|Hüfte|Gesäß|Schulterblätter)\b/            ? 7 :
      $alt =~ /(?<!der )\bBrust\b(?!-)/                               ? 6 :
      $alt =~ /(?<!dem )\bRücken\b(?!-)/                              ? 6 :
      $alt =~ /(?<!den )\bSchultern\b(?!-)/                           ? 6 :
      $alt =~ /\b(?:Oberkörper|Beine)\b(?!-)/                         ? 6 :
      $alt =~ /\bRock\b.*?\bvon\b.*[kK]leid\b/                        ? 5 :
      $alt =~ /\btotal\b/                                             ? 3 :
      $alt =~ /\b(?:Porträt|Hüften|Passbild|wttl)\b/                  ? 5 :
      $alt =~ /\bim\b.*\b(?:Body|Badeanzug|Gymnastikanzug|Bikini)\b/  ? 2 :
      $alt =~ /\b(?:Body|Badeanzug|Gymnastikanzug|Bikini)\b/          ? 3 :
                                                                        4 ;
   $rank +=
      $alt =~ /\bvon\s+(?:links|rechts|hinten)\b/                              ? 10 :
      $alt =~ /(?<!dem )\bRücken\b(?!-)/ && $prevalt =~ /\bOberkörper\s+von\s/ ? 10 :
                                                                                  0 ;
   $rank += 20 unless $alt =~ /[Kk]leid\b/;
   $h -> {"rank"} = $rank if !$h -> {"rank"} || $h -> {"rank"} > $rank;
   $h -> {"position"} = ++ $self -> {"count"};
   $self -> {"prevalt"} = $alt;
   $alt =~ s/\s*\btotal\b\s*/ /;
   $alt =~ s/\s*\bwttl\b\s*/ /;
   $alt =~ s/\s+$//;
   $h -> {"alt"} //= $alt;
   if (! $h -> {"format"}) {
      $attr -> {'{}fmt'} -> {'Value'} =~ /^(.*)$/;
      $h -> {"format"} = $1 eq "h" || $1 eq "k" ? "hoch" : "quer";
   }
   $h -> {"sectno"} //= $self -> {"sectno"};
} # start_element

sub end_element {
   my ($self, $el) = @_;
   my $ln = $el -> {'LocalName'};
   if ($ln eq "section") {
      my $images = $self -> {"images"};
      my $cs     = $self -> {"cursect"};
      my $minrank = 10000;            # bisher kleinster Rang im aktuellen Abschnitt
      my $prefimg;                    # Kennung des bevorzugten Bildes
      my ($img, $idata);              # Bildkennung, Bilddaten im Abschnitt
      my $idataf;                     # Bilddaten im "Dokument"-Hash
      my $rank;                       # Rang
      my $pos;                        # Position eines Bildes
      my $prefpos;                    # Position des (bisher) bevorzugten Bildes
      my $fmt;                        # Format (hoch, quer) eines Bildes
      my $preffmt;                    # Format des (bisher) bevorzugten Bildes
      while ( ($img, $idata) = each %$cs ) {
         $rank = $idata -> {"rank"};
         $pos  = $idata -> {"position"};
         $fmt  = $idata -> {"format"};
         if (
            $rank < $minrank || ($rank == $minrank
            && ( ($preffmt eq "quer" && $fmt eq "hoch") || ($preffmt eq $fmt
            && $pos < $prefpos)))
         ) {
            $minrank = $rank;
            $prefimg = $img;
            $prefpos = $pos;
            $preffmt = $fmt;
         }
      }
      $cs -> {$prefimg} -> {"rank"} = 1 if $prefimg;
      while ( ($img, $idata) = each %$cs ) {
         if ( $idataf = $images -> {$img} ) {
            $idataf -> {"rank"} = $idata -> {"rank"}
            if $idata -> {"rank"} < $idataf -> {"rank"} ;
            $idataf -> {"alt"}  //= $idata -> {"alt"} ;
         }
         else {
            $images -> {$img} = $idata;
         }
      }
   }
   elsif ($ln eq "document") {
      my $images = $self -> {"images"};
      my ($img, $idata);             # Bildkennung, Bilddaten
      my $numrepr = 0;               # Anzahl der repräsentativen Bilder
      my $alt;                       # Bildtitel
      while ( ($img, $idata) = each %$images ) {
         if ( $idata -> {"rank"} == 1 ) {
            $alt = $idata -> {"alt"};
            # Im ersten Durchlauf Kleider, aber keine Schuhe
            if (
               $alt =~ /[Kk]leid/  &&
               $alt !~ /(?:[Ss]chuh|[Ss]tiefel|High[ -]Heel|Pumps|[Ss]andalen])/
            )
            {
               ++$numrepr;
               $idata -> {"repr"} = 1;
            }
         }
      }
      if (!$numrepr) {
         while ( ($img, $idata) = each %$images ) {
            if ( $idata -> {"rank"} == 1 ) {
               $alt = $idata -> {"alt"};
               # Zweiter Durchlauf: keine Schuhe
               if ( $alt !~ /(?:[Ss]chuh|[Ss]tiefel|High[ -]Heel|Pumps|[Ss]andalen])/ ) {
                  ++$numrepr;
                  $idata -> {"repr"} = 1;
               }
               else { $idata -> {"repr"} = 0; }
            }
         }
      }
      if (!$numrepr) {
         while ( ($img, $idata) = each %$images ) {
            if ( $idata -> {"rank"} == 1 ) {
               $alt = $idata -> {"alt"};
               # Dritter Durchlauf: Kleider
               if ( $alt =~ /[Kk]leid/ ) {
                  ++$numrepr;
                  $idata -> {"repr"} = 1;
               }
               else { $idata -> {"repr"} = 0; }
            }
         }
      }
      $self -> {"numrepr"} = $numrepr;
      $self -> {"prevalt"} = undef;
   }
} # end_element

1;
# end package HB_ImageRank;

package main;

use Cwd qw(realpath);
use Herbaer::Readargs;     # read_args ()
use File::Spec::Functions; # catfile
use POSIX qw(strftime);    # Zur Ausgabe der Zeit

binmode (STDERR, ":raw:encoding(utf-8)");

sub version {
   print <<'VERSION' ;
KLEIDER/web/src/addstory/imgindex.pl
2014-04-21 Herbert Schiemann <h.schiemann@herbaer.de>
VERSION
}

my $webbase = realpath($0);
$webbase =~ s/\/web\/src\/addstory\/imgindex\.pl//;

# Hash der Kommandozeilen-Argumente
my $args = {
   "[cnt]verbose"   => undef,
   "in"             => "story.xml",                              # Eingabedatei
   "out"            => undef,                                    # Ausgabedatei
   "xslt"           => "$webbase/src/addstory/imgindex_ht.xslt", # in der Ausgabe
   "ptn_in"         => "$webbase/docroot/s\${storyid}/story.xml",
   "ptn_out"        => "$webbase/imgix/imgix_\${storyid}.xml",
   "[cnt]overwrite" => undef,                                    # Dateien ersetzen
};

$args -> {"[sr]version"} = sub { version (); exit 0; };

$args -> {"[sr]help"} = sub {
   version ();
   set_default ($args);
   print_message_with_values (<<"HELP", $args);
$0 --help     zeigt diese Hilfe an
$0 --version  zeigt die Programm-Version an

$0 [option]...  [STORYID]...

--[no_]verbose     Umfang der Ausgabe nach STDERR
--in      INFILE   Pfad der Eingabedatei \${in}
--out     OUTFILE  Pfad der Ausgabedatei \${out}
--xslt    XSLT     XSLT-Stylesheet der Ausgabe oder none
                   \${xslt}
--ptn_in  PTN_IN   Muster der Dateipfade der Eingabedateien
                   \${ptn_in}
--ptn_out PTN_OUT  Muster der Dateipfade der Ausgabedateien
                   \${ptn_out}
--[no_]overwrite   Existierende Dateien ersetzen \${[cnt]overwrite}
STORYID            Kennung einer Bildergeschichte
HELP
   exit 0;
}; # version

sub set_default {
   my $args = shift;
   my $f  = $args -> {"in"};
   -d $f and $args -> {"in"} = catfile ($f, "story.xml");
   $f = $args -> {"out"};
   if (! $f) {
      $f = $args -> {"in"};
      $f =~ s/\.xml$//;
      $f =~ s/\.+$//;
      $args -> {"out"} = "$f.imgix.xml" ;
   }
} # set_default

read_args ($args);
set_default ($args);

my $imgrank = new HB_ImageRank ($args);

# Schleife über die Kennungen der Bildergeschichten
sub loop_storyids {
   my ($imgrank, $args, $sids) = @_;
   my $ptn_in  = $args -> {"ptn_in"};
   my $ptn_out = $args -> {"ptn_out"};
   my $owrite  = $args -> {"[cnt]overwrite"};
   my $verbose = $args -> {"[cnt]verbose"};
   my ($fpin, $fpout);  # Pfade von Ein- und Ausgabedatei
   my $sid;
   for $sid (@$sids) {
      $fpin  = $ptn_in;
      $fpin  =~ s/\$\{storyid\}/$sid/ge ;
      if ( ! -r $fpin ) {
         print STDERR "Kann Datei \"$fpin\" nicht lesen\n" if $verbose;
         next;
      }
      $fpout = $ptn_out;
      $fpout =~ s/\$\{storyid\}/$sid/ge ;
      if (-e $fpout) {
         if ($owrite) {
            print STDERR "Lösche Datei \"$fpout\"\n" if $verbose;
            unlink $fpout;
         }
         if (-e $fpout) {
            print STDERR "Datei \"$fpout\" existiert\n" if $verbose;
            next;
         }
      }
      print "Verarbeite \"$fpin\" -> \"$fpout\"\n" if $verbose;
      $imgrank -> clear ();
      $imgrank -> add_story ($fpin);
      $imgrank -> write_xml (
         $fpout,
         $args,
         {
            "filename" => $fpout,
            "time"     => strftime ("%Y-%m-%dT%H:%M:%S", localtime()),
            "storyid"  => $sid,
            "srcfile"  => $fpin,
         }
      );
   }
} # loop_storyids

if ($args -> {"_argv"} && @{$args -> {"_argv"}}) {
   loop_storyids ($imgrank, $args, $args -> {"_argv"});
}
elsif ($args -> {"in"}) {
   my $f = $args -> {"in"};
   if (-f $f) {
      $imgrank -> add_story ($args -> {"in"});
      $imgrank -> write_xml ($args -> {"out"}, $args);
   }
   else {
      print STDERR "Datei \"$f\" existiert nicht.\n" if $args -> {"[cnt]verbose"};
   }
}
# end of file KLEIDER/web/src/addstory/imgindex.pl