eg/oreilly_de_catalog/main.pm

package oreilly_de_catalog::main;

=pod

Testing Instructions:

Search for Kochbuch:      Umlaute correct?

Search for 389721:        Many fallback hits?

Search for an existing ISBN with correct dashes, with wrong dashes and
without dashes. If the ISBN is correct, you should get only one result.

Search for books that have more than one author: ampersand correctly
escaped?

Search for C#, C++, .net

Are the flags there and correct? E.g. "Java Foundation Classes"

Is the -M test for the stylesheet disabled?

Search for repkover which hits all "colophon"s.

Search while the indexer is running.

Search for <, &, >, ". Kein Server Error? Kommt schoen "sed & awk"?

Search for "&uuml;ber". Viele deutsche Buecher? Erscheint richtig
geschriebenes "ueber" im Textfeld? Benutze gleich das "ue" uns suche
nach "fuer" (mit echtem Umlaut).

Lego suchen wegen des Registered Zeichens. Aeh?

index_ora muss einmal mit --debug gelaufen sein und die ALL Dump Datei
muss man sich anschauen wg. Umlauten und Ticks. HTML::Entities (in
HTML::Parser) muss mit Support for high entities compiliert werden.

Search for word with "-".

Search for "-" alone. Should give no match.


=cut

use Apache::Constants ();
use Apache::Request;
use Apache::Session::Counted;
use Fcntl qw(O_RDONLY);
use HTTP::Date ();
use Apache::Util ();
use Apache::File ();
use WAIT::Database ();

use oreilly_de_catalog::config;
use oreilly_de_catalog::wait_filter;

use strict;

our $DEBUG_s = 0; # Searchterm wrt. UTF-8
our $XSLCACHE = {};

sub handler {
  my($r) = @_;
  my $req = __PACKAGE__->new(R => $r);
  $req->dispatch;
}

foreach my $fld ( qw(R CGI IF DEBUG DONE) ) {
  no strict 'refs';
  *{"get_$fld"} = sub {
    my ($self) = shift;
    $self->{$fld};
  };
  *{"set_$fld"} = sub {
    my ($self) = shift;
    $self->{$fld} = shift;
  };
}

sub session {
  my oreilly_de_catalog::main $self = shift;
  return $self->{SESSION} if defined $self->{SESSION};
  my $cgi = $self->get_CGI;
  my $sid = $cgi->param('SESSION');
  my %session;
  require Apache::Session::Counted;
  my $cntfile = $self->counterfile;
  my $rundatadir = oreilly_de_catalog::config::RUNDATADIR or die "RUNDATADIR not set";
  tie %session, 'Apache::Session::Counted',
      $sid, {
             Directory => "$rundatadir/sessions",
             DirLevels => 1,
             CounterFile => $cntfile,
            };
  $self->{SESSION} = \%session;
}

sub sessionid {
  shift->session->{_session_id};
}

sub counterfile {
  my oreilly_de_catalog::main $self = shift;
  my $rundatadir = oreilly_de_catalog::config::RUNDATADIR or die "RUNDATADIR not set";
  sprintf "%s/cnt/%s", $rundatadir, $self->today;
}

sub today {
  my oreilly_de_catalog::main $self = shift;
  return $self->{TODAY} if defined $self->{TODAY};
  my @today = localtime;
  $today[5]+=1900;
  $today[4]++;
  sprintf "%04d-%02d-%02d", @today[5,4,3];
}

sub handle_session {
  my $self = shift;
  my $oldsearchterm;
  $oldsearchterm = $self->session->{SearchTerm};
  my $cgi = $self->get_CGI;
  my $r = $self->get_R;
  my $no = $cgi->param("NO");
  $no = "" unless defined $no;
  my $oldsessionid = $cgi->param("SESSION");
  if (length $no) {
    my $waha = $self->session->{WaitActiveHitsArr};
    my $obj = $waha->[$no];
    my $due = $cgi->param("DUE") || "index";
    my $docid = $obj->{rec}{docid};
    my $redir = sprintf(
                        "http://%s%s",
                        $r->server->server_hostname,
                        $self->doclink($docid, $due),
                       );
    # warn "INFO: redir[$redir]";
    $r->header_out("Location",$redir);
    my $stat = Apache::Constants::REDIRECT();
    $r->status($stat);
    $r->send_http_header;
    my $fh = $self->statslogfile;
    $fh->printf("%s %s %s [%s] %d %d %s %s\n",
                HTTP::Date::time2iso(),                     # date blank time
                $oldsessionid,                              # coming from
                "s",                                        # eventtype select
                Apache::Util::escape_uri($oldsearchterm),   # what we searched
                $no,                                        # selected number
                $#$waha,                                    # highest possible number
                $docid,                                     # book ID
                $due,                                       # document within book
               );
    close $fh or die "Could not close statslog: $!";
    $self->set_DONE($stat);
    return;
  }
  my $fh = $self->statslogfile;
  $fh->printf("%s %s %s [%s] [%s]\n",
              HTTP::Date::time2iso(),                        # date blank time
              $oldsessionid,                                 # coming from
              "c",                                           # eventtype change
              Apache::Util::escape_uri($oldsearchterm),      # what we searched
              Apache::Util::escape_uri($self->searchterm), # new query
             );
  close $fh or die "Could not close statslog: $!";
}

sub dispatch {
  my($self) = @_;

  my $r = $self->get_R;
  my $cgi = Apache::Request->new($r);
  $self->set_CGI($cgi);

  my $uri = $r->uri;
  my $args = $r->args || "";
  my @m;

  # If they are victim of statistics, do statistics and redirect or
  # let them pass by as appropriate
  if ($cgi->param("SESSION")) {
    $self->handle_session;
    my $done = $self->get_DONE;
    return $done if $done;
  }

  # Do they want an interface?
  my($if) = $self->interface;

  # Does somebody need debugging?
  my $debug = $cgi->param("DEBUG") || "";
  if ($debug) { # debug
    $self->set_DEBUG($debug);
    my @param = $cgi->param;
    warn "uri[$uri]args[$args]param[@param]if[$if]";
  }

  if (rand(1) < oreilly_de_catalog::config::STATSSAMPLE ) {
    $self->{SetupForStats} = 1;
  }

  $self->wait_query;

  # now $self contains everything we need to construct the page.
  if ( $self->{SetupForStats} ) {
    my $session = $self->session;
    for my $k (qw(SearchTerm WaitActiveHitsArr)) {
      $session->{$k} = $self->{$k};
    }
    my $fh = $self->statslogfile;
    $fh->printf("%s %s %s [%s] %d %4.2f\n",
                HTTP::Date::time2iso(),                      # date blank time
                $self->sessionid,                            # starting session
                "n",                                         # eventtype new
                Apache::Util::escape_uri($self->searchterm), # what we searched
                $self->{NumHits},                            # hits we found
                oreilly_de_catalog::config::STATSSAMPLE,     # current representativity
               );
    close $fh or die "Could not close statslog: $!";
  }
  # require Devel::Peek;Devel::Peek::Dump($self->{WaitActiveHitsArr}[2]{rec}{title});

  my $content;
  if ($if) {
    my $xml = $self->construct_xml;
    # require Devel::Peek;Devel::Peek::Dump($xml); 
    $content = $self->convert_xml($xml);
  } else {
    $content = $self->direct_html; # can go away once we are sure XSLT always wins
  }

  $r->set_last_modified(int(time/86400)*86400);
  if ($r->protocol =~ /(\d)\.(\d)/ && $1 >= 1 && $2 >= 1){
    $r->header_out('Cache-Control', "max-age=" . 24*60*60);
  } else {
    $r->header_out('Expires',
                   HTTP::Date::time2str(time + 24*60*60));
  }

  require Encode;
  my $enccontent = Encode::encode_utf8($content);
  $content = $enccontent if $enccontent;
  $r->set_content_length(length $content);


  $r->send_http_header;
  $r->print($content);
  Apache::Constants::OK();
}

sub interface {
  my $self = shift;
  return $self->{IF} if defined $self->{IF};
  my $cgi = $self->get_CGI;
  my $if = $cgi->param("IF");
  $if ||= oreilly_de_catalog::config::DEFAULTSTYLESHEET;
  $self->set_IF($if);
  $if;
}

sub convert_xml {
  my $self = shift;
  my $xml = shift;

  # convert $xml into $content

  my $content = "";

  require XML::LibXML;
  require XML::LibXSLT;
  my $if = $self->interface;
  my $cgi = $self->get_CGI;
  my $r = $self->get_R;
  my $debug = $cgi->param("DEBUG") || "";

    my $parser = XML::LibXML->new();
    my $doc = $parser->parse_string($xml);
    my $stylesheet;
    if (oreilly_de_catalog::config::TESTMTIMESTYLESHEET &&
        exists $XSLCACHE->{$if} &&
        $XSLCACHE->{$if}{M}) {
      my $file = $XSLCACHE->{$if}{file};
      if (-M $file < $XSLCACHE->{$if}{M}) {
        delete $XSLCACHE->{$if};
      }
    }
    unless ($XSLCACHE->{$if}{sheet}) {
      my $stylefile = __FILE__;
      $stylefile =~ s/main\.pm$/$if.xsl/;
      $XSLCACHE->{$if}{file} = $stylefile;
      $XSLCACHE->{$if}{M} = -M $stylefile;
      open my $fh, "<", $stylefile or die "Could not open $stylefile: $!";
      local $/;
      my $styletxt = <$fh>;
      close $fh;
      my $xslt = XML::LibXSLT->new();
      my $style_doc = $parser->parse_string($styletxt);
      $stylesheet = $xslt->parse_stylesheet($style_doc);
      $XSLCACHE->{$if}{sheet} = $stylesheet;
    }
    $stylesheet ||= $XSLCACHE->{$if}{sheet};
    my $tdoc = $stylesheet->transform($doc);

    if ($debug) {
      if ($debug eq "DEBUG1") {
        $r->content_type("text/plain; charset=utf-8");
        $content = "$xml\n-|-|-|-|-|-|-|-|-\n" . $stylesheet->output_string($tdoc);
      } else {
        $r->content_type("text/html; charset=utf-8");
        my $args1 = my $args2 = $r->args;
        my $uri = $r->uri;
        $args1 =~ s/DEBUG=1/DEBUG=DEBUG1/;
        $args2 =~ s/DEBUG=1//;
        $content = qq{<html>
<title>O'Reilly Suche -- Debugging in Frames</title>
<frameset rows="75%,25%">
<frame src="$uri?$args1">
<frame src="$uri?$args2">
</frameset>
</html>

}; #'};
      }
    } else {
      $r->content_type("text/html; charset=utf-8");
      $content = $stylesheet->output_string($tdoc);
      $content =~ s|(\S)/>|$1 />|gs; # Netscape groks <br />, but not <br/>

      # Netscape 4.73 groks &#252; but not &#xFC;
      $content =~ s[&#x([\dA-F]+);][sprintf "&#%d;", hex $1]igse;

      # $content =~ s|</tr><tr>|</tr>\n<tr>|gs;


      if (0) {

        # The following line is WRONG, it would insert a newline even
        # into the content of the search textfield. It is here just as
        # a reminder.

        # $content =~ s|(.{80,}?)\s|$1\n|g; # a bit easier to debug
      }
    }
  $content;
}

sub statslogfile {
  my($self) = shift;
  my $file = oreilly_de_catalog::config::STATSLOGFILE;
  open my $fh, ">>", $file or die "Could not open $file: $!";
  return $fh;
}

sub new {
  my($me) = shift;
  bless { @_ }, ref($me) || $me;
}

sub textfield {
  my($self, %arg) = @_;
  my $name = $arg{name} || "";
  my $val = $self->{CGI}->param($name);
  require Encode;
  $val = Encode::decode_utf8($val);
  # require Devel::Peek;Devel::Peek::Dump($val);
  $val = $arg{default} || "" unless defined $val;
  my $ret = sprintf(qq{<input type="text" name="%s" value="%s"%s%s />},
                    $self->escapeHTML($name),
                    $self->escapeHTML($val),
                    exists $arg{size} ? qq{ size="$arg{size}"} : "",
                    exists $arg{maxlength} ? qq{ maxlength="$arg{maxlength}"} : ""
                   );
  # require Devel::Peek;Devel::Peek::Dump($ret);
  $ret;
}

sub searchterm {
  my($self) = @_;

  return $self->{SearchTerm} if defined $self->{SearchTerm};

  my $cgi = $self->get_CGI;
  my $q = $cgi->param("tfq") || ""; # q from the text field
  my @q = $cgi->param("rbq"); # q from radiobuttons
  my $sterm = join " ", $q, @q;

  $sterm =~ s/^\s+//;

  if ($sterm =~ /[\200-\377]/) {
    # XXX if they have both 8bit and entities we cannot just simply
    # decode_entities because then we might have UTF-8 and Latin-1
    # mixed in the string. It would be fair to issue a warning, but
    # I simply do not feel like it.

    # OK, let's assume we want to solve this: we split the string into
    # 7bit and 8bit chunks, apply decode_entities on the 7bit chunks
    # and something else to the 8bit chunks. Something like that....
  } else {
    require HTML::Entities;
    HTML::Entities::decode_entities($sterm);
  }

  require Unicode::String;
  if ($sterm =~ /([\200-\377]+)/) {
    warn sprintf "DEBUG: we found 8bit bytes or chars: [%s]", $1 if $DEBUG_s;
    my $warn;
    {
      # Put this in a scope of its own so we can warn() ASAP again
      local $^W=1;
      local($SIG{__WARN__}) = sub { $warn = $_[0]; };
      my $us = Unicode::String::utf8($sterm); #side effect: warning
    }
    if ($warn and $warn =~ /utf8/i) {
      warn "DEBUG: Es war nicht UTF8, also kann's nur latin1 sein" if $DEBUG_s;
      $sterm = Unicode::String::latin1($sterm)->utf8;
    } else {
      warn "DEBUG: no warning, so we believe it's UTF-8. sterm[$sterm]" if $DEBUG_s;
    }
    require Encode;
    my $tmp = Encode::decode_utf8($sterm);
    if (defined $tmp) {
      $sterm = $tmp;
    } else {
      $sterm = Encode::decode("latin1", $sterm);
    }
  }
  $cgi->param('tfq',$sterm);
  $self->{SearchTermAsTextField} = $self->textfield(
                                                    "name" => "tfq",
                                                    "size" => 30,
                                                   );

  # require Devel::Peek;Devel::Peek::Dump($self->{SearchTermAsTextField});

  if ($self->{SetupForStats}) {
    $self->{HiddenfieldForStats} = sprintf(
                                           qq{<input type="hidden"
 name="SESSION" value="%s" />},
                                           $self->sessionid,
                                          );
  }

  return $self->{SearchTerm} = $sterm;
}

sub wait_query {
  my($self) = @_;
  my $sterm = $self->searchterm or return;
  my $db = WAIT::Database->open(name      => oreilly_de_catalog::config::WAITDBNAME,
                                mode      => O_RDONLY,
                                directory => oreilly_de_catalog::config::WAITDIR,
                               ) or die;
  my $tb = $db->table(name => oreilly_de_catalog::config::WAITTBCATALOG) or die;
  my $overbook = 25; # Term "java xslt" gab nicht den Titel "Java and
                     # XSLT" als ersten Hit als wir nur 4-faches
                     # overbook hatten
  my %result;
  my %from;
  my(%weight) = (title => 4,
                 aboutauthor => 0.4,     # "parrot" reveiled must be low
                 abouttranslator => 0.4,
                 colophon => 0.6,
                 inx => 0.05,
                 isbn => 4, # 3-89721-227-7 reveiled that 1 is too small
                );
  my @attr = sort {
    ($weight{$a}||1) <=> ($weight{$b}||1)
  } $tb->fields; # must be sorted so that the truncating only occurs
                 # when the important fields have had their chance
 ATTR: for my $attr (@attr) {
    my $weight = $weight{$attr} || 1;
    # warn "DEBUG: attr[$attr]";
    my %r;
    %r = $tb->search({attr => $attr,
                      top =>  oreilly_de_catalog::config::WAITMAXHITS * $overbook,
                      cont => $sterm});
    if (0) { # debug
      my $hits = keys %r;
      warn "attr[$attr] sterm[$sterm] hits[$hits]";
    }
    my $cnt = 0;
  RESULT: while (my($key, $val) = each %r) {
      $result{$key} ||= 0;
      $result{$key} += $val*$weight;
      $from{$key}{$attr} = undef;

      last RESULT if $cnt++ > oreilly_de_catalog::config::WAITMAXHITS * $overbook;
      last if $cnt > oreilly_de_catalog::config::WAITMAXHITS * $overbook/(scalar @attr) &&
          scalar keys %result >= oreilly_de_catalog::config::WAITMAXHITS * $overbook;
    }
  }
  $self->{NumHits} = keys %result;
  if (%result) {
    $self->format_result(\%result, \%from, $tb);
  } else {
    $tb->close;
    my $overbook = 10;
    $tb = $db->table(name => oreilly_de_catalog::config::WAITTBFALLBACK) or die;
    my($wx,$wy) = oreilly_de_catalog::config::WAITALTWORDS =~ /(\d+)x(\d+)/;
    my $top = $wx * $wy;
    my %r = $tb->search(
                        {attr => "headline",
                         top => $top * $overbook,
                         cont => $sterm,
                        }
                       );
    if (%r) {
      $self->format_aoa(\%r,$tb);
    } else {
      $self->{WaitNothingFound}++;
      warn "Info: twice no hit on [$sterm]\n";
    }
    unless ($self->{WaitFallbackHitsAOA} || $self->{WaitActiveHitsArr}) {
      warn "Info: unexpectedly no hit on [$sterm]";
      $self->{WaitNothingFound}++;
    }
  }
  $tb->close;
}

sub format_aoa {
  my $self = shift;
  my $result = shift;
  my %result = %$result;
  my $tb = shift;

  my $no = 0; # we number the hits
  my @didaoa = ();
  my($wx,$wy) = oreilly_de_catalog::config::WAITALTWORDS =~ /(\d+)x(\d+)/;
  my $top = $wx * $wy;
  for my $did (sort { $result{$b} <=> $result{$a} } keys %result) {
    my %rec = $tb->fetch($did);
    my $ydim = int($no/$wx);
    my $xdim = $no % $wx;
    my $dispvalue = $rec{docid};
    my $checkbox = $self->checkbox("name" => "rbq",
                                   "value" => $dispvalue,
                                  );
    if ($dispvalue =~ /^\d{9}[\dX]$/i) {
      next; # we do not offer castrated ISBNs
    }
    $didaoa[$ydim][$xdim] = {
                             did => $did,
                             val => $result{$did},
                             checkbox => $checkbox,
                             dispvalue => $dispvalue,
                            };
    last if ++$no >= $top;
  }
  $self->{WaitFallbackHitsAOA} = \@didaoa if @didaoa;
}

sub format_result {
  my $self = shift;
  my $result = shift;
  my $from = shift;
  my $tb = shift;
  my %result = %$result;
  my %from = %$from;
  my $r = $self->get_R;
  my $uri = $r->uri;
  my $no = 0; # we number the hits
  my @did = ();
  my $maxval;
  for my $did (sort { $result{$b} <=> $result{$a} } keys %result) {
    $maxval ||= $result{$did};
    my %rec = $tb->fetch($did);
    for my $k (keys %rec) {
      $rec{$k} = $self->escapeHTML(Encode::decode_utf8($rec{$k}));
    }
    my $dueto = [ keys %{$from{$did}} ];
    use Image::Size ();
    my $gif = sprintf(qq{%s/covers/%s.s.gif},
                      oreilly_de_catalog::config::CATALOG,
                      $rec{docid});
    my $wh = "";
    if (-f $gif) {
      $wh = Image::Size::html_imgsize($gif);
    }
    my(@due,%due);
    @due{@$dueto} = ();
    delete $due{title};
    delete $due{abstract};
    my %duetree = (
                   author => { author => undef, aboutauthor => undef },
                   translator => { translator => undef, abouttranslator => undef },
                   desc => { desc => undef },
                   colophon => { colophon => undef },
                   chapter => { chapter => undef },
                   inx => { inx => undef },
                   toc => { toc => undef },
                  );
    my %duedict = (
                   author => "&Uuml;ber den Autor",
                   translator => "&Uuml;ber den &Uuml;bersetzer",
                   desc => "Ausf&uuml;hrliche Beschreibung",
                   toc => "Inhaltsverzeichnis",
                   inx => "Index",
                   colophon => "Kolophon",
                   chapter => "Probekapitel",
                  );
  DUE: for my $due (qw(desc author translator chapter toc inx colophon)) {
      for my $dues (keys %{$duetree{$due}}) {
        if (exists $due{$dues}) {
          if ($self->{SetupForStats}) {
            push @due, sprintf(
                               qq{<a href="%s?SESSION=%s;DUE=%s;NO=%s">%s</a>},
                               $uri,
                               $self->sessionid,
                               $due,
                               $no,
                               $duedict{$due},
                              );
          } else {
            push @due, sprintf(
                               qq{<a href="%s">%s</a>},
                               $self->doclink(
                                              $rec{docid},
                                              $due),
                               $duedict{$due},
                              );
          }
          next DUE;
        }
      }
    }
    my $hrefindex;
    if ($self->{SetupForStats}) {
      $hrefindex = sprintf(
                           "%s?SESSION=%s;DUE=index;NO=%s",
                           $uri,
                           $self->sessionid,
                           $no,
                          );
    } else {
      $hrefindex = sprintf(
                           qq{%s/%s/index.html},
                           oreilly_de_catalog::config::CATALOGROOTLOC,
                           $rec{docid},
                          );
    }
    my $coverlink = sprintf(qq{<a href="%s"><img class="cover" src="%s/covers/%s.s.gif" %s alt="cover" /></a>},
                            $hrefindex,
                            oreilly_de_catalog::config::CATALOGROOTLOC,
                            $rec{docid},
                            $wh,
                           );
    my $indexlink = sprintf(qq{<a href="%s">%s</a>},
                            $hrefindex,
                            $rec{title},
                           );
    my $duelinks = join(qq{<br />},@due);
    # warn "DEBUG: did[$did]";
    my $lang = $rec{docid} =~ /ger$/ ? "de" : "en";
    my $relval = int($result{$did} * 98.9 / ($maxval || 1))+1;

    $did[$no] = {
                 did => $did,
                 val => $result{$did},
                 dueto => $dueto,
                 rec => \%rec,
                 thumbnaillink => $coverlink,
                 indexlink => $indexlink,
                 duelinks => $duelinks,
                 lang => $lang,
                 relval => $relval,
                };
    last if ++$no >= oreilly_de_catalog::config::WAITMAXHITS;
  }
  $self->{WaitActiveHitsArr} = \@did;
}

sub doclink {
  my($self,$recdocid,$due) = @_;
  $due = "chapter/index" if $due eq "chapter";
  sprintf(
          qq{%s/%s/%s.html},
          oreilly_de_catalog::config::CATALOGROOTLOC,
          $recdocid,
          $due,
         );
}

# sub escapeHTML { # slow but doesn't lose the UTF8-Flag
sub escapeHTML_slow {
  my($self, $what) = @_;
  return unless defined $what;
  # require Devel::Peek;Devel::Peek::Dump($what);
  my %escapes = qw(& &amp; " &quot; > &gt; < &lt;); #");
  $what =~ s/([&\"<>])/$escapes{$1}/g; #}/;
  # require Devel::Peek;Devel::Peek::Dump($what);
  $what;
}


# sub escapeHTML_unreliablewithutf8 {
sub escapeHTML { # fast but loses the UTF-8 flag
  my($self, $what) = @_;
  return unless defined $what;
  # require Devel::Peek;Devel::Peek::Dump($what);
  require Apache::Util;
  $what = Encode::encode_utf8($what);
  my $ret = Apache::Util::escape_html($what);
  $ret = Encode::decode_utf8($ret);
  # require Devel::Peek;Devel::Peek::Dump($ret);
  $ret;
}

sub checkbox {
  my($self,%arg) = @_;

  my $name = $arg{name};
  my $value;
  defined($value = $arg{value}) or ($value = "on");
  my $checked;
  my @sel = $self->{CGI}->param($name);
  if (@sel) {
    for my $s (@sel) {
      if ($s eq $value) {
        $checked = 1;
        last;
      }
    }
  } else {
    $checked = $arg{checked};
  }
  sprintf(qq{<input type="checkbox" name="%s" value="%s"%s />},
          $self->escapeHTML($name),
          $self->escapeHTML($value),
          $checked ? qq{ checked="checked"} : ""
         );
}

sub construct_xml {
  my($self) = @_;
  my(@m);

  # if they want an interface, we need to convert our relevant data
  # to XML and feed it to some XSLT transformer.
  push @m, qq{<?xml version="1.0" encoding="UTF-8"?>
<!DOCTYPE stylesheet [
<!ENTITY Auml   "&#196;">
<!ENTITY Ouml   "&#214;">
<!ENTITY Uuml   "&#220;">
<!ENTITY szlig  "&#223;">
<!ENTITY auml   "&#228;">
<!ENTITY ouml   "&#246;">
<!ENTITY uuml   "&#252;">
]>

<root>
};
  for my $sfield (qw(

           SearchTermAsTextField HiddenfieldForStats WaitNothingFound

)) {
    next unless exists $self->{$sfield} && defined $self->{$sfield};
    push @m, sprintf(qq{<%s>%s</%s>\n},
                     $sfield,
                     $self->{$sfield},
                     $sfield);
  }
  # WaitFallbackHitsAOA, WaitActiveHitsArr
  if (exists $self->{WaitFallbackHitsAOA} and defined $self->{WaitFallbackHitsAOA}) {
    push @m, qq{<WaitFallbackHitsAOA>\n};
    for my $line (@{$self->{WaitFallbackHitsAOA}}) {
      push @m, qq{ <WaitFallbackHitsAOALine>};
      for my $col (@$line) {
        push @m, qq{  <WaitFallbackHitsAOACol>};
        for my $k (sort keys %$col) {
          # we have no escaping problem because the dictionary doesn't contain <>&
          push @m, qq{   <item key="$k">$col->{$k}</item>};
        }
        push @m, qq{  </WaitFallbackHitsAOACol>\n};
      }
      push @m, qq{ </WaitFallbackHitsAOALine>\n};
    }
    push @m, qq{</WaitFallbackHitsAOA>\n};
  }
  if (exists $self->{WaitActiveHitsArr} && defined $self->{WaitActiveHitsArr}) {
    push @m, qq{<WaitActiveHitsArr>};
    for my $item (@{$self->{WaitActiveHitsArr}}) {
      push @m, qq{ <WaitActiveHitsArrItem>\n};
      for my $k (sort keys %$item) {
        my $v = $item->{$k};
        if (ref $v eq "ARRAY") {
          push @m, qq{   <item key="$k">skipped array</item>\n};
        } elsif (ref $v eq "HASH") {
          push @m, qq{   <item key="$k">\n};
          for my $k2 (sort keys %$v) {
            # No escape problems: all field names clean, all field
            # values (so far) clean
            push @m, qq{    <rec field="$k2">$v->{$k2}</rec>\n};
          }
          push @m, qq{   </item>\n};
        } else {
          # No escape problem
          push @m, qq{   <item key="$k">$item->{$k}</item>\n};
        }
      }
      push @m, qq{ </WaitActiveHitsArrItem>\n};
    }
    push @m, qq{</WaitActiveHitsArr>};
  }
  push @m, qq{
</root>
};
  join "", @m;
}

sub direct_html {
  my($self) = @_;
  my(@m);

  # a bare-bone-page without XSLT. It was a pre-release study and I
  # leave it here in case XSLT breaks tomorrow

  push @m, qq{<html><head><title>O\'Reilly Verlag -- Suche</title></head><body>};
  # startform
  push @m, qq{<form method="get"><p>};
  # textfield
  push @m, $self->{SearchTermAsTextField};
  # maybe radiobuttons
  if ($self->{WaitFallbackHitsAOA}) {

    push @m, qq{<p>Zu Ihrem Suchbegriff wurde kein Dokument
      gefunden. Befindet sich unter den folgenden W&ouml;rtern ein
      passender Suchbegriff? Wenn ja, bitte klicken Sie einen oder
      mehrere Suchbegriffe an und anschlie&szlig;end auf &quot;Erneut
      Suchen&quot;.</p>};

    push @m, qq{<table cellpadding="2" cellspacing="6">};

  ALTTABLE: for my $yi (0..$#{$self->{WaitFallbackHitsAOA}}) {
      push @m, qq{<tr>};
      for my $xi (0..$#{$self->{WaitFallbackHitsAOA}[$yi]}) {
        push @m, qq{<td>};
        push @m, $self->{WaitFallbackHitsAOA}[$yi][$xi]{checkbox};
        push @m, " ";
        push @m, $self->{WaitFallbackHitsAOA}[$yi][$xi]{dispvalue};
        push @m, qq{</td>};
      }
      push @m, qq{</tr>};
    }
    push @m, qq{</table>};
    push @m, qq{<input type="submit" value="Erneut Suchen" />};
  }
  # endform
  push @m, qq{</p></form>};
  if ($self->{WaitNothingFound}) {

    push @m, "<p>Zu Ihrem Suchbegriff konnten wir leider gar nichts
      finden. Bitte versuchen Sie einen l&auml;ngeren oder mehrere
      Suchbegriffe.</p>";

  }
  # maybe answer
  if ($self->{WaitActiveHitsArr}) {
    push @m, qq{<table cellpadding="2" cellspacing="3">};
    for my $i (0..$#{$self->{WaitActiveHitsArr}}) {
      push @m, sprintf(qq{<tr>
<td align="center" valign="center">%s</td><td valign="top"><font size="5">
<b>%s</b></font><br />%s<br />ISBN %s<br /><br /><br />%s</td></tr>\n},
                       $self->{WaitActiveHitsArr}[$i]{thumbnaillink},
                       $self->{WaitActiveHitsArr}[$i]{indexlink},
                       $self->{WaitActiveHitsArr}[$i]{rec}{author},
                       $self->{WaitActiveHitsArr}[$i]{rec}{isbn},
                       $self->{WaitActiveHitsArr}[$i]{duelinks},
                      );
    }
    push @m, qq{</table>};
  }

  push @m, qq{</body></html>};
  my $r = $self->get_R;
  $r->content_type("text/html; charset=utf-8");
  join "", @m;
}

1;