File Coverage

blib/lib/SeeAlso/Source/BeaconAggregator/Publisher.pm

Criterion	Covered	Total	%
statement	7	9	77.7
branch			n/a
condition			n/a
subroutine	3	3	100.0
pod			n/a
total	10	12	83.3

package SeeAlso::Source::BeaconAggregator::Publisher;
use strict;
use warnings;

our $VERSION = "0.2_90";

=head1 NAME

SeeAlso::Source::BeaconAggregator::Publisher - additional methods for SeeAlso::Source::BeaconAggregator

=head1 SYNOPSIS

  $source = SeeAlso::Source::BeaconAggregator::Publisher->new(...);

=head1 DESCRIPTION

This package provides the functionallity to export a BEACON file from the
data connected with an SeeAlso::Source::BeaconAggregator instance and
also the additional formats "redirect" and "sources" which universally
can be used as callbacks for SeeAlso::Server (replacing the default
"seealso" method yielding JSON data).

=cut

our %Defaults = (
#   "REVISIT" => 86400,             # one day
    "REVISIT" => undef,             # no default (leave empty unless otherwise set)
    "uAformatname" => "sources",
    "beaconformatname" => "beacon",
    "FORMAT"  => "BEACON",
    "VERSION" => "0.1",             # no other exist
);

use SeeAlso::Source::BeaconAggregator;
use Carp;

=head2 new ( ... )

Creates an SeeAlso::Source::BeaconAggregator object with additional methods from
this package enabled

=cut

sub new {                 # directly create BeaconAggregator instance with extended features...
  my $class = shift @_;
  push(@SeeAlso::Source::BeaconAggregator::ISA, $class);
  return SeeAlso::Source::BeaconAggregator->new(@_);
}


=head2 activate ()

Makes SeeAlso::Source::BeaconAggregator objects member of this class,
globally enabling the additional methods

Usage:

  $db = SeeAlso::Source::BeaconAggregator::Maintenance->new(...);
  ...
  do stuff
  ...
  require SeeAlso::Source::BeaconAggregator::Publisher
          or die "could not require Publisher extension";
  SeeAlso::Source::BeaconAggregator::Publisher->activate();   # "recast" all objects
  ...
  do more stuff

=cut
sub activate {            # enrich SeeAlso::Source and derived classes with our methods
  my $class = shift @_;
  push(@SeeAlso::Source::BeaconAggregator::ISA, $class);
  return 1;
}


### Produktion der Beacon-Datei

=head2 beacon ( [dumpmeta arguments] )

produces a BEACON file (however, $cgibase is mandatory)

=head2 dumpmeta ( [$cgibase, [$uAformatname, [$headersonly]]] [, $preset])

produces only the meta fields of a BEACON file

Meta fields are generated from the $preset Hashref, falling back to
values stored in the database, falling back to reasonable default
values.

Arguments:

=over 8

=item $cgibase

URL of the SeeAlso service the BEACON file is provided for

=item $uAformatname

unAPI format name to be used as target (Default: "sources")

=item $headersonly

currently unused

=item $preset

Hashref of Beacon header fields overriding the contents of the database

=back

Regular Usage:

  $db = SeeAlso::Source::BeaconAggregator::Publisher->new(...);
  binmode(STDOUT, ":utf8");
  my $cgibase = "http://address/of/service";
  my ( $error, $headerref) = $db->beacon($cgibase, @ARGV, {'FORMAT' => 'PND-BEACON'});


CGI Usage:

  $format = $CGI->param('format') || "";
  if ( $format eq "beacon" ) {  # bypass SeeAlso::Server->query() b/c performance / interim storage
                                  insert access restrictions here...
      do_beacon($source, $CGI);
    }
  ...

 sub do_beacon {
   my ($self, $cgi) = @_;           # Of type SeeAlso::Source::BeaconAggregator
   unless ( $self->can("beacon") ) {
       croak "On the fly generation of beacon Files not supported by this service";}
   my $cgibase = $cgi->url(-path_info=>1);

   print $cgi->header( -status => 200,
                      -expires => '+1d',
                         -type => 'text/plain',
                      -charset => 'utf-8',
                      );
   return $self->beacon($cgibase, "sources", {});     # prints directly to stdout..., returns $error, $headerref
 }

=cut

sub beacon {
  my ($self) = shift @_ or croak("beacon is a method!");         # Of type SeeAlso::Source::BeaconAggregator
  my ($error, $headerref) = $self->dumpmeta(@_);
  croak("Error generating Header, will not proceed") if $error;

  print @$headerref;

  my $c = (defined $self->{identifierClass}) ? $self->{identifierClass} : $self->autoIdentifier();

  my ($sth, $sthexpl) = $self->stmtHdl(<<"XxX");
SELECT hash, COUNT(DISTINCT seqno) FROM beacons GROUP BY hash ORDER BY hash;
XxX
  $self->stmtExplain($sthexpl) if $ENV{'DBI_PROFILE'};
  $sth->execute() or croak("Could not execute >".$sth->{Statement}."<: ".$sth->errstr);
  my $rows = 0;
  while ( my $row = $sth->fetchrow_arrayref ) {
      $rows++;
      my $expanded = $row->[0];
      if ( defined $c ) {
# compat: hash might not take an argument, must resort to value, has to be cleared before...
	  $c->value("");
          my $did = $c->hash($row->[0]) || $c->value($row->[0]);
          $expanded = $c->can("pretty") ? $c->pretty() : $c->value();
                 # illegal identifier b/c different classes for loading and exporting?
          next unless defined $expanded && ($expanded ne "");
        }
      print $expanded.(($row->[1] > 1) ? "|".$row->[1] : "")."\n";
    }

  return $rows, $headerref;
}

sub dumpmeta {    # cgibase unAPIformatname headers_only {preset}
  my ($self) = shift @_ or croak("dumpmeta is a method!");         # Of type SeeAlso::Source::BeaconAggregator
  my ($error, @result) = (0, ());

  my $cgibase = shift @_ if @_ && !ref($_[0]);
  my $uAformatname = shift @_ if @_ && !ref($_[0]);
  $uAformatname ||= $Defaults{'uAformatname'};
  my $headersonly = shift @_ if @_ && !ref($_[0]);
  my $preset = (@_ && ref($_[0])) ? (shift @_) : {};

  my ($metasth, $metasthexpl) = $self->stmtHdl(<<"XxX");
SELECT key, val FROM osd;
XxX
  $self->stmtExplain($metasthexpl) if $ENV{'DBI_PROFILE'};
  $metasth->execute() or croak("Could not execute >".$metasth->{Statement}."<: ".$metasth->errstr);

  my (%osd, %beaconmeta);
  while ( my $aryref = $metasth->fetchrow_arrayref ) {
      my ($key, $val) = @$aryref;
      next unless $val;
      if ($key =~ s/^bc// ) {        # BeaconMeta Fields
          $beaconmeta{$key} = $val}
      elsif ( exists $osd{$key} ) {
          if ( ref($osd{$key}) ) {
              push(@{$osd{$key}}, $val)}
          else {
              $osd{$key} = [$osd{$key}, $val]};
        }
      else {
          $osd{$key} = $val};
    };
  my @osdexamples;
  if ( $osd{'Examples'} && ref($osd{'Examples'}) ) {
      foreach my $expl ( @{$osd{'Examples'}} ) {
          $expl =~ s/\s*\|.*$//;
          push(@osdexamples, $expl);
        }
    }
  elsif ( my $expl = $osd{'Examples'} ) {
      $expl =~ s/\s*\|.*$//;
      push(@osdexamples, $expl);
    };

  foreach ( grep /^[A-Z]+$/, keys %$preset ) {
      $beaconmeta{$_} = $preset->{$_}}
# Mandatory fields
  push(@result, "#FORMAT: ".($beaconmeta{'FORMAT'} || $Defaults{'FORMAT'})."\n");
  push(@result, "#VERSION: ".($beaconmeta{'VERSION'} || $Defaults{'VERSION'})."\n");
  if ( $beaconmeta{'TARGET'} ) {
      $beaconmeta{'TARGET'} =~ s/^\{BASE\}/$cgibase/;
      push(@result, "#TARGET: $beaconmeta{'TARGET'}\n");
    }
  elsif ( $cgibase ) {
      push(@result, "#TARGET: $cgibase?format=$uAformatname&id={ID}\n")}
  else {
      carp "Don't know how to construct the mandatory #TARGET field!";
      $error ++;
    }

  my $timestamp = $preset->{'TIMESTAMP'} || $osd{DateModified} || $^T;
  push(@result, "#TIMESTAMP: ".SeeAlso::Source::BeaconAggregator::tToISO($timestamp)."\n") if $timestamp > 0;
  my $revisit = ($beaconmeta{'REVISIT'} || $Defaults{'REVISIT'}) || "";
  $revisit =~ tr/ //d;
  $revisit =~ s/(\d+)mo\w*/($1*30)."d"/ei;
  $revisit =~ s/(\d+)M\w*/($1*30)."d"/e;
  $revisit =~ s/(\d+)w\w*/($1*7)."d"/ei;
  $revisit =~ s/(\d+)d\w*/($1*24)."h"/ei;
  $revisit =~ s/(\d+)h\w*/($1*60)."m"/ei;
  $revisit =~ s/(\d+)m\w*/($1*60)."s"/ei;
  $revisit =~ s/(\d+)s\w*/$1/i;
  push(@result, "#REVISIT: ".SeeAlso::Source::BeaconAggregator::tToISO($timestamp + $revisit)."\n") if $revisit && ($revisit =~ /^[+-]?\d+$/) && ($revisit > 0);;

# $beaconmeta{'UPDATE'} ||= "daily";
  $beaconmeta{'FEED'} ||= "$cgibase?format=".$Defaults{'beaconformatname'} if $cgibase;
  $beaconmeta{'EXAMPLES'} ||= join("|", @osdexamples);
  $beaconmeta{'CONTACT'} ||= $self->{Contact} || $osd{'Contact'};
  $beaconmeta{'DESCRIPTION'} ||= $self->{Description} || $osd{'Description'};
  $beaconmeta{'NAME'} ||= $self->{ShortName} || $osd{'ShortName'};
  foreach ( grep !/^(FORMAT|REVISIT|TARGET|TIMESTAMP|VERSION)$/, SeeAlso::Source::BeaconAggregator->beaconfields() ) {
      next unless my $val = $beaconmeta{$_};
      next if $val =~ /^-/;
      $val =~ s/\s+/ /g; $val =~ s/^\s+//; $val =~ s/\s+$//;
      push(@result, "#$_: $val\n");
    }

# extract admin info of last transaction (i.e. last possible modification of underlying data)
# alternatively: SELECT seqno, utime FROM repos WHERE seqno=(SELECT MAX(seqno) FROM repos);
  my ($laststh, $laststhexpl) = $self->stmtHdl(<<"XxX");
SELECT MAX(seqno), MAX(mtime) FROM repos;
XxX
  $self->stmtExplain($laststhexpl) if $ENV{'DBI_PROFILE'};
  $laststh->execute() or croak("Could not execute >".$laststh->{Statement}."<: ".$laststh->errstr);
  if ( my $aryref = $laststh->fetchrow_arrayref ) {
      my ($sq, $ut) = @$aryref;
      push(@result, "#X-REVISION: $sq [".SeeAlso::Source::BeaconAggregator::tToISO($ut)."]\n") if $sq;
    };
  my $admref = $self->admhash();
  if ( my $cu = $admref->{'gcountu'} ) {
      my $type = $admref->{'IDENTIFIER_CLASS'} || "";
      push(@result, "#X-EXTENT: $cu unique identifiers".($type ? " of type $type" : "")."\n");
    };


## PND-BEACON
#                CONTACT => ['VARCHAR(63)'],
#            INSTITUTION => ['VARCHAR(255)'],
#                   ISIL => ['VARCHAR(63)'],
#            DESCRIPTION => ['VARCHAR(255)'],
## BEACON
#                MESSAGE => ['VARCHAR(255)'],    # enthaelt {hits}
#             ONEMESSAGE => ['VARCHAR(255)'],
#            SOMEMESSAGE => ['VARCHAR(255)'],
#                 PREFIX => ['VARCHAR(255)'],
## WInofficial
#                   NAME => ['VARCHAR(255)'],

  return $error, \@result;
}


=head2 redirect ( $server, $format, $extra, $query )

Produces an HTTP redirect page, HTML content contains very terse details in case
of multiple results.

This subroutine may be used as callback method in SeeAlso::Server

Usage is a bit cludgy due to author's lack of understanding of SeeAlso::Server

  $source = SeeAlso::Sources::BeaconAggregator::Publisher->new(...);
  $CGI = CGI->new();

  $formats = {
    ...
    redirect => {
           type => "text/html",
           docs => "http://www.endofthe.net/",
#        method => \&SeeAlso::Source::BeaconAggregator::Publisher::redirect,
  #redirect_300 => 'sources',
                }
  };

  $server   = SeeAlso::Server->new (
          'cgi' => $CGI,
      'formats' => $formats,
       ...
  );

  # Closure as fix: Server.pm does not expose self, $source and the CGI object to the format methods
  my $oref = \&SeeAlso::Source::BeaconAggregator::Publisher::redirect;
  $server->{'formats'}->{'redirect'}->{method}
    = sub {return &$oref($source, $server, $method, $formats->{$method}, @_)};

  my $result = $server->query($source);

Arguments:

=over 8

=item $server

SeeAlso::Server object. Must contain a CGI object

=item $format

Name of a format registered with the $server object ()

=item $extra

Hashref with the following configuration directives

  redirect_300 => CGI 'format' parameter to be used in HTML content (eg. format=sources)

  force_single => Only regard the first hit (thus always redirect)

=item $query

Identifier to be queried

=back

=cut

sub redirect {          # Liste der Beacon-Header fuer Treffer oder einfaches redirect
  my ($self, $server, $format, $extra, $query) = @_;
  my $formatprops = $server->{'formats'}->{$format} || {};
  my $cgi = $server->{'cgi'} or croak("I rely on a prepared CGI.pm object");

  my %headerdefaults = (               -type => ($formatprops->{'type'} || 'text/html'),
#      ($formatprops->{'charset'} ? (-charset =>  $formatprops->{'charset'}) : ()),
                                     -charset => ($formatprops->{'charset'} || 'UTF-8'),
                                    -expires => ($server->{'expires'} || '+1h'),
    );

  my ($hash, $pretty, $canon) = $self->prepare_query($query);
  unless ( $hash ) {
      print $cgi->header(-status => "400 Bad Request (Identifier '$query' not valid)",
                        -expires => "+1y",
                           -type => 'text/html',
                         ),
            $cgi->start_html (-dtd => "-//W3C//DTD HTML 3.2 Final//EN",
                            -title => "No valid identifier",
                              ),
            $cgi->p("Malformed identifier '$query'"),
            $cgi->end_html;
      return "";
    };

  my $clusterid;
  if ( $self->{cluster} ) {
      my ($clusterh, $clusterexpl) = $self->stmtHdl("SELECT beacons.altid FROM cluster.beacons WHERE beacons.hash=? OR beacons.altid=? LIMIT 1;");
      $self->stmtExplain($clusterexpl, $hash, $hash) if $ENV{'DBI_PROFILE'};
      $clusterh->execute($hash, $hash);
      while ( my $onerow = $clusterh->fetchrow_arrayref() ) {
          $clusterid = $onerow->[0];}
    }

  my $clause = $extra->{force_single} ? "LIMIT 1" : "ORDER BY repos.sort, repos.alias";
  my (  $tfield,$afield,  $gfield,  $mfield,$nfield,$ifield) = map{ scalar $self->beaconfields($_) }
      qw(TARGET  ALTTARGET IMGTARGET MESSAGE NAME   INSTITUTION);
# above  5       6         7         8       9      10
# below        0              1             2             3       4
#            11
  my ($sth, $sthexpl);
  if ( $clusterid ) {  # query IN cluster
      ($sth, $sthexpl) = $self->stmtHdl(<<"XxX");
SELECT beacons.hash, beacons.altid, beacons.hits, beacons.info, beacons.link,
       repos.$tfield, repos.$afield, repos.$gfield, repos.$mfield, repos.$nfield, repos.$ifield,
       repos.alias
  FROM beacons NATURAL LEFT JOIN repos
  WHERE ( (beacons.hash=?)
       OR (beacons.hash IN (SELECT cluster.beacons.hash FROM cluster.beacons WHERE cluster.beacons.altid=?)) )
  $clause;
XxX
      $self->stmtExplain($sthexpl, $clusterid, $clusterid) if $ENV{'DBI_PROFILE'};
      $sth->execute($clusterid, $clusterid) or croak("Could not execute >".$sth->{Statement}."<: ".$sth->errstr);
    }
  else {
      ($sth, $sthexpl) = $self->stmtHdl(<<"XxX");
SELECT beacons.hash, beacons.altid, beacons.hits, beacons.info, beacons.link,
       repos.$tfield, repos.$afield, repos.$gfield, repos.$mfield, repos.$nfield, repos.$ifield,
       repos.alias
  FROM beacons NATURAL LEFT JOIN repos
  WHERE beacons.hash=?
  $clause;
XxX
      $self->stmtExplain($sthexpl, $hash) if $ENV{'DBI_PROFILE'};
      $sth->execute($hash) or croak("Could not execute >".$sth->{Statement}."<: ".$sth->errstr);
    }

  my $c = $self->{identifierClass} || undef;
  my @rawres;
  my %didalready;
  while ( my $onerow = $sth->fetchrow_arrayref ) {
      next if $onerow->[11] && exists $self->{'aliasfilter'}->{$onerow->[11]};
      my $uri = $onerow->[4];         # Evtl. Expliziter Link
      my $guri = "";

      my $h = $onerow->[0];
      my $p;
      if ( $h eq $hash ) {
          $p = $pretty}
      elsif ( $clusterid && ref($c) ) {
          $c->value("");
          my $did = $c->hash($h) || $c->value($h) || $h;
          $p = $c->can("pretty") ? $c->pretty() : $c->value();
        };
      $p = ($clusterid ? $h : $pretty) unless defined $p;

      if ( $onerow->[1] ) {      # Konkordanzformat
          $uri ||= sprintf($onerow->[6] || $onerow->[5], $p, SeeAlso::Source::BeaconAggregator::urlpseudoescape($onerow->[1]));
          $guri = sprintf($onerow->[7], $p, SeeAlso::Source::BeaconAggregator::urlpseudoescape($onerow->[1])) if $onerow->[7];
        }
      elsif ( $onerow->[5] ) {                    # normales Beacon-Format
          $uri ||= sprintf($onerow->[5], $p);
          $guri = sprintf($onerow->[7], $p) if $onerow->[7];
        };
      next unless $uri;

#                       #NAME         #INSTITUTION  _alias
      my $label;
      if ( $label = $onerow->[8] ) { #MESSAGE
          $label = sprintf($label, $onerow->[2] || "...")}
      elsif ( $label = $onerow->[9] || $onerow->[10] || $onerow->[11] || "???" ) {
          $label .= " (".$onerow->[1].")" if $onerow->[1]}

      push(@rawres, [$uri, $guri, $label, $onerow->[11], $onerow->[3]]) unless $didalready{join("\x7f", $label, $uri)}++;;
    };
  my $hits = scalar @rawres;

  if ( ! $hits ) {
      print $cgi->header(-status => "404 Not Found (identifier '$canon')",
                         %headerdefaults),
            $cgi->start_html (-dtd => "-//W3C//DTD HTML 3.2 Final//EN",
                            -title => "No References for $pretty",
                              ),
            $cgi->p("No References found for ", $cgi->a({href=>"$canon"}, $pretty)),
            $cgi->end_html;
      return "";
    }
  elsif ( $hits == 1 ) {
      return $cgi->redirect(-status => "302 Found (Redirecting for identifier '$canon')",
                               -uri => $rawres[0]->[0],
                            %headerdefaults);
    }

  my $sources = new CGI($cgi);
  $sources->param(-name => 'id', -value=>"$canon");
  unless ( $canon =~ /:\/\// ) {
      my ($osd, $beaconmeta) = $self->get_meta;
      my $prefix = $beaconmeta->{'PREFIX'} || "";
      $canon = "$prefix$pretty" if $prefix;
    };
  if ( my $multired = $extra->{redirect_300} ) {
      $sources->param(-name => 'format', -value=>$multired);
      print $cgi->redirect(-status => "300 Multiple Choices for identifier '$canon'",
                              -uri => $sources->url(-path_info=>1, -query=>1),
                           %headerdefaults);
    }
  else {
      print $cgi->header(-status => "300 Multiple Choices for identifier '$canon'",
#                           -nph => 1,    # for older CGI/mod_perl???
                         %headerdefaults);
# mod_perl overrides the header and adds a custom document at the end of everything
# therefore we force the header out (a simple print "" does not suffice) and then can
# safely reset the status to OK via CGI.pm leaking the Apache2::Request object
      if ( my $r = $sources->r ) {
          local($|) = 1;
          print "\n";
          $r->status(200);
        };
    };
  my @result;
  push(@result, $cgi->start_html ( -title => "$hits References for $pretty",
                                     -dtd => "-//W3C//DTD HTML 3.2 Final//EN"),
                $cgi->h1("$hits References for ", $cgi->a({href=>"$canon"}, $pretty)),
                '');

  my $rowcnt = 0;
  foreach ( @rawres ) {  # uri, guri, label, alias, info
      if ( $_->[1] ) {
          my $tooltip = $_->[4] ? ($_->[4]." [".$_->[2]."]") : $_->[2];
          my $img =  $cgi->a({href=>$_->[0], title=>$tooltip}, $cgi->img({src=>$_->[1], alt=>$_->[4]||$_->[2], style=>"width: 5em; border: 0pt;"}));
          push(@result, $cgi->li({id=>"$_->[3]".++$rowcnt}, $img, $cgi->a({href=>$_->[0]}, $_->[2]), ($_->[4] ? " [".$_->[4]."]" : "")));
        }
      else {
          push(@result, $cgi->li({id=>"$_->[3]".++$rowcnt}, $cgi->a({href=>$_->[0]}, $_->[2]), $_->[4] ? " [".$_->[4]."]" : ""))};
    };

  push(@result, '');

  if ( $server->{'formats'}->{'sources'} ) {
      $sources->param(-name => 'format', -value=>"sources");
      push(@result, $cgi->p("[", $cgi->a({href=>($sources->url(-path_info=>1, -query=>1))}, "Details"), "]"));
    };

  my($tu, $ts, $tcu, $tcs) = times();
  push(@result, sprintf("", $tu, $ts, $tu+$ts), $cgi->end_html());
  return join("\n", @result);
}

=head2 sources ( $server, $format, $extra, $query )

Produces an HTML page with details to the queried identifier (description of sources)

This subroutine may be used as callback method in SeeAlso::Server (cf. description
of redirect above

=over 8

=item $server

SeeAlso::Server object


=item $format

Format selected for $server


=item $extra

Hashref with the following configuration directives

  css => URL of css file to be referenced

=item $query

Identifier to be queried

=back

=cut

sub sources {          # Liste der Beacon-Header fuer Treffer
                       # We escape all characters except US-ASCII, because older CGI.pm's set an xml declaration
                       # which somehow interferes with IE8's adherence to the character set...
  my ($self, $server, $format, $extra, $query) = @_;
  my $formatprops = $server->{'formats'}->{$format} || {};
  my $cgi = $server->{'cgi'} || CGI->new();

  my ($hash, $pretty, $canon) = $self->prepare_query($query);
  unless ( $hash ) {
      print $cgi->header(-status => "400 Bad Request (Identifier '$query' not valid)",
                        -expires => "+1y",
                           -type => 'text/html',
                         ),
            $cgi->start_html (-dtd => "-//W3C//DTD HTML 3.2 Final//EN",
                            -title => "No valid identifier",
                              ),
            $cgi->p("Malformed identifier '$query'"),
            $cgi->end_html;
      return "";
    };

  my ($clusterid, %idlist);
  my $c = $self->{identifierClass} || undef;
  if ( $self->{cluster} ) {
      my ($clusterh, $clusterexpl) = $self->stmtHdl("SELECT beacons.hash, beacons.altid FROM cluster.beacons WHERE beacons.hash=? OR beacons.altid=? LIMIT 1;");
      $self->stmtExplain($clusterexpl, $hash, $hash) if $ENV{'DBI_PROFILE'};
      $clusterh->execute($hash, $hash) or croak("Could not execute >".$clusterh->{Statement}."<: ".$clusterh->errstr);
      while ( my $onerow = $clusterh->fetchrow_arrayref() ) {
          $clusterid = $onerow->[1];
          my $h = $onerow->[0];
          if ( $c ) {
              $c->value("");
              my $did = $c->hash($h) || $c->value($h);
              my $p = $c->can("pretty") ? $c->pretty() : $c->value();
              $idlist{$p} = "";
            }
           else {
              $idlist{$h} = "";
            }
        };
      $idlist{$pretty} = "queriedid";
      if ( $clusterid ) {
          if ( $clusterid eq $hash ) {
              $idlist{$pretty} .= " preferredid"}
          elsif ( $c ) {
              $c->value("");
              my $did = $c->hash($clusterid) || $c->value($clusterid);
              my $p = $c->can("pretty") ? $c->pretty() : $c->value();
              $idlist{$p} = "variantid preferredid";
            }
           else {
              $idlist{$clusterid} = "variantid preferredid";
            };
          my ($varianth, $variantexpl) = $self->stmtHdl("SELECT beacons.hash FROM cluster.beacons WHERE beacons.altid=?;");
          $self->stmtExplain($variantexpl, $clusterid) if $ENV{'DBI_PROFILE'};
          $varianth->execute($clusterid) or croak("Could not execute >".$varianth->{Statement}."<: ".$varianth->errstr);
          while ( my $onerow = $varianth->fetchrow_arrayref() ) {
              my $v = $onerow->[0];
              if ( $c ) {
                  $c->value("");
                  my $did = $c->hash($v) || $c->value($v);
                  my $p = $c->can("pretty") ? $c->pretty() : $c->value();
                  (exists $idlist{$p}) || ($idlist{$p} = "variantid");
                }
               else {
                  (exists $idlist{$v}) || ($idlist{$v} = "variantid");
                }
            }
        }
    }

  my ($countsth, $countexpl);
  if ( $clusterid ) {
      ($countsth, $countexpl) = $self->stmtHdl(<<"XxX");
SELECT COUNT(DISTINCT seqno) FROM beacons
 WHERE ( (hash=?) OR (hash IN (SELECT beacons.hash FROM cluster.beacons WHERE cluster.beacons.altid=?)) );
XxX
      $self->stmtExplain($countexpl, $clusterid, $clusterid) if $ENV{'DBI_PROFILE'};
      $countsth->execute($clusterid, $clusterid) or croak("Could not execute >".$countsth->{Statement}."<: ".$countsth->errstr);
    }
  else {
      ($countsth, $countexpl) = $self->stmtHdl(<<"XxX");
SELECT COUNT(DISTINCT seqno) FROM beacons WHERE hash=?;
XxX
      $self->stmtExplain($countexpl, $hash) if $ENV{'DBI_PROFILE'};
      $countsth->execute($hash) or croak("Could not execute >".$countsth->{Statement}."<: ".$countsth->errstr);
    };
  my $hitsref = $countsth->fetchrow_arrayref;
  my $hits = $hitsref->[0] || 0;

  my ($osd, $beaconmeta) = $self->get_meta;
  my $prefix = $beaconmeta->{'PREFIX'} || "";
  (my $servicename = $beaconmeta->{'NAME'} || $osd->{'ShortName'} || "") =~ s/([<>&"]|[^\x00-\x7f])/'&#'.ord($1).';'/ge;

  my $target = $cgi->url(-path=>1);

  my @result;
  push(@result, $cgi->start_html(
                     -encoding => "UTF-8",
                        -title => "$servicename referring ".$query->as_string(),
                         -meta => {'robots'=>'noindex'},
    ($extra->{'css'} ? (-style => {'src'=>$extra->{'css'}}) : ()),
                         -head => [$cgi->Link({-rel=>'unapi-server',
                                              -type=>'application/xml',
                                              title=>'unAPI',
                                              -href=>$target}),
                                   $cgi->Link({-rel=>'start',
                                              -href=>$target}),
                                  ],
             ));

  push(@result, 'function toggle(divid) {if ( document.getElementById(divid).style.display == "none" ) {document.getElementById(divid).style.display = "block"} else {document.getElementById(divid).style.display = "none"}}');
  push(@result, 'function mtoggle(dlid,cl) {var nd=document.getElementById(dlid).firstChild; while (nd!=null){if (nd.nodeType == 1) {if (nd.className==cl) {if (nd.style.display == "none"){nd.style.display = "block"}else{nd.style.display = "none"}}};nd=nd.nextSibling;};}');

  push(@result, $cgi->h1("$hits References for ".$cgi->abbr({class=>"unapi-id", title=>"$canon"}, $query)));

  push(@result, '');
  push(@result, $cgi->p($cgi->span("Identifier:"), $cgi->a({href=>"$prefix$pretty"}, "$prefix$pretty"))) if $prefix;
  # delete $idlist{$pretty} if $prefix;
  push(@result, $cgi->p($cgi->span("Variant Identifiers:"), map {$cgi->span({class=>($idlist{$_} || "variantid")}, $_)} sort keys %idlist)) if %idlist;
  push(@result, '');

  my ($srcsth, $srcexpl);
  if ( $clusterid ) {
      ($srcsth, $srcexpl) = $self->stmtHdl(<<"XxX");
SELECT beacons.*, repos.*
  FROM beacons NATURAL LEFT JOIN repos
  WHERE ( (beacons.hash=?)
       OR (beacons.hash IN (SELECT beacons.hash FROM cluster.beacons WHERE cluster.beacons.altid=?)) )
  ORDER BY repos.sort, repos.alias;
XxX
      $self->stmtExplain($srcexpl, $clusterid, $clusterid) if $ENV{'DBI_PROFILE'};
      $srcsth->execute($clusterid, $clusterid) or croak("Could not execute >".$srcsth->{Statement}."<: ".$srcsth->errstr);
    }
  else {
      ($srcsth, $srcexpl) = $self->stmtHdl(<<"XxX");
SELECT beacons.*, repos.*
  FROM beacons NATURAL LEFT JOIN repos
  WHERE beacons.hash=?
  ORDER BY repos.sort, repos.alias;
XxX
      $self->stmtExplain($srcexpl, $hash) if $ENV{'DBI_PROFILE'};
      $srcsth->execute($hash) or croak("Could not execute >".$srcsth->{Statement}."<: ".$srcsth->errstr);
    }

  my $rows = 0;
  push(@result, '');
  my ($lastseq, @groups) = (0, ());
  while ( my $onerow = $srcsth->fetchrow_hashref ) {
      $rows ++;
      if ( $lastseq and $onerow->{'seqno'} == $lastseq ) {
          my %vary;
          foreach my $key ( grep /^(hash|altid|hits|info|link)$/, keys %$onerow ) {
              my $pval = $onerow->{$key};
              next unless defined $pval;
              $pval =~ s/([<>&"]|[^\x00-\x7f])/'&#'.ord($1).';'/ge if $key eq "link";
              $vary{$key} = $pval;
            }
          push(@{$groups[$#groups]}, \%vary);
        }
      else {
          my (%vary, %repos, %meta);
          while ( my($key, $val) = each %$onerow ) {
              my $pval = $val;
              unless ( $key =~ /altid|feed|target|uri|link/i ) {
                  $pval =~ s/([<>&"]|[^\x00-\x7f])/'&#'.ord($1).';'/ge if defined $pval};
              if ( $key =~ /time|revisit/i ) {
                  next unless $val;
                  $pval = HTTP::Date::time2str($val);
                };
              if ( $key =~ /^bc(\w+)$/ ) {
                  $repos{$1} = $pval if $pval}
              elsif ( $key =~ /^(hash|altid|hits|info|link)$/ ) {
                  $vary{$key} = $pval}
              else {
                  $meta{"_$key"} = $pval if $pval}
            };
           push(@groups, [\%repos, \%meta, \%vary]);
         };
      $lastseq = $onerow->{'seqno'};
    };
# Grouping done, now display...

  my %didalreadysee;
  foreach my $groupref ( @groups ) {
      my ($repos, $meta, @vary) = @$groupref;

      my $aos = $meta->{'_alias'} || $meta->{'_seqno'};

      my $multi = (scalar @vary > 1) ? "multi" : "single";
      push(@result, qq!!);
      push(@result, $cgi->h3({class=>"aggregator", onClick=>"toggle('ag$aos')"}, "Administrative Details"));

      push(@result, $cgi->h3({class=>"beacon", onClick=>"toggle('bc$aos')"}, "Repository Details"));

      if ( $multi eq "single" ) {
          push(@result, $cgi->h3({class=>"hit", onClick=>"toggle('ht$aos')"}, "Result Details"));

          my $vary = $vary[0];

          my $hits = $vary->{'hits'};
          my $description = $hits;

          my $h = $vary->{'hash'};
          my $variantid = ($h eq $hash) ? "" : "variantid";
          my $p;
          if ( $h eq $hash ) {
              $p = $pretty}
          elsif ( $clusterid && ref($c) ) {
              $c->value("");
              my $did = $c->hash($h) || $c->value($h) || $h;
              $p = $c->can("pretty") ? $c->pretty() : $c->value();
            };
          $p = ($clusterid ? $h : $pretty) unless defined $p;

          my $uri = "???";
          if ( $uri = $vary->{'link'} ) {  # o.k.
            }
          elsif ( $repos->{'ALTTARGET'} && $vary->{'altid'} ) {
              $uri = sprintf($repos->{'ALTTARGET'}, $p, SeeAlso::Source::BeaconAggregator::urlpseudoescape($vary->{'altid'}))}
          elsif ( $repos->{'TARGET'} ) {
              $uri = sprintf($repos->{'TARGET'}, $p)}
          elsif ( $repos->{'ALTTARGET'} ) {
              $uri = sprintf($repos->{'ALTTARGET'}, $p, SeeAlso::Source::BeaconAggregator::urlpseudoescape($p))};

          my $redundant = ($didalreadysee{$uri}++) ? "subsequent" : "";

          my $guri = "";
          if ( $repos->{'IMGTARGET'} ) {
              $guri = sprintf($repos->{'IMGTARGET'}, $p, SeeAlso::Source::BeaconAggregator::urlpseudoescape($vary->{'altid'}))}

          my @labels = grep /\S/, $repos->{'NAME'} || "", $repos->{'DESCRIPTION'} || "", $repos->{'INSTITUTION'} || "";
          my $rlabel;
          if ( $hits == 1 ) {
              $rlabel = $repos->{'ONEMESSAGE'} if $repos->{'ONEMESSAGE'}}
          elsif ( $hits == 0 ) {
              $rlabel = $repos->{'SOMEMESSAGE'} if $repos->{'SOMEMESSAGE'}};
          unless ( $rlabel ) {
              $rlabel = $repos->{'MESSAGE'} || shift @labels || "???"};
          my $label = sprintf($rlabel, $hits);

          my $ttip = pop @labels || "";
          $ttip =~ s/&#(\d+);/chr($1)/ge;

          push(@result, $cgi->a({style=>"float: right; clear: right;", href=>$uri}, $cgi->img({alt=>$vary->{'info'}||$label,src=>$guri}))) if $guri;

          push(@result, $cgi->h2({class=>"label $redundant $variantid ident_$p", id=>"head$aos"}, $cgi->a({href=>$uri, title=>$ttip}, $label)));

          push(@result, qq!!);
          push(@result, $cgi->span($vary->{'info'})) if $vary->{'info'};
          push(@result, $cgi->span("($hits Treffer)")) if $hits && ($rlabel !~ /%s/);
          push(@result, '');

          push(@result, qq!!);
          push(@result, $cgi->p({class=>"ht_uri"}, $cgi->span("Target URL:"), $cgi->a({href=>$uri}, CGI::escapeHTML($uri))));
          push(@result, $cgi->p({class=>"ht_guri"}, $cgi->span("Preview URL:"), $cgi->a({href=>$guri}, $guri))) if $guri;
          push(@result, $cgi->p({class=>"ht_hits"}, $cgi->span("Hits:"), $hits)) if $hits;
          push(@result, $cgi->p({class=>"ht_info"}, $cgi->span("Additional Info:"), $vary->{'info'})) if $vary->{'info'};
          push(@result, $cgi->p({class=>"ht_idnote"}, $cgi->span("Variant Identifier:"), $p)) if $variantid;
          push(@result, '');
        }
      else {
          push(@result, $cgi->h3({class=>"hit", onClick=>"mtoggle('res$aos', 'hit')"}, "Result Details"));
          my $hits = scalar @vary;

          my @labels = grep /\S/, $repos->{'NAME'} || "", $repos->{'DESCRIPTION'} || "", $repos->{'INSTITUTION'} || "";
          my $rlabel = $repos->{'MESSAGE'} || shift @labels || "???";
          my $ttip = pop @labels || "";
          $ttip =~ s/&#(\d+);/chr($1)/ge;

#          my $rlabel =  $repos->{'SOMEMESSAGE'} || $repos->{'MESSAGE'} || $repos->{'DESCRIPTION'} || $repos->{'NAME'} || $repos->{'INSTITUTION'} || "???";

#          my $ttip = $repos->{'MESSAGE'} ? $repos->{'DESCRIPTION'} || $repos->{'NAME'} || $repos->{'INSTITUTION'} || ""

#                                         : $repos->{'INSTITUTION'} || $repos->{'NAME'} || "";

#          $ttip = "" if $ttip eq $rlabel;
          $ttip =~ s/&#(\d+);/chr($1)/ge;

          my $label = sprintf($rlabel, $hits);
          push(@result, $cgi->h2({class=>"label", id=>"head$aos"}, $label));

          push(@result, qq!!);
          my $cnt = 0;
          foreach my $vary ( @vary ) {
              $cnt ++;

              my $h = $vary->{'hash'};
              my $variantid = ($h eq $hash) ? "" : "variantid";
              my $p;
              if ( $h eq $hash ) {
                  $p = $pretty}
              elsif ( $clusterid && ref($c) ) {
                  $c->value("");
                  my $did = $c->hash($h) || $c->value($h) || $h;
                  $p = $c->can("pretty") ? $c->pretty() : $c->value();
                };
              $p = ($clusterid ? $h : $pretty) unless defined $p;

              my $uri = "???";
              if ( $uri = $vary->{'link'} ) {  # o.k.
                }
              elsif ( $repos->{'ALTTARGET'} && $vary->{'altid'} ) {
                  $uri = sprintf($repos->{'ALTTARGET'}, $p, SeeAlso::Source::BeaconAggregator::urlpseudoescape($vary->{'altid'}))}
              elsif ( $repos->{'TARGET'} ) {
                  $uri = sprintf($repos->{'TARGET'}, $p)}
              elsif ( $repos->{'ALTTARGET'} ) {
                  $uri = sprintf($repos->{'ALTTARGET'}, $p, SeeAlso::Source::BeaconAggregator::urlpseudoescape($p))};

              my $redundant = ($didalreadysee{$uri}++) ? "subsequent" : "";

              my $guri = "";
              if ( $repos->{'IMGTARGET'} ) {
                  $guri = sprintf($repos->{'IMGTARGET'}, $p, SeeAlso::Source::BeaconAggregator::urlpseudoescape($vary->{'altid'}))}

              my $hits = $vary->{hits} if $vary->{hits} and $vary->{hits} != 1;

              push(@result, qq!!);
              push(@result, $cgi->div({style=>"float: right;"}, $cgi->a({href=>$uri}, $cgi->img({src=>$guri})))) if $guri;
              push(@result, $cgi->a({href=>$uri}, $cgi->span($vary->{'info'} || "[$cnt.]")));
              push(@result, $cgi->span("($hits Treffer)")) if $hits;
              push(@result, '');

              push(@result, qq!!);
              push(@result, $cgi->p({class=>"ht_uri"}, $cgi->span("Target URL:"), $cgi->a({href=>$uri}, $uri)));
              push(@result, $cgi->p({class=>"ht_guri"}, $cgi->span("Preview URL:"), $cgi->a({href=>$guri}, $guri))) if $guri;
              push(@result, $cgi->p({class=>"ht_hits"}, $cgi->span("Hits:"), $vary->{hits})) if $vary->{hits};
              push(@result, $cgi->p({class=>"ht_info"}, $cgi->span("Additional Info:"), $vary->{'info'})) if $vary->{'info'};
              push(@result, $cgi->p({class=>"ht_idnote"}, $cgi->span("Variant Identifier:"), $p)) if $variantid;

              push(@result, '');
              push(@result, '');
            };
          push(@result, qq!!);
        }

      push(@result, qq!!);
      foreach ( sort keys %$repos ) {
          next if /(MESSAGE|TARGET)$/;
          next unless $repos->{$_};
          $repos->{$_} =~ s!([a-z]+://\S+)!$cgi->a({href=>"$1", target=>"_blank"}, "$1")!ge;                 # URL
          $repos->{$_} =~ s!(?:\<\s*)?(\w[\w.-]*)\@((?:\w[\w-]*\.)+\w+)(?:\s*\>)?!<$1 (at) $2>!g;      # Mail Addr
          $repos->{$_} =~ s/\s*\|\s*/ | /g;                                                                  # Examples
          next if /^(FORMAT|PREFIX|REVISIT|VERSION)$/;                   # Postpone to "administrative Details"
          push(@result, $cgi->p({class=>"bc_$_"}, $cgi->span("#$_:"), $repos->{$_}));
        };
      push(@result, $cgi->p({class=>"ag_mtime"}, $cgi->span("Modified:"), $meta->{'_mtime'})) if $meta->{'_mtime'};
      push(@result, '');

      push(@result, qq!!);
      foreach ( sort keys %$repos ) {
          next unless /^(FORMAT|PREFIX|REVISIT|VERSION)$/;
          next unless $repos->{$_};
          push(@result, $cgi->p({class=>"bc_$_"}, $cgi->span("#$_:"), $repos->{$_}));
        };
      push(@result, $cgi->p({class=>"ag_ftime"}, $cgi->span("Loaded:"), $meta->{'_ftime'})) if $meta->{'_ftime'};
      push(@result, $cgi->p({class=>"ag_fstat"}, $cgi->span("Load status:"), $meta->{'_fstat'})) if $meta->{'_fstat'};
      push(@result, $cgi->p({class=>"ag_utime"}, $cgi->span("Update attempt:"), $meta->{'_utime'})) if $meta->{'_utime'};
      push(@result, $cgi->p({class=>"ag_ustat"}, $cgi->span("Update status:"), $meta->{'_ustat'})) if $meta->{'_ustat'};
      push(@result, $cgi->p({class=>"ag_counti"}, $cgi->span("Identifiers:"), $meta->{'_counti'})) if $meta->{'_counti'};
      push(@result, $cgi->p({class=>"ag_countu"}, $cgi->span("Distinct Ids:"), $meta->{'_countu'})) if $meta->{'_countu'};
      push(@result, $cgi->p({class=>"ag_sort"}, $cgi->span("Sort key:"), $meta->{'_sort'})) if $meta->{'_sort'};
      push(@result, $cgi->p({class=>"ag_admin"}, $cgi->span("Remark:"), $meta->{'_admin'})) if $meta->{'_admin'};
      push(@result, '');

      push(@result, '');

      push(@result, '');
    };
  push(@result, '');

  push(@result, '');
# $cgi->span("provided by:"),
  push(@result, $cgi->p({class=>"mt_NAME"}, $cgi->a({href=>$target}, $servicename)));
# $cgi->span("Service description:"),
  (my $descr = $beaconmeta->{'DESCRIPTION'} || $osd->{'Description'} || "") =~ s/([<>&"]|[^\x00-\x7f])/'&#'.ord($1).';'/ge;
  push(@result, $cgi->p({class=>"mt_DESCRIPTION"}, $descr));
  push(@result, '');

  my($tu, $ts, $tcu, $tcs) = times();
  push(@result, sprintf("", $tu, $ts, $tu+$ts), $cgi->end_html());
  return join("\n", @result);
}


=head2 get_meta ()

Returns a pair of hash references:

=over 8

=item 1

OSD fields

=item 2

Beacon header fields

=back

=cut

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

  my ($metasth, $metaexpl) = $self->stmtHdl(<<"XxX");
SELECT key, val FROM osd;
XxX
  $self->stmtExplain($metaexpl) if $ENV{'DBI_PROFILE'};
  $metasth->execute() or croak("Could not execute >".$metasth->{Statement}."<: ".$metasth->errstr);
  my (%osd, %beaconmeta);
  while ( my $aryref = $metasth->fetchrow_arrayref ) {
      my ($key, $val) = @$aryref;
      next unless $val;
      if ($key =~ s/^bc// ) {        # BeaconMeta Fields
          $beaconmeta{$key} = $val}
      elsif ( exists $osd{$key} ) {
          if ( ref($osd{$key}) ) {
              push(@{$osd{$key}}, $val)}
          else {
              $osd{$key} = [$osd{$key}, $val]};
        }
      else {
          $osd{$key} = $val};
    };
  return (\%osd, \%beaconmeta);
}

=head1 AUTHOR

    Thomas Berger
    CPAN ID: THB
    gymel.com
    [e-mail]

=head1 COPYRIGHT

This program is free software; you can redistribute
it and/or modify it under the same terms as Perl itself.

The full text of the license can be found in the
LICENSE file included with this module.


=cut

1;
# The preceding line will help the module return a true value