blib/lib/SeeAlso/Source/BeaconAggregator/Publisher.pm | |||
---|---|---|---|
Criterion | Covered | Total | % |
statement | 116 | 465 | 24.9 |
branch | 47 | 352 | 13.3 |
condition | 23 | 186 | 12.3 |
subroutine | 9 | 11 | 81.8 |
pod | 7 | 7 | 100.0 |
total | 202 | 1021 | 19.7 |
line | stmt | bran | cond | sub | pod | time | code |
---|---|---|---|---|---|---|---|
1 | package SeeAlso::Source::BeaconAggregator::Publisher; | ||||||
2 | 3 | 3 | 87348 | use strict; | |||
3 | 3 | ||||||
3 | 68 | ||||||
3 | 3 | 3 | 10 | use warnings; | |||
3 | 3 | ||||||
3 | 180 | ||||||
4 | |||||||
5 | our $VERSION = "0.2_92"; | ||||||
6 | |||||||
7 | =head1 NAME | ||||||
8 | |||||||
9 | SeeAlso::Source::BeaconAggregator::Publisher - additional methods for SeeAlso::Source::BeaconAggregator | ||||||
10 | |||||||
11 | =head1 SYNOPSIS | ||||||
12 | |||||||
13 | $source = SeeAlso::Source::BeaconAggregator::Publisher->new(...); | ||||||
14 | |||||||
15 | =head1 DESCRIPTION | ||||||
16 | |||||||
17 | This package provides the functionallity to export a BEACON file from the | ||||||
18 | data connected with an SeeAlso::Source::BeaconAggregator instance and | ||||||
19 | also the additional formats "redirect" and "sources" which universally | ||||||
20 | can be used as callbacks for SeeAlso::Server (replacing the default | ||||||
21 | "seealso" method yielding JSON data). | ||||||
22 | |||||||
23 | =cut | ||||||
24 | |||||||
25 | our %Defaults = ( | ||||||
26 | # "REVISIT" => 86400, # one day | ||||||
27 | "REVISIT" => undef, # no default (leave empty unless otherwise set) | ||||||
28 | "uAformatname" => "sources", | ||||||
29 | "beaconformatname" => "beacon", | ||||||
30 | "FORMAT" => "BEACON", | ||||||
31 | "VERSION" => "0.1", # no other exist | ||||||
32 | ); | ||||||
33 | |||||||
34 | 3 | 3 | 792 | use SeeAlso::Source::BeaconAggregator; | |||
3 | 5 | ||||||
3 | 109 | ||||||
35 | 3 | 3 | 12 | use Carp; | |||
3 | 5 | ||||||
3 | 15250 | ||||||
36 | |||||||
37 | =head2 new ( ... ) | ||||||
38 | |||||||
39 | Creates an SeeAlso::Source::BeaconAggregator object with additional methods from | ||||||
40 | this package enabled | ||||||
41 | |||||||
42 | =cut | ||||||
43 | |||||||
44 | sub new { # directly create BeaconAggregator instance with extended features... | ||||||
45 | 4 | 4 | 1 | 3586 | my $class = shift @_; | ||
46 | 4 | 41 | push(@SeeAlso::Source::BeaconAggregator::ISA, $class); | ||||
47 | 4 | 19 | return SeeAlso::Source::BeaconAggregator->new(@_); | ||||
48 | } | ||||||
49 | |||||||
50 | |||||||
51 | =head2 activate () | ||||||
52 | |||||||
53 | Makes SeeAlso::Source::BeaconAggregator objects member of this class, | ||||||
54 | globally enabling the additional methods | ||||||
55 | |||||||
56 | Usage: | ||||||
57 | |||||||
58 | $db = SeeAlso::Source::BeaconAggregator::Maintenance->new(...); | ||||||
59 | ... | ||||||
60 | do stuff | ||||||
61 | ... | ||||||
62 | require SeeAlso::Source::BeaconAggregator::Publisher | ||||||
63 | or die "could not require Publisher extension"; | ||||||
64 | SeeAlso::Source::BeaconAggregator::Publisher->activate(); # "recast" all objects | ||||||
65 | ... | ||||||
66 | do more stuff | ||||||
67 | |||||||
68 | =cut | ||||||
69 | sub activate { # enrich SeeAlso::Source and derived classes with our methods | ||||||
70 | 1 | 1 | 1 | 414 | my $class = shift @_; | ||
71 | 1 | 10 | push(@SeeAlso::Source::BeaconAggregator::ISA, $class); | ||||
72 | 1 | 3 | return 1; | ||||
73 | } | ||||||
74 | |||||||
75 | |||||||
76 | ### Produktion der Beacon-Datei | ||||||
77 | |||||||
78 | =head2 beacon ( [dumpmeta arguments] ) | ||||||
79 | |||||||
80 | produces a BEACON file (however, $cgibase is mandatory) | ||||||
81 | |||||||
82 | =head2 dumpmeta ( [$cgibase, [$uAformatname, [$headersonly]]] [, $preset]) | ||||||
83 | |||||||
84 | produces only the meta fields of a BEACON file | ||||||
85 | |||||||
86 | Meta fields are generated from the $preset Hashref, falling back to | ||||||
87 | values stored in the database, falling back to reasonable default | ||||||
88 | values. | ||||||
89 | |||||||
90 | Arguments: | ||||||
91 | |||||||
92 | =over 8 | ||||||
93 | |||||||
94 | =item $cgibase | ||||||
95 | |||||||
96 | URL of the SeeAlso service the BEACON file is provided for | ||||||
97 | |||||||
98 | =item $uAformatname | ||||||
99 | |||||||
100 | unAPI format name to be used as target (Default: "sources") | ||||||
101 | |||||||
102 | =item $headersonly | ||||||
103 | |||||||
104 | currently unused | ||||||
105 | |||||||
106 | =item $preset | ||||||
107 | |||||||
108 | Hashref of Beacon header fields overriding the contents of the database | ||||||
109 | |||||||
110 | =back | ||||||
111 | |||||||
112 | Regular Usage: | ||||||
113 | |||||||
114 | $db = SeeAlso::Source::BeaconAggregator::Publisher->new(...); | ||||||
115 | binmode(STDOUT, ":utf8"); | ||||||
116 | my $cgibase = "http://address/of/service"; | ||||||
117 | my ( $error, $headerref) = $db->beacon($cgibase, @ARGV, {'FORMAT' => 'PND-BEACON'}); | ||||||
118 | |||||||
119 | |||||||
120 | CGI Usage: | ||||||
121 | |||||||
122 | $format = $CGI->param('format') || ""; | ||||||
123 | if ( $format eq "beacon" ) { # bypass SeeAlso::Server->query() b/c performance / interim storage | ||||||
124 | insert access restrictions here... | ||||||
125 | do_beacon($source, $CGI); | ||||||
126 | } | ||||||
127 | ... | ||||||
128 | |||||||
129 | sub do_beacon { | ||||||
130 | my ($self, $cgi) = @_; # Of type SeeAlso::Source::BeaconAggregator | ||||||
131 | unless ( $self->can("beacon") ) { | ||||||
132 | croak "On the fly generation of beacon Files not supported by this service";} | ||||||
133 | my $cgibase = $cgi->url(-path_info=>1); | ||||||
134 | |||||||
135 | print $cgi->header( -status => 200, | ||||||
136 | -expires => '+1d', | ||||||
137 | -type => 'text/plain', | ||||||
138 | -charset => 'utf-8', | ||||||
139 | ); | ||||||
140 | return $self->beacon($cgibase, "sources", {}); # prints directly to stdout..., returns $error, $headerref | ||||||
141 | } | ||||||
142 | |||||||
143 | =cut | ||||||
144 | |||||||
145 | sub beacon { | ||||||
146 | 1 | 50 | 1 | 1 | 10600 | my ($self) = shift @_ or croak("beacon is a method!"); # Of type SeeAlso::Source::BeaconAggregator | |
147 | 1 | 3 | my ($error, $headerref) = $self->dumpmeta(@_); | ||||
148 | 1 | 50 | 3 | croak("Error generating Header, will not proceed") if $error; | |||
149 | |||||||
150 | 1 | 41 | print @$headerref; | ||||
151 | |||||||
152 | 1 | 50 | 6 | my $c = (defined $self->{identifierClass}) ? $self->{identifierClass} : $self->autoIdentifier(); | |||
153 | |||||||
154 | 1 | 3 | my ($sth, $sthexpl) = $self->stmtHdl(<<"XxX"); | ||||
155 | SELECT hash, COUNT(DISTINCT seqno) FROM beacons GROUP BY hash ORDER BY hash; | ||||||
156 | XxX | ||||||
157 | 1 | 50 | 3 | $self->stmtExplain($sthexpl) if $ENV{'DBI_PROFILE'}; | |||
158 | 1 | 50 | 138 | $sth->execute() or croak("Could not execute >".$sth->{Statement}."<: ".$sth->errstr); | |||
159 | 1 | 3 | my $rows = 0; | ||||
160 | 1 | 40 | while ( my $row = $sth->fetchrow_arrayref ) { | ||||
161 | 7 | 6 | $rows++; | ||||
162 | 7 | 6 | my $expanded = $row->[0]; | ||||
163 | 7 | 50 | 13 | if ( defined $c ) { | |||
164 | # compat: hash might not take an argument, must resort to value, has to be cleared before... | ||||||
165 | 0 | 0 | $c->value(""); | ||||
166 | 0 | 0 | 0 | my $did = $c->hash($row->[0]) || $c->value($row->[0]); | |||
167 | 0 | 0 | 0 | $expanded = $c->can("pretty") ? $c->pretty() : $c->value(); | |||
168 | # illegal identifier b/c different classes for loading and exporting? | ||||||
169 | 0 | 0 | 0 | 0 | next unless defined $expanded && ($expanded ne ""); | ||
170 | } | ||||||
171 | 7 | 100 | 142 | print $expanded.(($row->[1] > 1) ? "|".$row->[1] : "")."\n"; | |||
172 | } | ||||||
173 | |||||||
174 | 1 | 3 | return $rows, $headerref; | ||||
175 | } | ||||||
176 | |||||||
177 | sub dumpmeta { # cgibase unAPIformatname headers_only {preset} | ||||||
178 | 2 | 50 | 2 | 1 | 2266 | my ($self) = shift @_ or croak("dumpmeta is a method!"); # Of type SeeAlso::Source::BeaconAggregator | |
179 | 2 | 3 | my ($error, @result) = (0, ()); | ||||
180 | |||||||
181 | 2 | 50 | 33 | 10 | my $cgibase = shift @_ if @_ && !ref($_[0]); | ||
182 | 2 | 50 | 33 | 8 | my $uAformatname = shift @_ if @_ && !ref($_[0]); | ||
183 | 2 | 33 | 8 | $uAformatname ||= $Defaults{'uAformatname'}; | |||
184 | 2 | 50 | 33 | 7 | my $headersonly = shift @_ if @_ && !ref($_[0]); | ||
185 | 2 | 50 | 33 | 12 | my $preset = (@_ && ref($_[0])) ? (shift @_) : {}; | ||
186 | |||||||
187 | 2 | 6 | my ($metasth, $metasthexpl) = $self->stmtHdl(<<"XxX"); | ||||
188 | SELECT key, val FROM osd; | ||||||
189 | XxX | ||||||
190 | 2 | 50 | 5 | $self->stmtExplain($metasthexpl) if $ENV{'DBI_PROFILE'}; | |||
191 | 2 | 50 | 85 | $metasth->execute() or croak("Could not execute >".$metasth->{Statement}."<: ".$metasth->errstr); | |||
192 | |||||||
193 | 2 | 3 | my (%osd, %beaconmeta); | ||||
194 | 2 | 23 | while ( my $aryref = $metasth->fetchrow_arrayref ) { | ||||
195 | 18 | 15 | my ($key, $val) = @$aryref; | ||||
196 | 18 | 50 | 24 | next unless $val; | |||
197 | 18 | 100 | 40 | if ($key =~ s/^bc// ) { # BeaconMeta Fields | |||
100 | |||||||
198 | 4 | 29 | $beaconmeta{$key} = $val} | ||||
199 | elsif ( exists $osd{$key} ) { | ||||||
200 | 12 | 100 | 16 | if ( ref($osd{$key}) ) { | |||
201 | 10 | 5 | push(@{$osd{$key}}, $val)} | ||||
10 | 42 | ||||||
202 | else { | ||||||
203 | 2 | 11 | $osd{$key} = [$osd{$key}, $val]}; | ||||
204 | } | ||||||
205 | else { | ||||||
206 | 2 | 11 | $osd{$key} = $val}; | ||||
207 | }; | ||||||
208 | 2 | 6 | my @osdexamples; | ||||
209 | 2 | 50 | 33 | 7 | if ( $osd{'Examples'} && ref($osd{'Examples'}) ) { | ||
50 | |||||||
210 | 0 | 0 | foreach my $expl ( @{$osd{'Examples'}} ) { | ||||
0 | 0 | ||||||
211 | 0 | 0 | $expl =~ s/\s*\|.*$//; | ||||
212 | 0 | 0 | push(@osdexamples, $expl); | ||||
213 | } | ||||||
214 | } | ||||||
215 | elsif ( my $expl = $osd{'Examples'} ) { | ||||||
216 | 0 | 0 | $expl =~ s/\s*\|.*$//; | ||||
217 | 0 | 0 | push(@osdexamples, $expl); | ||||
218 | }; | ||||||
219 | |||||||
220 | 2 | 13 | foreach ( grep /^[A-Z]+$/, keys %$preset ) { | ||||
221 | 3 | 6 | $beaconmeta{$_} = $preset->{$_}} | ||||
222 | # Mandatory fields | ||||||
223 | 2 | 33 | 8 | push(@result, "#FORMAT: ".($beaconmeta{'FORMAT'} || $Defaults{'FORMAT'})."\n"); | |||
224 | 2 | 33 | 6 | push(@result, "#VERSION: ".($beaconmeta{'VERSION'} || $Defaults{'VERSION'})."\n"); | |||
225 | 2 | 50 | 4 | if ( $beaconmeta{'TARGET'} ) { | |||
50 | |||||||
226 | 0 | 0 | $beaconmeta{'TARGET'} =~ s/^\{BASE\}/$cgibase/; | ||||
227 | 0 | 0 | push(@result, "#TARGET: $beaconmeta{'TARGET'}\n"); | ||||
228 | } | ||||||
229 | elsif ( $cgibase ) { | ||||||
230 | 2 | 6 | push(@result, "#TARGET: $cgibase?format=$uAformatname&id={ID}\n")} | ||||
231 | else { | ||||||
232 | 0 | 0 | carp "Don't know how to construct the mandatory #TARGET field!"; | ||||
233 | 0 | 0 | $error ++; | ||||
234 | } | ||||||
235 | |||||||
236 | 2 | 33 | 8 | my $timestamp = $preset->{'TIMESTAMP'} || $osd{DateModified} || $^T; | |||
237 | 2 | 50 | 9 | push(@result, "#TIMESTAMP: ".SeeAlso::Source::BeaconAggregator::tToISO($timestamp)."\n") if $timestamp > 0; | |||
238 | 2 | 50 | 12 | my $revisit = ($beaconmeta{'REVISIT'} || $Defaults{'REVISIT'}) || ""; | |||
239 | 2 | 2 | $revisit =~ tr/ //d; | ||||
240 | 2 | 3 | $revisit =~ s/(\d+)mo\w*/($1*30)."d"/ei; | ||||
0 | 0 | ||||||
241 | 2 | 2 | $revisit =~ s/(\d+)M\w*/($1*30)."d"/e; | ||||
0 | 0 | ||||||
242 | 2 | 3 | $revisit =~ s/(\d+)w\w*/($1*7)."d"/ei; | ||||
0 | 0 | ||||||
243 | 2 | 4 | $revisit =~ s/(\d+)d\w*/($1*24)."h"/ei; | ||||
1 | 6 | ||||||
244 | 2 | 3 | $revisit =~ s/(\d+)h\w*/($1*60)."m"/ei; | ||||
1 | 3 | ||||||
245 | 2 | 3 | $revisit =~ s/(\d+)m\w*/($1*60)."s"/ei; | ||||
1 | 2 | ||||||
246 | 2 | 4 | $revisit =~ s/(\d+)s\w*/$1/i; | ||||
247 | 2 | 50 | 66 | 13 | push(@result, "#REVISIT: ".SeeAlso::Source::BeaconAggregator::tToISO($timestamp + $revisit)."\n") if $revisit && ($revisit =~ /^[+-]?\d+$/) && ($revisit > 0);; | ||
66 | |||||||
248 | |||||||
249 | # $beaconmeta{'UPDATE'} ||= "daily"; | ||||||
250 | 2 | 50 | 33 | 10 | $beaconmeta{'FEED'} ||= "$cgibase?format=".$Defaults{'beaconformatname'} if $cgibase; | ||
251 | 2 | 33 | 16 | $beaconmeta{'EXAMPLES'} ||= join("|", @osdexamples); | |||
252 | 2 | 33 | 8 | $beaconmeta{'CONTACT'} ||= $self->{Contact} || $osd{'Contact'}; | |||
33 | |||||||
253 | 2 | 33 | 8 | $beaconmeta{'DESCRIPTION'} ||= $self->{Description} || $osd{'Description'}; | |||
33 | |||||||
254 | 2 | 33 | 9 | $beaconmeta{'NAME'} ||= $self->{ShortName} || $osd{'ShortName'}; | |||
33 | |||||||
255 | 2 | 10 | foreach ( grep !/^(FORMAT|REVISIT|TARGET|TIMESTAMP|VERSION)$/, SeeAlso::Source::BeaconAggregator->beaconfields() ) { | ||||
256 | 32 | 100 | 44 | next unless my $val = $beaconmeta{$_}; | |||
257 | 6 | 50 | 10 | next if $val =~ /^-/; | |||
258 | 6 | 17 | $val =~ s/\s+/ /g; $val =~ s/^\s+//; $val =~ s/\s+$//; | ||||
6 | 9 | ||||||
6 | 7 | ||||||
259 | 6 | 13 | push(@result, "#$_: $val\n"); | ||||
260 | } | ||||||
261 | |||||||
262 | # extract admin info of last transaction (i.e. last possible modification of underlying data) | ||||||
263 | # alternatively: SELECT seqno, utime FROM repos WHERE seqno=(SELECT MAX(seqno) FROM repos); | ||||||
264 | 2 | 6 | my ($laststh, $laststhexpl) = $self->stmtHdl(<<"XxX"); | ||||
265 | SELECT MAX(seqno), MAX(mtime) FROM repos; | ||||||
266 | XxX | ||||||
267 | 2 | 50 | 3 | $self->stmtExplain($laststhexpl) if $ENV{'DBI_PROFILE'}; | |||
268 | 2 | 50 | 88 | $laststh->execute() or croak("Could not execute >".$laststh->{Statement}."<: ".$laststh->errstr); | |||
269 | 2 | 50 | 20 | if ( my $aryref = $laststh->fetchrow_arrayref ) { | |||
270 | 2 | 2 | my ($sq, $ut) = @$aryref; | ||||
271 | 2 | 50 | 13 | push(@result, "#X-REVISION: $sq [".SeeAlso::Source::BeaconAggregator::tToISO($ut)."]\n") if $sq; | |||
272 | }; | ||||||
273 | 2 | 6 | my $admref = $self->admhash(); | ||||
274 | 2 | 50 | 6 | if ( my $cu = $admref->{'gcountu'} ) { | |||
275 | 2 | 50 | 6 | my $type = $admref->{'IDENTIFIER_CLASS'} || ""; | |||
276 | 2 | 50 | 10 | push(@result, "#X-EXTENT: $cu unique identifiers".($type ? " of type $type" : "")."\n"); | |||
277 | }; | ||||||
278 | |||||||
279 | |||||||
280 | ## PND-BEACON | ||||||
281 | # CONTACT => ['VARCHAR(63)'], | ||||||
282 | # INSTITUTION => ['VARCHAR(255)'], | ||||||
283 | # ISIL => ['VARCHAR(63)'], | ||||||
284 | # DESCRIPTION => ['VARCHAR(255)'], | ||||||
285 | ## BEACON | ||||||
286 | # MESSAGE => ['VARCHAR(255)'], # enthaelt {hits} | ||||||
287 | # ONEMESSAGE => ['VARCHAR(255)'], | ||||||
288 | # SOMEMESSAGE => ['VARCHAR(255)'], | ||||||
289 | # PREFIX => ['VARCHAR(255)'], | ||||||
290 | ## WInofficial | ||||||
291 | # NAME => ['VARCHAR(255)'], | ||||||
292 | |||||||
293 | 2 | 11 | return $error, \@result; | ||||
294 | } | ||||||
295 | |||||||
296 | |||||||
297 | =head2 redirect ( $server, $format, $extra, $query ) | ||||||
298 | |||||||
299 | Produces an HTTP redirect page, HTML content contains very terse details in case | ||||||
300 | of multiple results. | ||||||
301 | |||||||
302 | This subroutine may be used as callback method in SeeAlso::Server | ||||||
303 | |||||||
304 | Usage is a bit cludgy due to author's lack of understanding of SeeAlso::Server | ||||||
305 | |||||||
306 | $source = SeeAlso::Sources::BeaconAggregator::Publisher->new(...); | ||||||
307 | $CGI = CGI->new(); | ||||||
308 | |||||||
309 | $formats = { | ||||||
310 | ... | ||||||
311 | redirect => { | ||||||
312 | type => "text/html", | ||||||
313 | docs => "http://www.endofthe.net/", | ||||||
314 | # method => \&SeeAlso::Source::BeaconAggregator::Publisher::redirect, | ||||||
315 | #redirect_300 => 'sources', | ||||||
316 | } | ||||||
317 | }; | ||||||
318 | |||||||
319 | $server = SeeAlso::Server->new ( | ||||||
320 | 'cgi' => $CGI, | ||||||
321 | 'formats' => $formats, | ||||||
322 | ... | ||||||
323 | ); | ||||||
324 | |||||||
325 | # Closure as fix: Server.pm does not expose self, $source and the CGI object to the format methods | ||||||
326 | my $oref = \&SeeAlso::Source::BeaconAggregator::Publisher::redirect; | ||||||
327 | $server->{'formats'}->{'redirect'}->{method} | ||||||
328 | = sub {return &$oref($source, $server, $method, $formats->{$method}, @_)}; | ||||||
329 | |||||||
330 | my $result = $server->query($source); | ||||||
331 | |||||||
332 | Arguments: | ||||||
333 | |||||||
334 | =over 8 | ||||||
335 | |||||||
336 | =item $server | ||||||
337 | |||||||
338 | SeeAlso::Server object. Must contain a CGI object | ||||||
339 | |||||||
340 | =item $format | ||||||
341 | |||||||
342 | Name of a format registered with the $server object () | ||||||
343 | |||||||
344 | =item $extra | ||||||
345 | |||||||
346 | Hashref with the following configuration directives | ||||||
347 | |||||||
348 | redirect_300 => CGI 'format' parameter to be used in HTML content (eg. format=sources) | ||||||
349 | |||||||
350 | force_single => Only regard the first hit (thus always redirect) | ||||||
351 | |||||||
352 | =item $query | ||||||
353 | |||||||
354 | Identifier to be queried | ||||||
355 | |||||||
356 | =back | ||||||
357 | |||||||
358 | =cut | ||||||
359 | |||||||
360 | sub redirect { # Liste der Beacon-Header fuer Treffer oder einfaches redirect | ||||||
361 | 0 | 0 | 1 | 0 | my ($self, $server, $format, $extra, $query) = @_; | ||
362 | 0 | 0 | 0 | my $formatprops = $server->{'formats'}->{$format} || {}; | |||
363 | 0 | 0 | 0 | my $cgi = $server->{'cgi'} or croak("I rely on a prepared CGI.pm object"); | |||
364 | |||||||
365 | my %headerdefaults = ( -type => ($formatprops->{'type'} || 'text/html'), | ||||||
366 | # ($formatprops->{'charset'} ? (-charset => $formatprops->{'charset'}) : ()), | ||||||
367 | -charset => ($formatprops->{'charset'} || 'UTF-8'), | ||||||
368 | 0 | 0 | 0 | -expires => ($server->{'expires'} || '+1h'), | |||
0 | |||||||
0 | |||||||
369 | ); | ||||||
370 | |||||||
371 | 0 | 0 | my ($hash, $pretty, $canon) = $self->prepare_query($query); | ||||
372 | 0 | 0 | 0 | unless ( $hash ) { | |||
373 | 0 | 0 | print $cgi->header(-status => "400 Bad Request (Identifier '$query' not valid)", | ||||
374 | -expires => "+1y", | ||||||
375 | -type => 'text/html', | ||||||
376 | ), | ||||||
377 | $cgi->start_html (-dtd => "-//W3C//DTD HTML 3.2 Final//EN", | ||||||
378 | -title => "No valid identifier", | ||||||
379 | ), | ||||||
380 | $cgi->p("Malformed identifier '$query'"), | ||||||
381 | $cgi->end_html; | ||||||
382 | 0 | 0 | return ""; | ||||
383 | }; | ||||||
384 | |||||||
385 | 0 | 0 | my $clusterid; | ||||
386 | 0 | 0 | 0 | if ( $self->{cluster} ) { | |||
387 | 0 | 0 | my ($clusterh, $clusterexpl) = $self->stmtHdl("SELECT beacons.altid FROM cluster.beacons WHERE beacons.hash=? OR beacons.altid=? LIMIT 1;"); | ||||
388 | 0 | 0 | 0 | $self->stmtExplain($clusterexpl, $hash, $hash) if $ENV{'DBI_PROFILE'}; | |||
389 | 0 | 0 | $clusterh->execute($hash, $hash); | ||||
390 | 0 | 0 | while ( my $onerow = $clusterh->fetchrow_arrayref() ) { | ||||
391 | 0 | 0 | $clusterid = $onerow->[0];} | ||||
392 | } | ||||||
393 | |||||||
394 | 0 | 0 | 0 | my $clause = $extra->{force_single} ? "LIMIT 1" : "ORDER BY repos.sort, repos.alias"; | |||
395 | 0 | 0 | my ( $tfield,$afield, $gfield, $mfield,$nfield,$ifield) = map{ scalar $self->beaconfields($_) } | ||||
0 | 0 | ||||||
396 | qw(TARGET ALTTARGET IMGTARGET MESSAGE NAME INSTITUTION); | ||||||
397 | # above 5 6 7 8 9 10 | ||||||
398 | # below 0 1 2 3 4 | ||||||
399 | # 11 | ||||||
400 | 0 | 0 | my ($sth, $sthexpl); | ||||
401 | 0 | 0 | 0 | if ( $clusterid ) { # query IN cluster | |||
402 | 0 | 0 | ($sth, $sthexpl) = $self->stmtHdl(<<"XxX"); | ||||
403 | SELECT beacons.hash, beacons.altid, beacons.hits, beacons.info, beacons.link, | ||||||
404 | repos.$tfield, repos.$afield, repos.$gfield, repos.$mfield, repos.$nfield, repos.$ifield, | ||||||
405 | repos.alias | ||||||
406 | FROM beacons NATURAL LEFT JOIN repos | ||||||
407 | WHERE ( (beacons.hash=?) | ||||||
408 | OR (beacons.hash IN (SELECT cluster.beacons.hash FROM cluster.beacons WHERE cluster.beacons.altid=?)) ) | ||||||
409 | $clause; | ||||||
410 | XxX | ||||||
411 | 0 | 0 | 0 | $self->stmtExplain($sthexpl, $clusterid, $clusterid) if $ENV{'DBI_PROFILE'}; | |||
412 | 0 | 0 | 0 | $sth->execute($clusterid, $clusterid) or croak("Could not execute >".$sth->{Statement}."<: ".$sth->errstr); | |||
413 | } | ||||||
414 | else { | ||||||
415 | 0 | 0 | ($sth, $sthexpl) = $self->stmtHdl(<<"XxX"); | ||||
416 | SELECT beacons.hash, beacons.altid, beacons.hits, beacons.info, beacons.link, | ||||||
417 | repos.$tfield, repos.$afield, repos.$gfield, repos.$mfield, repos.$nfield, repos.$ifield, | ||||||
418 | repos.alias | ||||||
419 | FROM beacons NATURAL LEFT JOIN repos | ||||||
420 | WHERE beacons.hash=? | ||||||
421 | $clause; | ||||||
422 | XxX | ||||||
423 | 0 | 0 | 0 | $self->stmtExplain($sthexpl, $hash) if $ENV{'DBI_PROFILE'}; | |||
424 | 0 | 0 | 0 | $sth->execute($hash) or croak("Could not execute >".$sth->{Statement}."<: ".$sth->errstr); | |||
425 | } | ||||||
426 | |||||||
427 | 0 | 0 | 0 | my $c = $self->{identifierClass} || undef; | |||
428 | 0 | 0 | my @rawres; | ||||
429 | my %didalready; | ||||||
430 | 0 | 0 | while ( my $onerow = $sth->fetchrow_arrayref ) { | ||||
431 | 0 | 0 | 0 | 0 | next if $onerow->[11] && exists $self->{'aliasfilter'}->{$onerow->[11]}; | ||
432 | 0 | 0 | my $uri = $onerow->[4]; # Evtl. Expliziter Link | ||||
433 | 0 | 0 | my $guri = ""; | ||||
434 | |||||||
435 | 0 | 0 | my $h = $onerow->[0]; | ||||
436 | 0 | 0 | my $p; | ||||
437 | 0 | 0 | 0 | 0 | if ( $h eq $hash ) { | ||
0 | |||||||
438 | 0 | 0 | $p = $pretty} | ||||
439 | elsif ( $clusterid && ref($c) ) { | ||||||
440 | 0 | 0 | $c->value(""); | ||||
441 | 0 | 0 | 0 | my $did = $c->hash($h) || $c->value($h) || $h; | |||
442 | 0 | 0 | 0 | $p = $c->can("pretty") ? $c->pretty() : $c->value(); | |||
443 | }; | ||||||
444 | 0 | 0 | 0 | $p = ($clusterid ? $h : $pretty) unless defined $p; | |||
0 | |||||||
445 | |||||||
446 | 0 | 0 | 0 | if ( $onerow->[1] ) { # Konkordanzformat | |||
0 | |||||||
447 | 0 | 0 | 0 | $uri ||= sprintf($onerow->[6] || $onerow->[5], $p, SeeAlso::Source::BeaconAggregator::urlpseudoescape($onerow->[1])); | |||
0 | |||||||
448 | 0 | 0 | 0 | $guri = sprintf($onerow->[7], $p, SeeAlso::Source::BeaconAggregator::urlpseudoescape($onerow->[1])) if $onerow->[7]; | |||
449 | } | ||||||
450 | elsif ( $onerow->[5] ) { # normales Beacon-Format | ||||||
451 | 0 | 0 | 0 | $uri ||= sprintf($onerow->[5], $p); | |||
452 | 0 | 0 | 0 | $guri = sprintf($onerow->[7], $p) if $onerow->[7]; | |||
453 | }; | ||||||
454 | 0 | 0 | 0 | next unless $uri; | |||
455 | |||||||
456 | # #NAME #INSTITUTION _alias | ||||||
457 | 0 | 0 | my $label; | ||||
458 | 0 | 0 | 0 | 0 | if ( $label = $onerow->[8] ) { #MESSAGE | ||
0 | |||||||
459 | 0 | 0 | 0 | $label = sprintf($label, $onerow->[2] || "...")} | |||
460 | elsif ( $label = $onerow->[9] || $onerow->[10] || $onerow->[11] || "???" ) { | ||||||
461 | 0 | 0 | 0 | $label .= " (".$onerow->[1].")" if $onerow->[1]} | |||
462 | |||||||
463 | 0 | 0 | 0 | push(@rawres, [$uri, $guri, $label, $onerow->[11], $onerow->[3]]) unless $didalready{join("\x7f", $label, $uri)}++;; | |||
464 | }; | ||||||
465 | 0 | 0 | my $hits = scalar @rawres; | ||||
466 | |||||||
467 | 0 | 0 | 0 | if ( ! $hits ) { | |||
0 | |||||||
468 | 0 | 0 | print $cgi->header(-status => "404 Not Found (identifier '$canon')", | ||||
469 | %headerdefaults), | ||||||
470 | $cgi->start_html (-dtd => "-//W3C//DTD HTML 3.2 Final//EN", | ||||||
471 | -title => "No References for $pretty", | ||||||
472 | ), | ||||||
473 | $cgi->p("No References found for ", $cgi->a({href=>"$canon"}, $pretty)), | ||||||
474 | $cgi->end_html; | ||||||
475 | 0 | 0 | return ""; | ||||
476 | } | ||||||
477 | elsif ( $hits == 1 ) { | ||||||
478 | 0 | 0 | return $cgi->redirect(-status => "302 Found (Redirecting for identifier '$canon')", | ||||
479 | -uri => $rawres[0]->[0], | ||||||
480 | %headerdefaults); | ||||||
481 | } | ||||||
482 | |||||||
483 | 0 | 0 | my $sources = new CGI($cgi); | ||||
484 | 0 | 0 | $sources->param(-name => 'id', -value=>"$canon"); | ||||
485 | 0 | 0 | 0 | unless ( $canon =~ /:\/\// ) { | |||
486 | 0 | 0 | my ($osd, $beaconmeta) = $self->get_meta; | ||||
487 | 0 | 0 | 0 | my $prefix = $beaconmeta->{'PREFIX'} || ""; | |||
488 | 0 | 0 | 0 | $canon = "$prefix$pretty" if $prefix; | |||
489 | }; | ||||||
490 | 0 | 0 | 0 | if ( my $multired = $extra->{redirect_300} ) { | |||
491 | 0 | 0 | $sources->param(-name => 'format', -value=>$multired); | ||||
492 | 0 | 0 | print $cgi->redirect(-status => "300 Multiple Choices for identifier '$canon'", | ||||
493 | -uri => $sources->url(-path_info=>1, -query=>1), | ||||||
494 | %headerdefaults); | ||||||
495 | } | ||||||
496 | else { | ||||||
497 | 0 | 0 | print $cgi->header(-status => "300 Multiple Choices for identifier '$canon'", | ||||
498 | # -nph => 1, # for older CGI/mod_perl??? | ||||||
499 | %headerdefaults); | ||||||
500 | # mod_perl overrides the header and adds a custom document at the end of everything | ||||||
501 | # therefore we force the header out (a simple print "" does not suffice) and then can | ||||||
502 | # safely reset the status to OK via CGI.pm leaking the Apache2::Request object | ||||||
503 | 0 | 0 | 0 | if ( my $r = $sources->r ) { | |||
504 | 0 | 0 | local($|) = 1; | ||||
505 | 0 | 0 | print "\n"; | ||||
506 | 0 | 0 | $r->status(200); | ||||
507 | }; | ||||||
508 | }; | ||||||
509 | 0 | 0 | my @result; | ||||
510 | 0 | 0 | push(@result, $cgi->start_html ( -title => "$hits References for $pretty", | ||||
511 | -dtd => "-//W3C//DTD HTML 3.2 Final//EN"), | ||||||
512 | $cgi->h1("$hits References for ", $cgi->a({href=>"$canon"}, $pretty)), | ||||||
513 | '
|
||||||
514 | |||||||
515 | 0 | 0 | my $rowcnt = 0; | ||||
516 | 0 | 0 | foreach ( @rawres ) { # uri, guri, label, alias, info | ||||
517 | 0 | 0 | 0 | if ( $_->[1] ) { | |||
518 | 0 | 0 | 0 | my $tooltip = $_->[4] ? ($_->[4]." [".$_->[2]."]") : $_->[2]; | |||
519 | 0 | 0 | 0 | my $img = $cgi->a({href=>$_->[0], title=>$tooltip}, $cgi->img({src=>$_->[1], alt=>$_->[4]||$_->[2], style=>"width: 5em; border: 0pt;"})); | |||
520 | 0 | 0 | 0 | push(@result, $cgi->li({id=>"$_->[3]".++$rowcnt}, $img, $cgi->a({href=>$_->[0]}, $_->[2]), ($_->[4] ? " [".$_->[4]."]" : ""))); | |||
521 | } | ||||||
522 | else { | ||||||
523 | 0 | 0 | 0 | push(@result, $cgi->li({id=>"$_->[3]".++$rowcnt}, $cgi->a({href=>$_->[0]}, $_->[2]), $_->[4] ? " [".$_->[4]."]" : ""))}; | |||
524 | }; | ||||||
525 | |||||||
526 | 0 | 0 | push(@result, ''); | ||||
527 | |||||||
528 | 0 | 0 | 0 | if ( $server->{'formats'}->{'sources'} ) { | |||
529 | 0 | 0 | $sources->param(-name => 'format', -value=>"sources"); | ||||
530 | 0 | 0 | push(@result, $cgi->p("[", $cgi->a({href=>($sources->url(-path_info=>1, -query=>1))}, "Details"), "]")); | ||||
531 | }; | ||||||
532 | |||||||
533 | 0 | 0 | my($tu, $ts, $tcu, $tcs) = times(); | ||||
534 | 0 | 0 | push(@result, sprintf("", $tu, $ts, $tu+$ts), $cgi->end_html()); | ||||
535 | 0 | 0 | return join("\n", @result); | ||||
536 | } | ||||||
537 | |||||||
538 | =head2 sources ( $server, $format, $extra, $query ) | ||||||
539 | |||||||
540 | Produces an HTML page with details to the queried identifier (description of sources) | ||||||
541 | |||||||
542 | This subroutine may be used as callback method in SeeAlso::Server (cf. description | ||||||
543 | of redirect above | ||||||
544 | |||||||
545 | =over 8 | ||||||
546 | |||||||
547 | =item $server | ||||||
548 | |||||||
549 | SeeAlso::Server object | ||||||
550 | |||||||
551 | |||||||
552 | =item $format | ||||||
553 | |||||||
554 | Format selected for $server | ||||||
555 | |||||||
556 | |||||||
557 | =item $extra | ||||||
558 | |||||||
559 | Hashref with the following configuration directives | ||||||
560 | |||||||
561 | css => URL of css file to be referenced | ||||||
562 | |||||||
563 | =item $query | ||||||
564 | |||||||
565 | Identifier to be queried | ||||||
566 | |||||||
567 | =back | ||||||
568 | |||||||
569 | =cut | ||||||
570 | |||||||
571 | sub sources { # Liste der Beacon-Header fuer Treffer | ||||||
572 | # We escape all characters except US-ASCII, because older CGI.pm's set an xml declaration | ||||||
573 | # which somehow interferes with IE8's adherence to the character set... | ||||||
574 | 0 | 0 | 1 | 0 | my ($self, $server, $format, $extra, $query) = @_; | ||
575 | 0 | 0 | 0 | my $formatprops = $server->{'formats'}->{$format} || {}; | |||
576 | 0 | 0 | 0 | my $cgi = $server->{'cgi'} || CGI->new(); | |||
577 | |||||||
578 | 0 | 0 | my ($hash, $pretty, $canon) = $self->prepare_query($query); | ||||
579 | 0 | 0 | 0 | unless ( $hash ) { | |||
580 | 0 | 0 | print $cgi->header(-status => "400 Bad Request (Identifier '$query' not valid)", | ||||
581 | -expires => "+1y", | ||||||
582 | -type => 'text/html', | ||||||
583 | ), | ||||||
584 | $cgi->start_html (-dtd => "-//W3C//DTD HTML 3.2 Final//EN", | ||||||
585 | -title => "No valid identifier", | ||||||
586 | ), | ||||||
587 | $cgi->p("Malformed identifier '$query'"), | ||||||
588 | $cgi->end_html; | ||||||
589 | 0 | 0 | return ""; | ||||
590 | }; | ||||||
591 | |||||||
592 | 0 | 0 | my ($clusterid, %idlist); | ||||
593 | 0 | 0 | 0 | my $c = $self->{identifierClass} || undef; | |||
594 | 0 | 0 | 0 | if ( $self->{cluster} ) { | |||
595 | 0 | 0 | my ($clusterh, $clusterexpl) = $self->stmtHdl("SELECT beacons.hash, beacons.altid FROM cluster.beacons WHERE beacons.hash=? OR beacons.altid=? LIMIT 1;"); | ||||
596 | 0 | 0 | 0 | $self->stmtExplain($clusterexpl, $hash, $hash) if $ENV{'DBI_PROFILE'}; | |||
597 | 0 | 0 | 0 | $clusterh->execute($hash, $hash) or croak("Could not execute >".$clusterh->{Statement}."<: ".$clusterh->errstr); | |||
598 | 0 | 0 | while ( my $onerow = $clusterh->fetchrow_arrayref() ) { | ||||
599 | 0 | 0 | $clusterid = $onerow->[1]; | ||||
600 | 0 | 0 | my $h = $onerow->[0]; | ||||
601 | 0 | 0 | 0 | if ( $c ) { | |||
602 | 0 | 0 | $c->value(""); | ||||
603 | 0 | 0 | 0 | my $did = $c->hash($h) || $c->value($h); | |||
604 | 0 | 0 | 0 | my $p = $c->can("pretty") ? $c->pretty() : $c->value(); | |||
605 | 0 | 0 | $idlist{$p} = ""; | ||||
606 | } | ||||||
607 | else { | ||||||
608 | 0 | 0 | $idlist{$h} = ""; | ||||
609 | } | ||||||
610 | }; | ||||||
611 | 0 | 0 | $idlist{$pretty} = "queriedid"; | ||||
612 | 0 | 0 | 0 | if ( $clusterid ) { | |||
613 | 0 | 0 | 0 | if ( $clusterid eq $hash ) { | |||
0 | |||||||
614 | 0 | 0 | $idlist{$pretty} .= " preferredid"} | ||||
615 | elsif ( $c ) { | ||||||
616 | 0 | 0 | $c->value(""); | ||||
617 | 0 | 0 | 0 | my $did = $c->hash($clusterid) || $c->value($clusterid); | |||
618 | 0 | 0 | 0 | my $p = $c->can("pretty") ? $c->pretty() : $c->value(); | |||
619 | 0 | 0 | $idlist{$p} = "variantid preferredid"; | ||||
620 | } | ||||||
621 | else { | ||||||
622 | 0 | 0 | $idlist{$clusterid} = "variantid preferredid"; | ||||
623 | }; | ||||||
624 | 0 | 0 | my ($varianth, $variantexpl) = $self->stmtHdl("SELECT beacons.hash FROM cluster.beacons WHERE beacons.altid=?;"); | ||||
625 | 0 | 0 | 0 | $self->stmtExplain($variantexpl, $clusterid) if $ENV{'DBI_PROFILE'}; | |||
626 | 0 | 0 | 0 | $varianth->execute($clusterid) or croak("Could not execute >".$varianth->{Statement}."<: ".$varianth->errstr); | |||
627 | 0 | 0 | while ( my $onerow = $varianth->fetchrow_arrayref() ) { | ||||
628 | 0 | 0 | my $v = $onerow->[0]; | ||||
629 | 0 | 0 | 0 | if ( $c ) { | |||
630 | 0 | 0 | $c->value(""); | ||||
631 | 0 | 0 | 0 | my $did = $c->hash($v) || $c->value($v); | |||
632 | 0 | 0 | 0 | my $p = $c->can("pretty") ? $c->pretty() : $c->value(); | |||
633 | 0 | 0 | 0 | (exists $idlist{$p}) || ($idlist{$p} = "variantid"); | |||
634 | } | ||||||
635 | else { | ||||||
636 | 0 | 0 | 0 | (exists $idlist{$v}) || ($idlist{$v} = "variantid"); | |||
637 | } | ||||||
638 | } | ||||||
639 | } | ||||||
640 | } | ||||||
641 | |||||||
642 | 0 | 0 | my ($countsth, $countexpl); | ||||
643 | 0 | 0 | 0 | if ( $clusterid ) { | |||
644 | 0 | 0 | ($countsth, $countexpl) = $self->stmtHdl(<<"XxX"); | ||||
645 | SELECT COUNT(DISTINCT seqno) FROM beacons | ||||||
646 | WHERE ( (hash=?) OR (hash IN (SELECT beacons.hash FROM cluster.beacons WHERE cluster.beacons.altid=?)) ); | ||||||
647 | XxX | ||||||
648 | 0 | 0 | 0 | $self->stmtExplain($countexpl, $clusterid, $clusterid) if $ENV{'DBI_PROFILE'}; | |||
649 | 0 | 0 | 0 | $countsth->execute($clusterid, $clusterid) or croak("Could not execute >".$countsth->{Statement}."<: ".$countsth->errstr); | |||
650 | } | ||||||
651 | else { | ||||||
652 | 0 | 0 | ($countsth, $countexpl) = $self->stmtHdl(<<"XxX"); | ||||
653 | SELECT COUNT(DISTINCT seqno) FROM beacons WHERE hash=?; | ||||||
654 | XxX | ||||||
655 | 0 | 0 | 0 | $self->stmtExplain($countexpl, $hash) if $ENV{'DBI_PROFILE'}; | |||
656 | 0 | 0 | 0 | $countsth->execute($hash) or croak("Could not execute >".$countsth->{Statement}."<: ".$countsth->errstr); | |||
657 | }; | ||||||
658 | 0 | 0 | my $hitsref = $countsth->fetchrow_arrayref; | ||||
659 | 0 | 0 | 0 | my $hits = $hitsref->[0] || 0; | |||
660 | |||||||
661 | 0 | 0 | my ($osd, $beaconmeta) = $self->get_meta; | ||||
662 | 0 | 0 | 0 | my $prefix = $beaconmeta->{'PREFIX'} || ""; | |||
663 | 0 | 0 | 0 | (my $servicename = $beaconmeta->{'NAME'} || $osd->{'ShortName'} || "") =~ s/([<>&"]|[^\x00-\x7f])/''.ord($1).';'/ge; | |||
0 | 0 | ||||||
664 | |||||||
665 | 0 | 0 | my $target = $cgi->url(-path=>1); | ||||
666 | |||||||
667 | 0 | 0 | my @result; | ||||
668 | push(@result, $cgi->start_html( | ||||||
669 | -encoding => "UTF-8", | ||||||
670 | -title => "$servicename referring ".$query->as_string(), | ||||||
671 | -meta => {'robots'=>'noindex'}, | ||||||
672 | 0 | 0 | 0 | ($extra->{'css'} ? (-style => {'src'=>$extra->{'css'}}) : ()), | |||
673 | -head => [$cgi->Link({-rel=>'unapi-server', | ||||||
674 | -type=>'application/xml', | ||||||
675 | title=>'unAPI', | ||||||
676 | -href=>$target}), | ||||||
677 | $cgi->Link({-rel=>'start', | ||||||
678 | -href=>$target}), | ||||||
679 | ], | ||||||
680 | )); | ||||||
681 | |||||||
682 | 0 | 0 | push(@result, ''); | ||||
683 | 0 | 0 | push(@result, ''); | ||||
684 | |||||||
685 | 0 | 0 | push(@result, $cgi->h1("$hits References for ".$cgi->abbr({class=>"unapi-id", title=>"$canon"}, $query))); | ||||
686 | |||||||
687 | 0 | 0 | push(@result, ' '); |
||||
688 | 0 | 0 | 0 | push(@result, $cgi->p($cgi->span("Identifier:"), $cgi->a({href=>"$prefix$pretty"}, "$prefix$pretty"))) if $prefix; | |||
689 | # delete $idlist{$pretty} if $prefix; | ||||||
690 | 0 | 0 | 0 | 0 | push(@result, $cgi->p($cgi->span("Variant Identifiers:"), map {$cgi->span({class=>($idlist{$_} || "variantid")}, $_)} sort keys %idlist)) if %idlist; | ||
0 | 0 | ||||||
691 | 0 | 0 | push(@result, ''); | ||||
692 | |||||||
693 | 0 | 0 | my ($srcsth, $srcexpl); | ||||
694 | 0 | 0 | 0 | if ( $clusterid ) { | |||
695 | 0 | 0 | ($srcsth, $srcexpl) = $self->stmtHdl(<<"XxX"); | ||||
696 | SELECT beacons.*, repos.* | ||||||
697 | FROM beacons NATURAL LEFT JOIN repos | ||||||
698 | WHERE ( (beacons.hash=?) | ||||||
699 | OR (beacons.hash IN (SELECT beacons.hash FROM cluster.beacons WHERE cluster.beacons.altid=?)) ) | ||||||
700 | ORDER BY repos.sort, repos.alias; | ||||||
701 | XxX | ||||||
702 | 0 | 0 | 0 | $self->stmtExplain($srcexpl, $clusterid, $clusterid) if $ENV{'DBI_PROFILE'}; | |||
703 | 0 | 0 | 0 | $srcsth->execute($clusterid, $clusterid) or croak("Could not execute >".$srcsth->{Statement}."<: ".$srcsth->errstr); | |||
704 | } | ||||||
705 | else { | ||||||
706 | 0 | 0 | ($srcsth, $srcexpl) = $self->stmtHdl(<<"XxX"); | ||||
707 | SELECT beacons.*, repos.* | ||||||
708 | FROM beacons NATURAL LEFT JOIN repos | ||||||
709 | WHERE beacons.hash=? | ||||||
710 | ORDER BY repos.sort, repos.alias; | ||||||
711 | XxX | ||||||
712 | 0 | 0 | 0 | $self->stmtExplain($srcexpl, $hash) if $ENV{'DBI_PROFILE'}; | |||
713 | 0 | 0 | 0 | $srcsth->execute($hash) or croak("Could not execute >".$srcsth->{Statement}."<: ".$srcsth->errstr); | |||
714 | } | ||||||
715 | |||||||
716 | 0 | 0 | my $rows = 0; | ||||
717 | 0 | 0 | push(@result, ' '); |
||||
718 | 0 | 0 | my ($lastseq, @groups) = (0, ()); | ||||
719 | 0 | 0 | while ( my $onerow = $srcsth->fetchrow_hashref ) { | ||||
720 | 0 | 0 | $rows ++; | ||||
721 | 0 | 0 | 0 | 0 | if ( $lastseq and $onerow->{'seqno'} == $lastseq ) { | ||
722 | 0 | 0 | my %vary; | ||||
723 | 0 | 0 | foreach my $key ( grep /^(hash|altid|hits|info|link)$/, keys %$onerow ) { | ||||
724 | 0 | 0 | my $pval = $onerow->{$key}; | ||||
725 | 0 | 0 | 0 | next unless defined $pval; | |||
726 | 0 | 0 | 0 | $pval =~ s/([<>&"]|[^\x00-\x7f])/''.ord($1).';'/ge if $key eq "link"; | |||
0 | 0 | ||||||
727 | 0 | 0 | $vary{$key} = $pval; | ||||
728 | } | ||||||
729 | 0 | 0 | push(@{$groups[$#groups]}, \%vary); | ||||
0 | 0 | ||||||
730 | } | ||||||
731 | else { | ||||||
732 | 0 | 0 | my (%vary, %repos, %meta); | ||||
733 | 0 | 0 | while ( my($key, $val) = each %$onerow ) { | ||||
734 | 0 | 0 | my $pval = $val; | ||||
735 | 0 | 0 | 0 | unless ( $key =~ /altid|feed|target|uri|link/i ) { | |||
736 | 0 | 0 | 0 | $pval =~ s/([<>&"]|[^\x00-\x7f])/''.ord($1).';'/ge if defined $pval}; | |||
0 | 0 | ||||||
737 | 0 | 0 | 0 | if ( $key =~ /time|revisit/i ) { | |||
738 | 0 | 0 | 0 | next unless $val; | |||
739 | 0 | 0 | $pval = HTTP::Date::time2str($val); | ||||
740 | }; | ||||||
741 | 0 | 0 | 0 | if ( $key =~ /^bc(\w+)$/ ) { | |||
0 | |||||||
742 | 0 | 0 | 0 | $repos{$1} = $pval if $pval} | |||
743 | elsif ( $key =~ /^(hash|altid|hits|info|link)$/ ) { | ||||||
744 | 0 | 0 | $vary{$key} = $pval} | ||||
745 | else { | ||||||
746 | 0 | 0 | 0 | $meta{"_$key"} = $pval if $pval} | |||
747 | }; | ||||||
748 | 0 | 0 | push(@groups, [\%repos, \%meta, \%vary]); | ||||
749 | }; | ||||||
750 | 0 | 0 | $lastseq = $onerow->{'seqno'}; | ||||
751 | }; | ||||||
752 | # Grouping done, now display... | ||||||
753 | |||||||
754 | 0 | 0 | my %didalreadysee; | ||||
755 | 0 | 0 | foreach my $groupref ( @groups ) { | ||||
756 | 0 | 0 | my ($repos, $meta, @vary) = @$groupref; | ||||
757 | |||||||
758 | 0 | 0 | 0 | my $aos = $meta->{'_alias'} || $meta->{'_seqno'}; | |||
759 | |||||||
760 | 0 | 0 | 0 | my $multi = (scalar @vary > 1) ? "multi" : "single"; | |||
761 | 0 | 0 | push(@result, qq! !); |
||||
762 | 0 | 0 | push(@result, $cgi->h3({class=>"aggregator", onClick=>"toggle('ag$aos')"}, "Administrative Details")); | ||||
763 | |||||||
764 | 0 | 0 | push(@result, $cgi->h3({class=>"beacon", onClick=>"toggle('bc$aos')"}, "Repository Details")); | ||||
765 | |||||||
766 | 0 | 0 | 0 | if ( $multi eq "single" ) { | |||
767 | 0 | 0 | push(@result, $cgi->h3({class=>"hit", onClick=>"toggle('ht$aos')"}, "Result Details")); | ||||
768 | |||||||
769 | 0 | 0 | my $vary = $vary[0]; | ||||
770 | |||||||
771 | 0 | 0 | my $hits = $vary->{'hits'}; | ||||
772 | 0 | 0 | my $description = $hits; | ||||
773 | |||||||
774 | 0 | 0 | my $h = $vary->{'hash'}; | ||||
775 | 0 | 0 | 0 | my $variantid = ($h eq $hash) ? "" : "variantid"; | |||
776 | 0 | 0 | my $p; | ||||
777 | 0 | 0 | 0 | 0 | if ( $h eq $hash ) { | ||
0 | |||||||
778 | 0 | 0 | $p = $pretty} | ||||
779 | elsif ( $clusterid && ref($c) ) { | ||||||
780 | 0 | 0 | $c->value(""); | ||||
781 | 0 | 0 | 0 | my $did = $c->hash($h) || $c->value($h) || $h; | |||
782 | 0 | 0 | 0 | $p = $c->can("pretty") ? $c->pretty() : $c->value(); | |||
783 | }; | ||||||
784 | 0 | 0 | 0 | $p = ($clusterid ? $h : $pretty) unless defined $p; | |||
0 | |||||||
785 | |||||||
786 | 0 | 0 | my $uri = "???"; | ||||
787 | 0 | 0 | 0 | 0 | if ( $uri = $vary->{'link'} ) { # o.k. | ||
0 | |||||||
0 | |||||||
0 | |||||||
788 | } | ||||||
789 | elsif ( $repos->{'ALTTARGET'} && $vary->{'altid'} ) { | ||||||
790 | 0 | 0 | $uri = sprintf($repos->{'ALTTARGET'}, $p, SeeAlso::Source::BeaconAggregator::urlpseudoescape($vary->{'altid'}))} | ||||
791 | elsif ( $repos->{'TARGET'} ) { | ||||||
792 | 0 | 0 | $uri = sprintf($repos->{'TARGET'}, $p)} | ||||
793 | elsif ( $repos->{'ALTTARGET'} ) { | ||||||
794 | 0 | 0 | $uri = sprintf($repos->{'ALTTARGET'}, $p, SeeAlso::Source::BeaconAggregator::urlpseudoescape($p))}; | ||||
795 | |||||||
796 | 0 | 0 | 0 | my $redundant = ($didalreadysee{$uri}++) ? "subsequent" : ""; | |||
797 | |||||||
798 | 0 | 0 | my $guri = ""; | ||||
799 | 0 | 0 | 0 | if ( $repos->{'IMGTARGET'} ) { | |||
800 | 0 | 0 | $guri = sprintf($repos->{'IMGTARGET'}, $p, SeeAlso::Source::BeaconAggregator::urlpseudoescape($vary->{'altid'}))} | ||||
801 | |||||||
802 | 0 | 0 | 0 | my @labels = grep /\S/, $repos->{'NAME'} || "", $repos->{'DESCRIPTION'} || "", $repos->{'INSTITUTION'} || ""; | |||
0 | |||||||
0 | |||||||
803 | 0 | 0 | my $rlabel; | ||||
804 | 0 | 0 | 0 | if ( $hits == 1 ) { | |||
0 | |||||||
805 | 0 | 0 | 0 | $rlabel = $repos->{'ONEMESSAGE'} if $repos->{'ONEMESSAGE'}} | |||
806 | elsif ( $hits == 0 ) { | ||||||
807 | 0 | 0 | 0 | $rlabel = $repos->{'SOMEMESSAGE'} if $repos->{'SOMEMESSAGE'}}; | |||
808 | 0 | 0 | 0 | unless ( $rlabel ) { | |||
809 | 0 | 0 | 0 | $rlabel = $repos->{'MESSAGE'} || shift @labels || "???"}; | |||
810 | 0 | 0 | my $label = sprintf($rlabel, $hits); | ||||
811 | |||||||
812 | 0 | 0 | 0 | my $ttip = pop @labels || ""; | |||
813 | 0 | 0 | $ttip =~ s/(\d+);/chr($1)/ge; | ||||
0 | 0 | ||||||
814 | |||||||
815 | 0 | 0 | 0 | 0 | push(@result, $cgi->a({style=>"float: right; clear: right;", href=>$uri}, $cgi->img({alt=>$vary->{'info'}||$label,src=>$guri}))) if $guri; | ||
816 | |||||||
817 | 0 | 0 | push(@result, $cgi->h2({class=>"label $redundant $variantid ident_$p", id=>"head$aos"}, $cgi->a({href=>$uri, title=>$ttip}, $label))); | ||||
818 | |||||||
819 | 0 | 0 | push(@result, qq! !); |
||||
820 | 0 | 0 | 0 | push(@result, $cgi->span($vary->{'info'})) if $vary->{'info'}; | |||
821 | 0 | 0 | 0 | 0 | push(@result, $cgi->span("($hits Treffer)")) if $hits && ($rlabel !~ /%s/); | ||
822 | 0 | 0 | push(@result, ''); | ||||
823 | |||||||
824 | 0 | 0 | push(@result, qq! | ||||
825 | 0 | 0 | push(@result, $cgi->p({class=>"ht_uri"}, $cgi->span("Target URL:"), $cgi->a({href=>$uri}, CGI::escapeHTML($uri)))); | ||||
826 | 0 | 0 | 0 | push(@result, $cgi->p({class=>"ht_guri"}, $cgi->span("Preview URL:"), $cgi->a({href=>$guri}, $guri))) if $guri; | |||
827 | 0 | 0 | 0 | push(@result, $cgi->p({class=>"ht_hits"}, $cgi->span("Hits:"), $hits)) if $hits; | |||
828 | 0 | 0 | 0 | push(@result, $cgi->p({class=>"ht_info"}, $cgi->span("Additional Info:"), $vary->{'info'})) if $vary->{'info'}; | |||
829 | 0 | 0 | 0 | push(@result, $cgi->p({class=>"ht_idnote"}, $cgi->span("Variant Identifier:"), $p)) if $variantid; | |||
830 | 0 | 0 | push(@result, ''); | ||||
831 | } | ||||||
832 | else { | ||||||
833 | 0 | 0 | push(@result, $cgi->h3({class=>"hit", onClick=>"mtoggle('res$aos', 'hit')"}, "Result Details")); | ||||
834 | 0 | 0 | my $hits = scalar @vary; | ||||
835 | |||||||
836 | 0 | 0 | 0 | my @labels = grep /\S/, $repos->{'NAME'} || "", $repos->{'DESCRIPTION'} || "", $repos->{'INSTITUTION'} || ""; | |||
0 | |||||||
0 | |||||||
837 | 0 | 0 | 0 | my $rlabel = $repos->{'MESSAGE'} || shift @labels || "???"; | |||
838 | 0 | 0 | 0 | my $ttip = pop @labels || ""; | |||
839 | 0 | 0 | $ttip =~ s/(\d+);/chr($1)/ge; | ||||
0 | 0 | ||||||
840 | |||||||
841 | # my $rlabel = $repos->{'SOMEMESSAGE'} || $repos->{'MESSAGE'} || $repos->{'DESCRIPTION'} || $repos->{'NAME'} || $repos->{'INSTITUTION'} || "???"; | ||||||
842 | |||||||
843 | # my $ttip = $repos->{'MESSAGE'} ? $repos->{'DESCRIPTION'} || $repos->{'NAME'} || $repos->{'INSTITUTION'} || "" | ||||||
844 | |||||||
845 | # : $repos->{'INSTITUTION'} || $repos->{'NAME'} || ""; | ||||||
846 | |||||||
847 | # $ttip = "" if $ttip eq $rlabel; | ||||||
848 | 0 | 0 | $ttip =~ s/(\d+);/chr($1)/ge; | ||||
0 | 0 | ||||||
849 | |||||||
850 | 0 | 0 | my $label = sprintf($rlabel, $hits); | ||||
851 | 0 | 0 | push(@result, $cgi->h2({class=>"label", id=>"head$aos"}, $label)); | ||||
852 | |||||||
853 | 0 | 0 | push(@result, qq!
|
||||
854 | 0 | 0 | my $cnt = 0; | ||||
855 | 0 | 0 | foreach my $vary ( @vary ) { | ||||
856 | 0 | 0 | $cnt ++; | ||||
857 | |||||||
858 | 0 | 0 | my $h = $vary->{'hash'}; | ||||
859 | 0 | 0 | 0 | my $variantid = ($h eq $hash) ? "" : "variantid"; | |||
860 | 0 | 0 | my $p; | ||||
861 | 0 | 0 | 0 | 0 | if ( $h eq $hash ) { | ||
0 | |||||||
862 | 0 | 0 | $p = $pretty} | ||||
863 | elsif ( $clusterid && ref($c) ) { | ||||||
864 | 0 | 0 | $c->value(""); | ||||
865 | 0 | 0 | 0 | my $did = $c->hash($h) || $c->value($h) || $h; | |||
866 | 0 | 0 | 0 | $p = $c->can("pretty") ? $c->pretty() : $c->value(); | |||
867 | }; | ||||||
868 | 0 | 0 | 0 | $p = ($clusterid ? $h : $pretty) unless defined $p; | |||
0 | |||||||
869 | |||||||
870 | 0 | 0 | my $uri = "???"; | ||||
871 | 0 | 0 | 0 | 0 | if ( $uri = $vary->{'link'} ) { # o.k. | ||
0 | |||||||
0 | |||||||
0 | |||||||
872 | } | ||||||
873 | elsif ( $repos->{'ALTTARGET'} && $vary->{'altid'} ) { | ||||||
874 | 0 | 0 | $uri = sprintf($repos->{'ALTTARGET'}, $p, SeeAlso::Source::BeaconAggregator::urlpseudoescape($vary->{'altid'}))} | ||||
875 | elsif ( $repos->{'TARGET'} ) { | ||||||
876 | 0 | 0 | $uri = sprintf($repos->{'TARGET'}, $p)} | ||||
877 | elsif ( $repos->{'ALTTARGET'} ) { | ||||||
878 | 0 | 0 | $uri = sprintf($repos->{'ALTTARGET'}, $p, SeeAlso::Source::BeaconAggregator::urlpseudoescape($p))}; | ||||
879 | |||||||
880 | 0 | 0 | 0 | my $redundant = ($didalreadysee{$uri}++) ? "subsequent" : ""; | |||
881 | |||||||
882 | 0 | 0 | my $guri = ""; | ||||
883 | 0 | 0 | 0 | if ( $repos->{'IMGTARGET'} ) { | |||
884 | 0 | 0 | $guri = sprintf($repos->{'IMGTARGET'}, $p, SeeAlso::Source::BeaconAggregator::urlpseudoescape($vary->{'altid'}))} | ||||
885 | |||||||
886 | 0 | 0 | 0 | 0 | my $hits = $vary->{hits} if $vary->{hits} and $vary->{hits} != 1; | ||
887 | |||||||
888 | 0 | 0 | push(@result, qq! |
||||
889 | 0 | 0 | 0 | push(@result, $cgi->div({style=>"float: right;"}, $cgi->a({href=>$uri}, $cgi->img({src=>$guri})))) if $guri; | |||
890 | 0 | 0 | 0 | push(@result, $cgi->a({href=>$uri}, $cgi->span($vary->{'info'} || "[$cnt.]"))); | |||
891 | 0 | 0 | 0 | push(@result, $cgi->span("($hits Treffer)")) if $hits; | |||
892 | 0 | 0 | push(@result, ''); | ||||
893 | |||||||
894 | 0 | 0 | push(@result, qq! | ||||
895 | 0 | 0 | push(@result, $cgi->p({class=>"ht_uri"}, $cgi->span("Target URL:"), $cgi->a({href=>$uri}, $uri))); | ||||
896 | 0 | 0 | 0 | push(@result, $cgi->p({class=>"ht_guri"}, $cgi->span("Preview URL:"), $cgi->a({href=>$guri}, $guri))) if $guri; | |||
897 | 0 | 0 | 0 | push(@result, $cgi->p({class=>"ht_hits"}, $cgi->span("Hits:"), $vary->{hits})) if $vary->{hits}; | |||
898 | 0 | 0 | 0 | push(@result, $cgi->p({class=>"ht_info"}, $cgi->span("Additional Info:"), $vary->{'info'})) if $vary->{'info'}; | |||
899 | 0 | 0 | 0 | push(@result, $cgi->p({class=>"ht_idnote"}, $cgi->span("Variant Identifier:"), $p)) if $variantid; | |||
900 | |||||||
901 | 0 | 0 | push(@result, ''); | ||||
902 | 0 | 0 | push(@result, ''); | ||||
903 | }; | ||||||
904 | 0 | 0 | push(@result, qq!!); | ||||
905 | } | ||||||
906 | |||||||
907 | 0 | 0 | push(@result, qq! | ||||
908 | 0 | 0 | foreach ( sort keys %$repos ) { | ||||
909 | 0 | 0 | 0 | next if /(MESSAGE|TARGET)$/; | |||
910 | 0 | 0 | 0 | next unless $repos->{$_}; | |||
911 | 0 | 0 | $repos->{$_} =~ s!([a-z]+://\S+)!$cgi->a({href=>"$1", target=>"_blank"}, "$1")!ge; # URL | ||||
0 | 0 | ||||||
912 | 0 | 0 | $repos->{$_} =~ s!(?:\<\s*)?(\w[\w.-]*)\@((?:\w[\w-]*\.)+\w+)(?:\s*\>)?!<$1 (at) $2>!g; # Mail Addr | ||||
913 | 0 | 0 | $repos->{$_} =~ s/\s*\|\s*/ | /g; # Examples | ||||
914 | 0 | 0 | 0 | next if /^(FORMAT|PREFIX|REVISIT|VERSION)$/; # Postpone to "administrative Details" | |||
915 | 0 | 0 | push(@result, $cgi->p({class=>"bc_$_"}, $cgi->span("#$_:"), $repos->{$_})); | ||||
916 | }; | ||||||
917 | 0 | 0 | 0 | push(@result, $cgi->p({class=>"ag_mtime"}, $cgi->span("Modified:"), $meta->{'_mtime'})) if $meta->{'_mtime'}; | |||
918 | 0 | 0 | push(@result, ''); | ||||
919 | |||||||
920 | 0 | 0 | push(@result, qq! | ||||
921 | 0 | 0 | foreach ( sort keys %$repos ) { | ||||
922 | 0 | 0 | 0 | next unless /^(FORMAT|PREFIX|REVISIT|VERSION)$/; | |||
923 | 0 | 0 | 0 | next unless $repos->{$_}; | |||
924 | 0 | 0 | push(@result, $cgi->p({class=>"bc_$_"}, $cgi->span("#$_:"), $repos->{$_})); | ||||
925 | }; | ||||||
926 | 0 | 0 | 0 | push(@result, $cgi->p({class=>"ag_ftime"}, $cgi->span("Loaded:"), $meta->{'_ftime'})) if $meta->{'_ftime'}; | |||
927 | 0 | 0 | 0 | push(@result, $cgi->p({class=>"ag_fstat"}, $cgi->span("Load status:"), $meta->{'_fstat'})) if $meta->{'_fstat'}; | |||
928 | 0 | 0 | 0 | push(@result, $cgi->p({class=>"ag_utime"}, $cgi->span("Update attempt:"), $meta->{'_utime'})) if $meta->{'_utime'}; | |||
929 | 0 | 0 | 0 | push(@result, $cgi->p({class=>"ag_ustat"}, $cgi->span("Update status:"), $meta->{'_ustat'})) if $meta->{'_ustat'}; | |||
930 | 0 | 0 | 0 | push(@result, $cgi->p({class=>"ag_counti"}, $cgi->span("Identifiers:"), $meta->{'_counti'})) if $meta->{'_counti'}; | |||
931 | 0 | 0 | 0 | push(@result, $cgi->p({class=>"ag_countu"}, $cgi->span("Distinct Ids:"), $meta->{'_countu'})) if $meta->{'_countu'}; | |||
932 | 0 | 0 | 0 | push(@result, $cgi->p({class=>"ag_sort"}, $cgi->span("Sort key:"), $meta->{'_sort'})) if $meta->{'_sort'}; | |||
933 | 0 | 0 | 0 | push(@result, $cgi->p({class=>"ag_admin"}, $cgi->span("Remark:"), $meta->{'_admin'})) if $meta->{'_admin'}; | |||
934 | 0 | 0 | push(@result, ''); | ||||
935 | |||||||
936 | 0 | 0 | push(@result, ''); | ||||
937 | |||||||
938 | 0 | 0 | push(@result, ''); | ||||
939 | }; | ||||||
940 | 0 | 0 | push(@result, ''); | ||||
941 | |||||||
942 | 0 | 0 | push(@result, ' '); |
||||
943 | # $cgi->span("provided by:"), | ||||||
944 | 0 | 0 | push(@result, $cgi->p({class=>"mt_NAME"}, $cgi->a({href=>$target}, $servicename))); | ||||
945 | # $cgi->span("Service description:"), | ||||||
946 | 0 | 0 | 0 | (my $descr = $beaconmeta->{'DESCRIPTION'} || $osd->{'Description'} || "") =~ s/([<>&"]|[^\x00-\x7f])/''.ord($1).';'/ge; | |||
0 | 0 | ||||||
947 | 0 | 0 | push(@result, $cgi->p({class=>"mt_DESCRIPTION"}, $descr)); | ||||
948 | 0 | 0 | push(@result, ''); | ||||
949 | |||||||
950 | 0 | 0 | my($tu, $ts, $tcu, $tcs) = times(); | ||||
951 | 0 | 0 | push(@result, sprintf("", $tu, $ts, $tu+$ts), $cgi->end_html()); | ||||
952 | 0 | 0 | return join("\n", @result); | ||||
953 | } | ||||||
954 | |||||||
955 | |||||||
956 | =head2 get_meta () | ||||||
957 | |||||||
958 | Returns a pair of hash references: | ||||||
959 | |||||||
960 | =over 8 | ||||||
961 | |||||||
962 | =item 1 | ||||||
963 | |||||||
964 | OSD fields | ||||||
965 | |||||||
966 | =item 2 | ||||||
967 | |||||||
968 | Beacon header fields | ||||||
969 | |||||||
970 | =back | ||||||
971 | |||||||
972 | =cut | ||||||
973 | |||||||
974 | sub get_meta { | ||||||
975 | 1 | 1 | 1 | 1574 | my ($self) = @_; | ||
976 | |||||||
977 | 1 | 4 | my ($metasth, $metaexpl) = $self->stmtHdl(<<"XxX"); | ||||
978 | SELECT key, val FROM osd; | ||||||
979 | XxX | ||||||
980 | 1 | 50 | 4 | $self->stmtExplain($metaexpl) if $ENV{'DBI_PROFILE'}; | |||
981 | 1 | 50 | 42 | $metasth->execute() or croak("Could not execute >".$metasth->{Statement}."<: ".$metasth->errstr); | |||
982 | 1 | 2 | my (%osd, %beaconmeta); | ||||
983 | 1 | 15 | while ( my $aryref = $metasth->fetchrow_arrayref ) { | ||||
984 | 9 | 9 | my ($key, $val) = @$aryref; | ||||
985 | 9 | 50 | 10 | next unless $val; | |||
986 | 9 | 100 | 24 | if ($key =~ s/^bc// ) { # BeaconMeta Fields | |||
100 | |||||||
987 | 2 | 16 | $beaconmeta{$key} = $val} | ||||
988 | elsif ( exists $osd{$key} ) { | ||||||
989 | 6 | 100 | 9 | if ( ref($osd{$key}) ) { | |||
990 | 5 | 4 | push(@{$osd{$key}}, $val)} | ||||
5 | 21 | ||||||
991 | else { | ||||||
992 | 1 | 6 | $osd{$key} = [$osd{$key}, $val]}; | ||||
993 | } | ||||||
994 | else { | ||||||
995 | 1 | 7 | $osd{$key} = $val}; | ||||
996 | }; | ||||||
997 | 1 | 5 | return (\%osd, \%beaconmeta); | ||||
998 | } | ||||||
999 | |||||||
1000 | =head1 AUTHOR | ||||||
1001 | |||||||
1002 | Thomas Berger | ||||||
1003 | CPAN ID: THB | ||||||
1004 | gymel.com | ||||||
1005 | THB@cpan.org | ||||||
1006 | |||||||
1007 | =head1 COPYRIGHT | ||||||
1008 | |||||||
1009 | This program is free software; you can redistribute | ||||||
1010 | it and/or modify it under the same terms as Perl itself. | ||||||
1011 | |||||||
1012 | The full text of the license can be found in the | ||||||
1013 | LICENSE file included with this module. | ||||||
1014 | |||||||
1015 | |||||||
1016 | =cut | ||||||
1017 | |||||||
1018 | 1; | ||||||
1019 | # The preceding line will help the module return a true value | ||||||
1020 |