Open-ILS/src/perlmods/lib/OpenILS/WWW/SuperCat.pm

   1 package OpenILS::WWW::SuperCat;
   2 use strict; use warnings;
   3
   4 use Apache2::Log;
   5 use Apache2::Const -compile => qw(OK REDIRECT DECLINED NOT_FOUND :log);
   6 use APR::Const    -compile => qw(:error SUCCESS);
   7 use Apache2::RequestRec ();
   8 use Apache2::RequestIO ();
   9 use Apache2::RequestUtil;
  10 use CGI;
  11 use Data::Dumper;
  12 use SRU::Request;
  13 use SRU::Response;
  14
  15 use OpenSRF::EX qw(:try);
  16 use OpenILS::Utils::DateTime qw/:datetime/;
  17 use OpenSRF::Utils::Cache;
  18 use OpenSRF::System;
  19 use OpenSRF::AppSession;
  20 use XML::LibXML;
  21 use XML::LibXSLT;
  22
  23 use Encode;
  24 use Unicode::Normalize;
  25 use OpenILS::Utils::Fieldmapper;
  26 use OpenILS::WWW::SuperCat::Feed;
  27 use OpenSRF::Utils::Logger qw/$logger/;
  28 use OpenILS::Application::AppUtils;
  29 use OpenILS::Utils::TagURI;
  30
  31 use MARC::Record;
  32 use MARC::File::XML ( BinaryEncoding => 'UTF-8' );
  33
  34 my $log = 'OpenSRF::Utils::Logger';
  35 my $U = 'OpenILS::Application::AppUtils';
  36
  37 # set the bootstrap config when this module is loaded
  38 my ($bootstrap, $supercat, $actor, $parser, $search, $xslt, $cn_browse_xslt, %browse_types, %qualifier_map);
  39
  40 my $authority_axis_re = qr/^authority\.(\w+)(\.refs)?$/;
  41
  42 my %extra_header_action_per_type = (
  43     marc21 => [
  44         {"Content-Disposition" =>
  45             sub { "attachment;filename=" . time . ".mrc"}}
  46     ]
  47 );
  48
  49 $browse_types{call_number}{xml} = sub {
  50     my $tree = shift;
  51
  52     my $year = (gmtime())[5] + 1900;
  53     my $content = '';
  54
  55     $content .= "<volumes  xmlns='http://open-ils.org/spec/holdings/v1'>\n";
  56
  57     for my $cn (@$tree) {
  58         (my $cn_class = $cn->class_name) =~ s/::/-/gso;
  59         $cn_class =~ s/Fieldmapper-//gso;
  60
  61         my $cn_tag = "tag:open-ils.org,$year:$cn_class/".$cn->id;
  62         my $cn_lib = $cn->owning_lib->shortname;
  63         my $cn_label = $cn->label;
  64         my $cn_prefix = $cn->prefix->label;
  65         my $cn_suffix = $cn->suffix->label;
  66
  67         $cn_label =~ s/\n//gos;
  68         $cn_label =~ s/&/&amp;/go;
  69         $cn_label =~ s/'/&apos;/go;
  70         $cn_label =~ s/</&lt;/go;
  71         $cn_label =~ s/>/&gt;/go;
  72
  73         $cn_prefix =~ s/\n//gos;
  74         $cn_prefix =~ s/&/&amp;/go;
  75         $cn_prefix =~ s/'/&apos;/go;
  76         $cn_prefix =~ s/</&lt;/go;
  77         $cn_prefix =~ s/>/&gt;/go;
  78
  79         $cn_suffix =~ s/\n//gos;
  80         $cn_suffix =~ s/&/&amp;/go;
  81         $cn_suffix =~ s/'/&apos;/go;
  82         $cn_suffix =~ s/</&lt;/go;
  83         $cn_suffix =~ s/>/&gt;/go;
  84
  85         (my $ou_class = $cn->owning_lib->class_name) =~ s/::/-/gso;
  86         $ou_class =~ s/Fieldmapper-//gso;
  87
  88         my $ou_tag = "tag:open-ils.org,$year:$ou_class/".$cn->owning_lib->id;
  89         my $ou_name = $cn->owning_lib->name;
  90
  91         $ou_name =~ s/\n//gos;
  92         $ou_name =~ s/'/&apos;/go;
  93
  94         (my $rec_class = $cn->record->class_name) =~ s/::/-/gso;
  95         $rec_class =~ s/Fieldmapper-//gso;
  96
  97         my $rec_tag = "tag:open-ils.org,$year:$rec_class/".$cn->record->id.'/'.$cn->owning_lib->shortname;
  98
  99         $content .= "<volume id='$cn_tag' lib='$cn_lib' prefix='$cn_prefix' label='$cn_label' suffix='$cn_suffix'>\n";
 100         $content .= "<owning_lib xmlns='http://open-ils.org/spec/actors/v1' id='$ou_tag' name='$ou_name'/>\n";
 101
 102         my $r_doc = $parser->parse_string($cn->record->marc);
 103         $r_doc->documentElement->setAttribute( id => $rec_tag );
 104         $content .= $U->entityize($r_doc->documentElement->toString);
 105
 106         $content .= "</volume>\n";
 107     }
 108
 109     $content .= "</volumes>\n";
 110     return ("Content-type: application/xml\n\n",$content);
 111 };
 112
 113
 114 $browse_types{call_number}{html} = sub {
 115     my $tree = shift;
 116     my $p = shift;
 117     my $n = shift;
 118
 119     if (!$cn_browse_xslt) {
 120         $cn_browse_xslt = $parser->parse_file(
 121                 OpenSRF::Utils::SettingsClient
 122                         ->new
 123                         ->config_value( dirs => 'xsl' ).
 124                 "/CNBrowse2HTML.xsl"
 125         );
 126         $cn_browse_xslt = $xslt->parse_stylesheet( $cn_browse_xslt );
 127     }
 128
 129     my (undef,$xml) = $browse_types{call_number}{xml}->($tree);
 130
 131     return (
 132         "Content-type: text/html\n\n",
 133         $U->entityize(
 134             $cn_browse_xslt->transform(
 135                 $parser->parse_string( $xml ),
 136                 'prev' => "'$p'",
 137                 'next' => "'$n'"
 138             )->toString(1)
 139         )
 140     );
 141 };
 142
 143 sub import {
 144     my $self = shift;
 145     $bootstrap = shift;
 146 }
 147
 148
 149 sub child_init {
 150     OpenSRF::System->bootstrap_client( config_file => $bootstrap );
 151
 152     my $idl = OpenSRF::Utils::SettingsClient->new->config_value("IDL");
 153     Fieldmapper->import(IDL => $idl);
 154
 155     $supercat = OpenSRF::AppSession->create('open-ils.supercat');
 156     $actor = OpenSRF::AppSession->create('open-ils.actor');
 157     $search = OpenSRF::AppSession->create('open-ils.search');
 158     $parser = new XML::LibXML;
 159     $xslt = new XML::LibXSLT;
 160
 161     $cn_browse_xslt = $parser->parse_file(
 162             OpenSRF::Utils::SettingsClient
 163                     ->new
 164                     ->config_value( dirs => 'xsl' ).
 165             "/CNBrowse2HTML.xsl"
 166     );
 167
 168     $cn_browse_xslt = $xslt->parse_stylesheet( $cn_browse_xslt );
 169
 170     %qualifier_map = %{$supercat
 171         ->request("open-ils.supercat.biblio.search_aliases")
 172         ->gather(1)};
 173
 174     my %attribute_desc = (
 175         site        => 'Evergreen Site Code (shortname)',
 176         sort        => 'Sort on relevance, title, author, pubdate, create_date or edit_date',
 177         dir         => 'Sort direction (asc|desc)',
 178         available   => 'Filter to available (true|false)',
 179     );
 180
 181     # Append the non-search-alias attributes to the qualifier map
 182     foreach ( qw/
 183             available
 184             ascending
 185             descending
 186             sort
 187             format
 188             before
 189             after
 190             statuses
 191             locations
 192             site
 193             depth
 194             lasso
 195             offset
 196             limit
 197             preferred_language
 198             preferred_language_weight
 199             preferred_language_multiplier
 200         /) {
 201         $qualifier_map{'eg'}{$_}{'index'} = $_;
 202         if (exists $attribute_desc{$_}) {
 203             $qualifier_map{'eg'}{$_}{'title'} = $attribute_desc{$_};
 204         } else {
 205             $qualifier_map{'eg'}{$_}{'title'} = $_;
 206         }
 207     }
 208
 209     my $list = $supercat
 210         ->request("open-ils.supercat.record.formats")
 211         ->gather(1);
 212
 213     $list = [ map { (keys %$_)[0] } @$list ];
 214     push @$list, 'htmlholdings','html', 'marctxt', 'ris';
 215
 216     for my $browse_axis ( qw/title author subject topic series item-age/ ) {
 217         for my $record_browse_format ( @$list ) {
 218             {
 219                 my $__f = $record_browse_format;
 220                 my $__a = $browse_axis;
 221
 222                 $browse_types{$__a}{$__f} = sub {
 223                     my $record_list = shift;
 224                     my $prev = shift;
 225                     my $next = shift;
 226                     my $real_format = shift || $__f;
 227                     my $unapi = shift;
 228                     my $base = shift;
 229                     my $site = shift;
 230
 231                     $log->info("Creating record feed with params [$real_format, $record_list, $unapi, $site]");
 232                     my $feed = create_record_feed( 'record', $real_format, $record_list, $unapi, $site, undef, $real_format =~ /(-full|-uris)$/o ? 1 : 0 );
 233                     $feed->root( "$base/../" );
 234                     $feed->lib( $site );
 235                     $feed->link( next => $next => $feed->type );
 236                     $feed->link( previous => $prev => $feed->type );
 237
 238                     return (
 239                         "Content-type: ". $feed->type ."; charset=utf-8\n\n",
 240                         $feed->toString
 241                     );
 242                 };
 243             }
 244         }
 245     }
 246
 247     my $auth_axes = $supercat
 248         ->request("open-ils.supercat.authority.browse_axis_list")
 249         ->gather(1);
 250
 251
 252     for my $axis ( @$auth_axes ) {
 253         my $basic_axis = 'authority.' . $axis;
 254         for my $browse_axis ( ($basic_axis, $basic_axis . ".refs") ) {
 255             {
 256                 my $__f = 'marcxml';
 257                 my $__a = $browse_axis;
 258
 259                 $browse_types{$__a}{$__f} = sub {
 260                     my $record_list = shift;
 261                     my $prev = shift;
 262                     my $next = shift;
 263                     my $real_format = shift || $__f;
 264                     my $unapi = shift;
 265                     my $base = shift;
 266                     my $site = shift;
 267
 268                     $log->info("Creating record feed with params [$real_format, $record_list, $unapi, $site]");
 269                     my $feed = create_record_feed( 'authority', $real_format, $record_list, $unapi, $site, undef, $real_format =~ /-full$/o ? -1 : 0 );
 270                     $feed->root( "$base/../" );
 271                     $feed->link( next => $next => $feed->type );
 272                     $feed->link( previous => $prev => $feed->type );
 273
 274                     return (
 275                         "Content-type: ". $feed->type ."; charset=utf-8\n\n",
 276                         $feed->toString
 277                     );
 278                 };
 279             }
 280         }
 281     }
 282     return Apache2::Const::OK;
 283 }
 284
 285 sub check_child_init() {
 286     if (!defined $supercat || !defined $actor || !defined $search) {
 287         # For some reason one (or more) of our appsessions is missing....
 288         # So init!
 289         child_init();
 290     }
 291 }
 292
 293 =head2 parse_feed_type($type)
 294
 295 Determines whether and how a given feed type needs to be "fleshed out"
 296 with holdings information.
 297
 298 The feed type could end with the string "-full", in which case we want
 299 to return call numbers, copies, and URIS.
 300
 301 Or the feed type could end with "-uris", in which case we want to return
 302 call numbers and URIS.
 303
 304 Otherwise, we won't return any holdings.
 305
 306 =cut
 307
 308 sub parse_feed_type {
 309     my $type = shift || '';
 310
 311      if ($type =~ /-full$/o) {
 312         return 1;
 313     }
 314
 315      if ($type =~ /-uris$/o) {
 316         return 2;
 317     }
 318
 319     # Otherwise, we'll return just the facts, ma'am
 320     return 0;
 321 }
 322
 323 =head2 supercat_format($format_hashref, $format_type)
 324
 325 Given a reference to a hash containing the namespace_uri,
 326 docs, and schema location attributes for a set of formats,
 327 generate the XML description required by the supercat service.
 328
 329 We derive the base type from the format type so that we do not
 330 have to populate the hash with redundant information.
 331
 332 =cut
 333
 334 sub supercat_format {
 335     my $h = shift;
 336     my $type = shift;
 337
 338     (my $base_type = $type) =~ s/(-full|-uris)$//o;
 339
 340     my $format = "<format><name>$type</name><type>application/xml</type>";
 341
 342     for my $part ( qw/namespace_uri docs schema_location/ ) {
 343         $format .= "<$part>$$h{$base_type}{$part}</$part>"
 344             if ($$h{$base_type}{$part});
 345     }
 346
 347     $format .= '</format>';
 348
 349     return $format;
 350 }
 351
 352 =head2 unapi_format($format_hashref, $format_type)
 353
 354 Given a reference to a hash containing the namespace_uri,
 355 docs, and schema location attributes for a set of formats,
 356 generate the XML description required by the supercat service.
 357
 358 We derive the base type from the format type so that we do not
 359 have to populate the hash with redundant information.
 360
 361 =cut
 362
 363 sub unapi_format {
 364     my $h = shift;
 365     my $type = shift;
 366
 367     (my $base_type = $type) =~ s/(-full|-uris)$//o;
 368
 369     my $format = "<format name='$type' type='application/xml'";
 370
 371     for my $part ( qw/namespace_uri docs schema_location/ ) {
 372         $format .= " $part='$$h{$base_type}{$part}'"
 373             if ($$h{$base_type}{$part});
 374     }
 375
 376     $format .= "/>\n";
 377
 378     return $format;
 379 }
 380
 381
 382 # Return a list of strings suitable for printing on STDOUT as HTTP headers.
 383 sub extra_headers_per_type_to_string {
 384     my ($type) = @_;
 385     if (my $list = $extra_header_action_per_type{$type}) {
 386         return map {
 387             my $str = (keys(%$_))[0] . ": ";
 388             my $value = (values(%$_))[0];
 389             if (ref $value eq 'CODE') {
 390                 $value = $value->();
 391             }
 392             return $str . $value . "\n";
 393         } @$list;
 394     }
 395     return;
 396 }
 397
 398 # Return key/value pairs suitable for feeding into CGI::header()
 399 sub extra_headers_per_type_to_cgi {
 400     my ($type) = @_;
 401
 402     if (my $list = $extra_header_action_per_type{$type}) {
 403         return map {
 404             my $key = (keys(%$_))[0];
 405             my $value = (values(%$_))[0];
 406             if (ref $value eq 'CODE') {
 407                 $value = $value->();
 408             }
 409             return $key => $value;
 410         } @$list;
 411     }
 412     return;
 413 }
 414
 415 sub oisbn {
 416
 417     my $apache = shift;
 418     return Apache2::Const::DECLINED if (-e $apache->filename);
 419
 420     check_child_init();
 421
 422     (my $isbn = $apache->path_info) =~ s{^.*?([^/]+)$}{$1}o;
 423
 424     my $list = $supercat
 425         ->request("open-ils.supercat.oisbn", $isbn)
 426         ->gather(1);
 427
 428     print "Content-type: application/xml; charset=utf-8\n\n";
 429     print "<?xml version='1.0' encoding='UTF-8' ?>\n";
 430
 431     unless (exists $$list{metarecord}) {
 432         print '<idlist/>';
 433         return Apache2::Const::OK;
 434     }
 435
 436     print "<idlist metarecord='$$list{metarecord}'>\n";
 437
 438     for ( keys %{ $$list{record_list} } ) {
 439         (my $o = $$list{record_list}{$_}) =~s/^(\S+).*?$/$1/o;
 440         print "  <isbn record='$_'>$o</isbn>\n"
 441     }
 442
 443     print "</idlist>\n";
 444
 445     return Apache2::Const::OK;
 446 }
 447
 448 sub unapi2 {
 449     my $apache = shift;
 450     my $u2 = shift;
 451     my $format = shift;
 452
 453     my $ctype = 'application/xml';
 454     # Only bre and biblio_record_entry_feed have tranforms, but we'll ignore that for now
 455     if ($u2->classname =~ /^(?:bre|biblio_record_entry_feed)$/ and $format ne 'xml') {
 456         # XXX set $ctype to something else
 457     }
 458
 459     print "Content-type: $ctype; charset=utf-8\n\n";
 460     print "<?xml version='1.0' encoding='UTF-8' ?>\n";
 461     print $U->entityize(
 462          $supercat->request("open-ils.supercat.u2", $u2->toURI, $format)
 463         ->gather(1)
 464     );
 465
 466     return Apache2::Const::OK;
 467 }
 468
 469 sub unapi2_formats {
 470     my $apache = shift;
 471     my $u2 = shift;
 472
 473     print "Content-type: application/xml; charset=utf-8\n\n";
 474     print "<?xml version='1.0' encoding='UTF-8' ?>\n";
 475     my $id = $u2->toURI;
 476     if ($u2->classname =~ /^(?:bre|biblio_record_entry_feed)$/) {
 477         # TODO: if/when unapi.bre_output_layout becomes something
 478         # that actually changes, the hard-coding here should be
 479         # replaced
 480         print <<FORMATS;
 481 <formats id='$id'>
 482 <format name="holdings_xml" type="application/xml"/>
 483 <format name="marcxml" type="application/xml" namespace_uri="http://www.loc.gov/MARC21/slim" docs="http://www.loc.gov/marcxml/" schema_location="http://www.loc.gov/standards/marcxml/schema/MARC21slim.xsd"/>
 484 <format name="mods32" type="application/xml" namespace_uri="http://www.loc.gov/mods/v3" docs="http://www.loc.gov/mods/" schema_location="http://www.loc.gov/standards/mods/v3/mods-3-2.xsd"/>
 485 </formats>
 486 FORMATS
 487     } else {
 488         print <<FORMATS;
 489 <formats id='$id'>
 490 <format name="xml" type="application/xml"/>
 491 </formats>
 492 FORMATS
 493     }
 494
 495     return Apache2::Const::OK;
 496 }
 497
 498 sub unapi {
 499
 500     my $apache = shift;
 501     return Apache2::Const::DECLINED if (-e $apache->filename);
 502
 503     check_child_init();
 504
 505     my $cgi = new CGI;
 506
 507     my $add_path = 0;
 508     if ( $cgi->server_software !~ m|^Apache/2.2| ) {
 509         my $rel_name = $cgi->url(-relative=>1);
 510         $add_path = 1 if ($cgi->url(-path_info=>1) !~ /$rel_name$/);
 511     }
 512
 513     my $url = $cgi->url(-path_info=>$add_path);
 514     my $root = (split 'unapi', $url)[0];
 515     my $base = (split 'unapi', $url)[0] . 'unapi';
 516
 517
 518     my $uri = $cgi->param('id') || '';
 519
 520     my $format = $cgi->param('format') || '';
 521     (my $base_format = $format) =~ s/(-full|-uris)$//o;
 522     my $u2uri = OpenILS::Utils::TagURI->new($uri);
 523     if ($u2uri->version > 1) {
 524         if ($format) {
 525             return unapi2($apache, $u2uri, $format);
 526         } else {
 527             return unapi2_formats($apache, $u2uri);
 528         }
 529     }
 530
 531     my $host = $cgi->virtual_host || $cgi->server_name;
 532
 533     my $skin = $cgi->param('skin') || 'default';
 534     my $locale = $cgi->param('locale') || 'en-US';
 535
 536     # Enable localized results of copy status, etc
 537     $supercat->session_locale($locale);
 538
 539     my $flesh_feed = parse_feed_type($format);
 540     ($base_format = $format) =~ s/(-full|-uris)$//o;
 541     my ($id,$type,$command,$lib,$depth,$paging) = ('','record','');
 542     my $body = "Content-type: application/xml; charset=utf-8\n\n";
 543
 544     if ($uri =~ m{^tag:[^:]+:([^\/]+)/([^\/[]+)(?:\[([0-9,]+)\])?(?:/(.+))?}o) {
 545         $id = $2;
 546         $paging = $3;
 547         ($lib,$depth) = split('/', $4);
 548         $type = 'metarecord' if ($1 =~ /^m/o);
 549         $type = 'authority' if ($1 =~ /^authority/o);
 550     }
 551
 552     if (!$format) {
 553         if ($uri =~ m{^tag:[^:]+:([^\/]+)/([^\/[]+)(?:\[([0-9,]+)\])?(?:/(.+))?}o) {
 554
 555             my $list = $supercat
 556                 ->request("open-ils.supercat.$type.formats")
 557                 ->gather(1);
 558
 559             if ($type eq 'record' or $type eq 'isbn') {
 560                 $body .= <<"                FORMATS";
 561 <formats id='$uri'>
 562     <format name='opac' type='text/html'/>
 563     <format name='html' type='text/html'/>
 564     <format name='htmlholdings' type='text/html'/>
 565     <format name='holdings_xml' type='application/xml'/>
 566     <format name='holdings_xml-full' type='application/xml'/>
 567     <format name='html-full' type='text/html'/>
 568     <format name='htmlholdings-full' type='text/html'/>
 569     <format name='marctxt' type='text/plain'/>
 570     <format name='ris' type='text/plain'/>
 571                 FORMATS
 572             } elsif ($type eq 'metarecord') {
 573                 $body .= <<"                FORMATS";
 574                 <formats id='$uri'>
 575                     <format name='opac' type='text/html'/>
 576                 FORMATS
 577             } else {
 578                 $body .= <<"                FORMATS";
 579                 <formats id='$uri'>
 580                 FORMATS
 581             }
 582
 583             for my $h (@$list) {
 584                 my ($type) = keys %$h;
 585                 $body .= unapi_format($h, $type);
 586
 587                 if (OpenILS::WWW::SuperCat::Feed->exists($type)) {
 588                     $body .= unapi_format($h, "$type-full");
 589                     $body .= unapi_format($h, "$type-uris");
 590                 }
 591             }
 592
 593             $body .= "</formats>\n";
 594
 595         } else {
 596             my $list = $supercat
 597                 ->request("open-ils.supercat.$type.formats")
 598                 ->gather(1);
 599
 600             push @$list,
 601                 @{ $supercat
 602                     ->request("open-ils.supercat.metarecord.formats")
 603                     ->gather(1);
 604                 };
 605
 606             my %hash = map { ( (keys %$_)[0] => (values %$_)[0] ) } @$list;
 607             $list = [ map { { $_ => $hash{$_} } } sort keys %hash ];
 608
 609             $body .= <<"            FORMATS";
 610 <formats>
 611     <format name='opac' type='text/html'/>
 612     <format name='html' type='text/html'/>
 613     <format name='htmlholdings' type='text/html'/>
 614     <format name='holdings_xml' type='application/xml'/>
 615     <format name='holdings_xml-full' type='application/xml'/>
 616     <format name='html-full' type='text/html'/>
 617     <format name='htmlholdings-full' type='text/html'/>
 618     <format name='marctxt' type='text/plain'/>
 619     <format name='ris' type='text/plain'/>
 620             FORMATS
 621
 622
 623             for my $h (@$list) {
 624                 my ($type) = keys %$h;
 625                 $body .= "\t" . unapi_format($h, $type);
 626
 627                 if (OpenILS::WWW::SuperCat::Feed->exists($type)) {
 628                     $body .= "\t" . unapi_format($h, "$type-full");
 629                     $body .= "\t" . unapi_format($h, "$type-uris");
 630                 }
 631             }
 632
 633             $body .= "</formats>\n";
 634
 635         }
 636         print $body;
 637         return Apache2::Const::OK;
 638     }
 639
 640     my $scheme;
 641     if ($uri =~ m{^tag:[^:]+:([^\/]+)/([^\/[]+)(?:\[([0-9,]+)\])?(?:/(.+))?}o) {
 642         $scheme = $1;
 643         $id = $2;
 644         $paging = $3;
 645         ($lib,$depth) = split('/', $4);
 646         $type = 'record';
 647         $type = 'metarecord' if ($scheme =~ /^metabib/o);
 648         $type = 'isbn' if ($scheme =~ /^isbn/o);
 649         $type = 'acp' if ($scheme =~ /^asset-copy/o);
 650         $type = 'acn' if ($scheme =~ /^asset-call_number/o);
 651         $type = 'auri' if ($scheme =~ /^asset-uri/o);
 652         $type = 'authority' if ($scheme =~ /^authority/o);
 653         $command = 'retrieve';
 654         $command = 'browse' if (grep { $scheme eq $_ } qw/call_number title author subject topic authority.title authority.author authority.subject authority.topic series item-age/);
 655         $command = 'browse' if ($scheme =~ /^authority/);
 656     }
 657
 658     if ($paging) {
 659         $paging = [split ',', $paging];
 660     } else {
 661         $paging = [];
 662     }
 663
 664     if (!$lib || $lib eq '-') {
 665          $lib = $actor->request(
 666             'open-ils.actor.org_unit_list.search' => parent_ou => undef
 667         )->gather(1)->[0]->shortname;
 668     }
 669
 670     my ($lib_object,$lib_id,$ou_types,$lib_depth);
 671     if ($type ne 'acn' && $type ne 'acp' && $type ne 'auri') {
 672         $lib_object = $actor->request(
 673             'open-ils.actor.org_unit_list.search' => shortname => $lib
 674         )->gather(1)->[0];
 675         $lib_id = $lib_object->id;
 676
 677         $ou_types = $actor->request( 'open-ils.actor.org_types.retrieve' )->gather(1);
 678         $lib_depth = defined($depth) ? $depth : (grep { $_->id == $lib_object->ou_type } @$ou_types)[0]->depth;
 679     }
 680
 681     if ($command eq 'browse') {
 682         print "Location: $root/browse/$base_format/$scheme/$lib/$id\n\n";
 683         return 302;
 684     }
 685
 686     if ($type eq 'isbn') {
 687         my $rec = $supercat->request('open-ils.supercat.isbn.object.retrieve',$id)->gather(1);
 688         if (!@$rec) {
 689             # Escape user input before display
 690             $command = CGI::escapeHTML($command);
 691             $id = CGI::escapeHTML($id);
 692             $type = CGI::escapeHTML($type);
 693             $format = CGI::escapeHTML(decode_utf8($format));
 694
 695             print "Content-type: text/html; charset=utf-8\n\n";
 696             $apache->custom_response( 404, <<"            HTML");
 697             <html>
 698                 <head>
 699                     <title>Type [$type] with id [$id] not found!</title>
 700                 </head>
 701                 <body>
 702                     <br/>
 703                     <center>Sorry, we couldn't $command a $type with the id of $id in format $format.</center>
 704                 </body>
 705             </html>
 706             HTML
 707             return 404;
 708         }
 709         $id = $rec->[0]->id;
 710         $type = 'record';
 711     }
 712
 713     if ( !grep
 714            { (keys(%$_))[0] eq $base_format }
 715            @{ $supercat->request("open-ils.supercat.$type.formats")->gather(1) }
 716          and !grep
 717            { $_ eq $base_format }
 718            qw/opac html htmlholdings marctxt ris holdings_xml/
 719     ) {
 720         # Escape user input before display
 721         $format = CGI::escapeHTML($format);
 722         $type = CGI::escapeHTML($type);
 723
 724         print "Content-type: text/html; charset=utf-8\n\n";
 725         $apache->custom_response( 406, <<"        HTML");
 726         <html>
 727             <head>
 728                 <title>Invalid format [$format] for type [$type]!</title>
 729             </head>
 730             <body>
 731                 <br/>
 732                 <center>Sorry, format $format is not valid for type $type.</center>
 733             </body>
 734         </html>
 735         HTML
 736         return 406;
 737     }
 738
 739     if ($format eq 'opac') {
 740         print "Location: $root/../../$locale/skin/$skin/xml/rresult.xml?m=$id&l=$lib_id&d=$lib_depth\n\n"
 741             if ($type eq 'metarecord');
 742         print "Location: /eg/opac/record/$id?locg=$lib_id&depth=$lib_depth\n\n"
 743             if ($type eq 'record');
 744         return 302;
 745     } elsif (OpenILS::WWW::SuperCat::Feed->exists($base_format) && ($type ne 'acn' && $type ne 'acp' && $type ne 'auri')) {
 746         my $feed = create_record_feed(
 747             $type,
 748             $format => [ $id ],
 749             $base,
 750             $lib,
 751             $depth,
 752             $flesh_feed,
 753             $paging
 754         );
 755
 756         if (!$feed->count) {
 757             # Escape user input before display
 758             $command = CGI::escapeHTML($command);
 759             $id = CGI::escapeHTML($id);
 760             $type = CGI::escapeHTML($type);
 761             $format = CGI::escapeHTML(decode_utf8($format));
 762
 763             print "Content-type: text/html; charset=utf-8\n\n";
 764             $apache->custom_response( 404, <<"            HTML");
 765             <html>
 766                 <head>
 767                     <title>Type [$type] with id [$id] not found!</title>
 768                 </head>
 769                 <body>
 770                     <br/>
 771                     <center>Sorry, we couldn't $command a $type with the id of $id in format $format.</center>
 772                 </body>
 773             </html>
 774             HTML
 775             return 404;
 776         }
 777
 778         $feed->root($root);
 779         $feed->creator($host);
 780         $feed->update_ts();
 781         $feed->link( unapi => $base) if ($flesh_feed);
 782
 783         print "Content-type: ". $feed->type ."; charset=utf-8\n";
 784
 785         print $_ for extra_headers_per_type_to_string($type);
 786
 787         print "\n", $feed->toString, "\n";
 788
 789         return Apache2::Const::OK;
 790     }
 791
 792     my $method = "open-ils.supercat.$type.$base_format.$command";
 793     my @params = ($id);
 794     push @params, $lib, $lib_depth, $flesh_feed, $paging if ($base_format eq 'holdings_xml');
 795
 796     # for acn, acp, etc, the "lib" pathinfo position isn't useful.
 797     # however, we can have it carry extra options like no_record! (comma separated)
 798     push @params, { map { ( $_ => 1 ) } split(',', $lib) } if ( grep { $type eq $_} qw/acn acp auri/);
 799
 800     my $req = $supercat->request($method,@params);
 801     my $data = $req->gather();
 802
 803     if ($req->failed || !$data) {
 804         # Escape user input before display
 805         $command = CGI::escapeHTML($command);
 806         $id = CGI::escapeHTML($id);
 807         $type = CGI::escapeHTML($type);
 808         $format = CGI::escapeHTML(decode_utf8($format));
 809
 810         print "Content-type: text/html; charset=utf-8\n\n";
 811         $apache->custom_response( 404, <<"        HTML");
 812         <html>
 813             <head>
 814                 <title>$type $id not found!</title>
 815             </head>
 816             <body>
 817                 <br/>
 818                 <center>Sorry, we couldn't $command a $type with the id of $id in format $format.</center>
 819             </body>
 820         </html>
 821         HTML
 822         return 404;
 823     }
 824
 825     print "Content-type: application/xml; charset=utf-8\n\n";
 826
 827     # holdings_xml format comes back to us without an XML declaration
 828     # and without being entityized; fix that here
 829     if ($base_format eq 'holdings_xml') {
 830         print "<?xml version='1.0' encoding='UTF-8' ?>\n";
 831         print $U->entityize($data);
 832
 833         while (my $c = $req->recv) {
 834             print $U->entityize($c->content);
 835         }
 836     } else {
 837         print $data;
 838     }
 839
 840     return Apache2::Const::OK;
 841 }
 842
 843 sub supercat {
 844
 845     my $apache = shift;
 846     return Apache2::Const::DECLINED if (-e $apache->filename);
 847
 848     check_child_init();
 849
 850     my $cgi = new CGI;
 851
 852     my $add_path = 0;
 853     if ( $cgi->server_software !~ m|^Apache/2.2| ) {
 854         my $rel_name = $cgi->url(-relative=>1);
 855         $add_path = 1 if ($cgi->url(-path_info=>1) !~ /$rel_name$/);
 856     }
 857
 858     my $url = $cgi->url(-path_info=>$add_path);
 859     my $root = (split 'supercat', $url)[0];
 860     my $base = (split 'supercat', $url)[0] . 'supercat';
 861     my $unapi = (split 'supercat', $url)[0] . 'unapi';
 862
 863     my $host = $cgi->virtual_host || $cgi->server_name;
 864
 865     my $path = $cgi->path_info;
 866     my ($id,$type,$format,$command) = reverse split '/', $path;
 867     my $flesh_feed = parse_feed_type($format);
 868     (my $base_format = $format) =~ s/(-full|-uris)$//o;
 869
 870     my $skin = $cgi->param('skin') || 'default';
 871     my $locale = $cgi->param('locale') || 'en-US';
 872
 873     # Enable localized results of copy status, etc
 874     $supercat->session_locale($locale);
 875
 876     if ( $path =~ m{^/formats(?:/([^\/]+))?$}o ) {
 877         print "Content-type: application/xml; charset=utf-8\n";
 878         if ($1) {
 879             my $list = $supercat
 880                 ->request("open-ils.supercat.$1.formats")
 881                 ->gather(1);
 882
 883             print "\n";
 884
 885             print "<formats>
 886                    <format>
 887                      <name>opac</name>
 888                      <type>text/html</type>
 889                    </format>";
 890
 891             if ($1 eq 'record' or $1 eq 'isbn') {
 892                 print "<format>
 893                      <name>htmlholdings</name>
 894                      <type>text/html</type>
 895                    </format>
 896                    <format>
 897                      <name>html</name>
 898                      <type>text/html</type>
 899                    </format>
 900                    <format>
 901                      <name>htmlholdings-full</name>
 902                      <type>text/html</type>
 903                    </format>
 904                    <format>
 905                      <name>html-full</name>
 906                      <type>text/html</type>
 907                    </format>
 908                    <format>
 909                      <name>marctxt</name>
 910                      <type>text/plain</type>
 911                    </format>
 912                    <format>
 913                      <name>ris</name>
 914                      <type>text/plain</type>
 915                    </format>";
 916             }
 917
 918             for my $h (@$list) {
 919                 my ($type) = keys %$h;
 920                 print supercat_format($h, $type);
 921
 922                 if (OpenILS::WWW::SuperCat::Feed->exists($type)) {
 923                     print supercat_format($h, "$type-full");
 924                     print supercat_format($h, "$type-uris");
 925                 }
 926
 927             }
 928
 929             print "</formats>\n";
 930
 931             return Apache2::Const::OK;
 932         }
 933
 934         my $list = $supercat
 935             ->request("open-ils.supercat.record.formats")
 936             ->gather(1);
 937
 938         push @$list,
 939             @{ $supercat
 940                 ->request("open-ils.supercat.metarecord.formats")
 941                 ->gather(1);
 942             };
 943
 944         my %hash = map { ( (keys %$_)[0] => (values %$_)[0] ) } @$list;
 945         $list = [ map { { $_ => $hash{$_} } } sort keys %hash ];
 946
 947         print "\n<formats>
 948                <format>
 949                  <name>opac</name>
 950                  <type>text/html</type>
 951                </format>
 952                <format>
 953                  <name>htmlholdings</name>
 954                  <type>text/html</type>
 955                </format>
 956                <format>
 957                  <name>html</name>
 958                  <type>text/html</type>
 959                </format>
 960                <format>
 961                  <name>htmlholdings-full</name>
 962                  <type>text/html</type>
 963                </format>
 964                <format>
 965                  <name>html-full</name>
 966                  <type>text/html</type>
 967                </format>
 968                <format>
 969                  <name>marctxt</name>
 970                  <type>text/plain</type>
 971                </format>
 972                <format>
 973                  <name>ris</name>
 974                  <type>text/plain</type>
 975                </format>";
 976
 977         for my $h (@$list) {
 978             my ($type) = keys %$h;
 979             print supercat_format($h, $type);
 980
 981             if (OpenILS::WWW::SuperCat::Feed->exists($type)) {
 982                 print supercat_format($h, "$type-full");
 983                 print supercat_format($h, "$type-uris");
 984             }
 985
 986         }
 987
 988         print "</formats>\n";
 989
 990
 991         return Apache2::Const::OK;
 992     }
 993
 994     if ($format eq 'opac') {
 995         print "Location: $root/../../$locale/skin/$skin/xml/rresult.xml?m=$id\n\n"
 996             if ($type eq 'metarecord');
 997         print "Location: /eg/opac/record/$id\n\n"
 998             if ($type eq 'record');
 999         return 302;
1000
1001     } elsif ($base_format eq 'marc21') {
1002
1003         my $ret = 200;
1004         try {
1005             my $bib = $supercat->request( "open-ils.supercat.record.object.retrieve", $id )->gather(1)->[0];
1006
1007             print "Content-type: application/octet-stream\n";
1008             print $_ for extra_headers_per_type_to_string($base_format);
1009             print "\n" . MARC::Record->new_from_xml( $bib->marc, 'UTF-8', 'USMARC' )->as_usmarc;
1010
1011         } otherwise {
1012             warn shift();
1013
1014             # Escape user input before display
1015             $id = CGI::escapeHTML($id);
1016
1017             print "Content-type: text/html; charset=utf-8\n\n";
1018             $apache->custom_response( 404, <<"            HTML");
1019             <html>
1020                 <head>
1021                     <title>ERROR</title>
1022                 </head>
1023                 <body>
1024                     <br/>
1025                     <center>Couldn't fetch $id as MARC21.</center>
1026                 </body>
1027             </html>
1028             HTML
1029             $ret = 404;
1030         };
1031
1032         return Apache2::Const::OK;
1033
1034     } elsif (OpenILS::WWW::SuperCat::Feed->exists($base_format)) {
1035         my $feed = create_record_feed(
1036             $type,
1037             $format => [ $id ],
1038             undef, undef, undef,
1039             $flesh_feed
1040         );
1041
1042         $feed->root($root);
1043         $feed->creator($host);
1044
1045         $feed->update_ts();
1046
1047         $feed->link( unapi => $base) if ($flesh_feed);
1048
1049         print "Content-type: ". $feed->type ."; charset=utf-8\n";
1050
1051         print $_ for extra_headers_per_type_to_string($type);
1052
1053         print "\n", $feed->toString, "\n";
1054
1055         return Apache2::Const::OK;
1056     }
1057
1058     my $req = $supercat->request("open-ils.supercat.$type.$format.$command",$id);
1059     $req->wait_complete;
1060
1061     if ($req->failed) {
1062         # Escape user input before display
1063         $command = CGI::escapeHTML($command);
1064         $id = CGI::escapeHTML($id);
1065         $type = CGI::escapeHTML($type);
1066         $format = CGI::escapeHTML(decode_utf8($format));
1067
1068         print "Content-type: text/html; charset=utf-8\n\n";
1069         $apache->custom_response( 404, <<"        HTML");
1070         <html>
1071             <head>
1072                 <title>$type $id not found!</title>
1073             </head>
1074             <body>
1075                 <br/>
1076                 <center>Sorry, we couldn't $command a $type with the id of $id in format $format.</center>
1077             </body>
1078         </html>
1079         HTML
1080         return 404;
1081     }
1082
1083     print "Content-type: application/xml; charset=utf-8\n\n";
1084     print $U->entityize( $parser->parse_string( $req->gather(1) )->documentElement->toString );
1085
1086     return Apache2::Const::OK;
1087 }
1088
1089
1090 sub bookbag_feed {
1091     my $apache = shift;
1092     return Apache2::Const::DECLINED if (-e $apache->filename);
1093
1094     check_child_init();
1095
1096     my $cgi = new CGI;
1097
1098     my $year = (gmtime())[5] + 1900;
1099     my $host = $cgi->virtual_host || $cgi->server_name;
1100
1101     my $add_path = 0;
1102     if ( $cgi->server_software !~ m|^Apache/2.2| ) {
1103         my $rel_name = $cgi->url(-relative=>1);
1104         $add_path = 1 if ($cgi->url(-path_info=>1) !~ /$rel_name$/);
1105     }
1106
1107     my $url = $cgi->url(-path_info=>$add_path);
1108     my $root = (split 'feed', $url)[0] . '/';
1109     my $base = (split 'bookbag', $url)[0] . '/bookbag';
1110     my $unapi = (split 'feed', $url)[0] . '/unapi';
1111
1112     my $skin = $cgi->param('skin') || 'default';
1113     my $locale = $cgi->param('locale') || 'en-US';
1114     my $org = $cgi->param('searchOrg');
1115
1116     # Enable localized results of copy status, etc
1117     $supercat->session_locale($locale);
1118
1119     my $org_unit = get_ou($org);
1120     my $scope = "l=" . $org_unit->[0]->id . "&";
1121
1122     $root =~ s{(?<!http:)//}{//}go;
1123     $base =~ s{(?<!http:)//}{//}go;
1124     $unapi =~ s{(?<!http:)//}{//}go;
1125
1126     my $path = $cgi->path_info;
1127     #warn "URL breakdown: $url -> $root -> $base -> $path -> $unapi";
1128
1129     my ($id,$type) = reverse split '/', $path;
1130     my $flesh_feed = parse_feed_type($type);
1131
1132     my $bucket = $actor->request("open-ils.actor.container.public.flesh", 'biblio', $id)->gather(1);
1133     return Apache2::Const::NOT_FOUND unless($bucket);
1134
1135     my $bucket_tag = "tag:$host,$year:record_bucket/$id";
1136     if (lc($type) eq 'opac') {
1137         print "Location: /eg/opac/results?bookbag=$id\n\n";
1138         return 302;
1139     }
1140
1141     # last created first
1142     my @sorted_bucket_items = sort { $b->create_time cmp $a->create_time } @{ $bucket->items };
1143
1144     my $feed = create_record_feed(
1145         'record',
1146         $type,
1147         [ map { $_->target_biblio_record_entry } @sorted_bucket_items ],
1148         $unapi,
1149         $org_unit->[0]->shortname,
1150         undef,
1151         $flesh_feed
1152     );
1153     $feed->root($root);
1154     $feed->id($bucket_tag);
1155
1156     $feed->title($bucket->name);
1157     $feed->description($bucket->description || ("Items in Book Bag [".$bucket->name."]"));
1158     $feed->creator($host);
1159     $feed->update_ts();
1160
1161     $feed->link(alternate => $base . "/rss2-full/$id" => 'application/rss+xml');
1162     $feed->link(atom => $base . "/atom-full/$id" => 'application/atom+xml');
1163     $feed->link(opac => $base . "/opac/$id" => 'text/html');
1164     $feed->link(OPAC => $base . "/opac/$id" => 'text/html');
1165     $feed->link(html => $base . "/html-full/$id" => 'text/html');
1166     $feed->link(unapi => $unapi);
1167
1168     print "Content-type: ". $feed->type ."; charset=utf-8\n\n";
1169     print $feed->toString . "\n";
1170
1171     return Apache2::Const::OK;
1172 }
1173
1174 sub changes_feed {
1175     my $apache = shift;
1176     return Apache2::Const::DECLINED if (-e $apache->filename);
1177
1178     check_child_init();
1179
1180     my $cgi = new CGI;
1181
1182     my $year = (gmtime())[5] + 1900;
1183     my $host = $cgi->virtual_host || $cgi->server_name;
1184
1185     my $add_path = 0;
1186     if ( $cgi->server_software !~ m|^Apache/2.2| ) {
1187         my $rel_name = $cgi->url(-relative=>1);
1188         $add_path = 1 if ($cgi->url(-path_info=>1) !~ /$rel_name$/);
1189     }
1190
1191     my $url = $cgi->url(-path_info=>$add_path);
1192     my $root = (split 'feed', $url)[0];
1193     my $base = (split 'freshmeat', $url)[0] . '/freshmeat';
1194     my $unapi = (split 'feed', $url)[0] . 'unapi';
1195
1196     my $skin = $cgi->param('skin') || 'default';
1197     my $locale = $cgi->param('locale') || 'en-US';
1198     my $org = $cgi->param('searchOrg');
1199
1200     # Enable localized results of copy status, etc
1201     $supercat->session_locale($locale);
1202
1203     my $org_unit = get_ou($org);
1204     my $scope = "l=" . $org_unit->[0]->id . "&";
1205
1206     my $path = $cgi->path_info;
1207     #warn "URL breakdown: $url ($rel_name) -> $root -> $base -> $path -> $unapi";
1208
1209     $path =~ s/^\/(?:feed\/)?freshmeat\///og;
1210
1211     my ($type,$rtype,$axis,$limit,$date) = split '/', $path;
1212     my $flesh_feed = parse_feed_type($type);
1213
1214     $limit ||= 10;
1215     $limit = 10 if $limit !~ /^\d+$/;
1216
1217     my $list = $supercat->request("open-ils.supercat.$rtype.record.$axis.recent", $date, $limit)->gather(1);
1218
1219     if (lc($type) eq 'opac') {
1220         print "Location: /eg/opac/results?query=record_list(".join(',', @$list ).")+sort(edit_date)+\%23descending&locg=".$org_unit->[0]->id . "\n\n";
1221         return 302;
1222     }
1223
1224     my $search = 'record';
1225     if ($rtype eq 'authority') {
1226         $search = 'authority';
1227     }
1228     my $feed = create_record_feed( $search, $type, $list, $unapi, $org_unit->[0]->shortname, undef, $flesh_feed);
1229     $feed->root($root);
1230
1231     if ($date) {
1232         $feed->title("Up to $limit recent $rtype ${axis}s from $date forward");
1233     } else {
1234         $feed->title("$limit most recent $rtype ${axis}s");
1235     }
1236
1237     $feed->creator($host);
1238     $feed->update_ts();
1239
1240     $feed->link(alternate => $base . "/rss2-full/$rtype/$axis/$limit/$date" => 'application/rss+xml');
1241     $feed->link(atom => $base . "/atom-full/$rtype/$axis/$limit/$date" => 'application/atom+xml');
1242     $feed->link(html => $base . "/html-full/$rtype/$axis/$limit/$date" => 'text/html');
1243     $feed->link(unapi => $unapi);
1244
1245     $feed->link(
1246         OPAC =>
1247         "http://$host/eg/opac/results?query=record_list(".join(',', @$list ).")\%20sort(edit_date)#descending&locg=".$org_unit->[0]->id,
1248         'text/html'
1249     );
1250
1251
1252     print "Content-type: ". $feed->type ."; charset=utf-8\n";
1253
1254     print $_ for extra_headers_per_type_to_string($type);
1255
1256     print "\n", $feed->toString, "\n";
1257
1258     return Apache2::Const::OK;
1259 }
1260
1261 sub opensearch_osd {
1262     my $version = shift;
1263     my $lib = shift;
1264     my $class = shift;
1265     my $base = shift;
1266     my $host = shift;
1267
1268     if ($version eq '1.0') {
1269         print <<OSD;
1270 Content-type: application/opensearchdescription+xml; charset=utf-8
1271
1272 <?xml version="1.0" encoding="UTF-8"?>
1273 <OpenSearchDescription xmlns="http://a9.com/-/spec/opensearchdescription/1.0/">
1274   <Url>$base/1.0/$lib/-/$class/?searchTerms={searchTerms}&amp;startPage={startPage}&amp;startIndex={startIndex}&amp;count={count}</Url>
1275   <Format>http://a9.com/-/spec/opensearchrss/1.0/</Format>
1276   <ShortName>$lib</ShortName>
1277   <LongName>Search $lib</LongName>
1278   <Description>Search the $lib OPAC by $class.</Description>
1279   <Tags>$lib book library</Tags>
1280   <SampleSearch>harry+potter</SampleSearch>
1281   <Developer>Mike Rylander for GPLS/PINES</Developer>
1282   <Contact>feedback\@open-ils.org</Contact>
1283   <SyndicationRight>open</SyndicationRight>
1284   <AdultContent>false</AdultContent>
1285 </OpenSearchDescription>
1286 OSD
1287     } else {
1288         print <<OSD;
1289 Content-type: application/opensearchdescription+xml; charset=utf-8
1290
1291 <?xml version="1.0" encoding="UTF-8"?>
1292 <OpenSearchDescription xmlns="http://a9.com/-/spec/opensearch/1.1/">
1293   <ShortName>$lib</ShortName>
1294   <Description>Search the $lib OPAC by $class.</Description>
1295   <Tags>$lib book library</Tags>
1296   <Url type="application/rss+xml"
1297        template="$base/1.1/$lib/rss2-full/$class/?searchTerms={searchTerms}&amp;startPage={startPage?}&amp;startIndex={startIndex?}&amp;count={count?}&amp;searchLang={language?}"/>
1298   <Url type="application/atom+xml"
1299        template="$base/1.1/$lib/atom-full/$class/?searchTerms={searchTerms}&amp;startPage={startPage?}&amp;startIndex={startIndex?}&amp;count={count?}&amp;searchLang={language?}"/>
1300   <Url type="application/x-mods3+xml"
1301        template="$base/1.1/$lib/mods3/$class/?searchTerms={searchTerms}&amp;startPage={startPage?}&amp;startIndex={startIndex?}&amp;count={count?}&amp;searchLang={language?}"/>
1302   <Url type="application/x-mods+xml"
1303        template="$base/1.1/$lib/mods/$class/?searchTerms={searchTerms}&amp;startPage={startPage?}&amp;startIndex={startIndex?}&amp;count={count?}&amp;searchLang={language?}"/>
1304   <Url type="application/octet-stream"
1305        template="$base/1.1/$lib/marc21/$class/?searchTerms={searchTerms}&amp;startPage={startPage?}&amp;startIndex={startIndex?}&amp;count={count?}&amp;searchLang={language?}"/>
1306   <Url type="application/x-marcxml+xml"
1307        template="$base/1.1/$lib/marcxml/$class/?searchTerms={searchTerms}&amp;startPage={startPage?}&amp;startIndex={startIndex?}&amp;count={count?}&amp;searchLang={language?}"/>
1308   <Url type="text/html"
1309        template="https://$host/eg/opac/results?locg=$lib;query={searchTerms};page={startPage?};startIndex={startIndex?};count={count?};searchLang={language?}"/>
1310   <LongName>Search $lib</LongName>
1311   <Query role="example" searchTerms="harry+potter" />
1312   <Developer>Mike Rylander for GPLS/PINES</Developer>
1313   <Contact>feedback\@open-ils.org</Contact>
1314   <SyndicationRight>open</SyndicationRight>
1315   <AdultContent>false</AdultContent>
1316   <Language>en-US</Language>
1317   <OutputEncoding>UTF-8</OutputEncoding>
1318   <InputEncoding>UTF-8</InputEncoding>
1319 </OpenSearchDescription>
1320 OSD
1321     }
1322
1323     return Apache2::Const::OK;
1324 }
1325
1326 sub opensearch_feed {
1327     my $apache = shift;
1328     return Apache2::Const::DECLINED if (-e $apache->filename);
1329
1330     check_child_init();
1331
1332     my $cgi = new CGI;
1333     my $year = (gmtime())[5] + 1900;
1334
1335     my $host = $cgi->virtual_host || $cgi->server_name;
1336
1337     my $add_path = 0;
1338     if ( $cgi->server_software !~ m|^Apache/2.2| ) {
1339         my $rel_name = $cgi->url(-relative=>1);
1340         $add_path = 1 if ($cgi->url(-path_info=>1) !~ /$rel_name$/);
1341     }
1342
1343     my $url = $cgi->url(-path_info=>$add_path);
1344     my $root = (split 'opensearch', $url)[0];
1345     my $base = (split 'opensearch', $url)[0] . 'opensearch';
1346     my $unapi = (split 'opensearch', $url)[0] . 'unapi';
1347
1348     my $path = $cgi->path_info;
1349     #warn "URL breakdown: $url ($rel_name) -> $root -> $base -> $path -> $unapi";
1350
1351     if ($path =~ m{^/?(1\.\d{1})/(?:([^/]+)/)?([^/]+)/osd.xml}o) {
1352
1353         my $version = $1;
1354         my $lib = uc($2);
1355         my $class = $3;
1356
1357         if (!$lib || $lib eq '-') {
1358              $lib = $actor->request(
1359                 'open-ils.actor.org_unit_list.search' => parent_ou => undef
1360             )->gather(1)->[0]->shortname;
1361         }
1362
1363         if ($class eq '-') {
1364             $class = 'keyword';
1365         }
1366
1367         return opensearch_osd($version, $lib, $class, $base, $host);
1368     }
1369
1370
1371     my $page = $cgi->param('startPage') || 1;
1372     my $offset = $cgi->param('startIndex') || 1;
1373     my $limit = $cgi->param('count') || 10;
1374
1375     $page = 1 if ($page !~ /^\d+$/);
1376     $offset = 1 if ($offset !~ /^\d+$/);
1377     $limit = 10 if ($limit !~ /^\d+$/); $limit = 25 if ($limit > 25);
1378
1379     if ($page > 1) {
1380         $offset = ($page - 1) * $limit;
1381     } else {
1382         $offset -= 1;
1383     }
1384
1385     my ($version,$org,$type,$class,$terms,$sort,$sortdir,$lang) = ('','','','','','','','');
1386     (undef,$version,$org,$type,$class,$terms,$sort,$sortdir,$lang) = split '/', $path;
1387
1388     $lang = $cgi->param('searchLang') if $cgi->param('searchLang');
1389     $lang = '' if ($lang eq '*');
1390
1391     $sort = $cgi->param('searchSort') if $cgi->param('searchSort');
1392     $sort ||= '';
1393     $sortdir = $cgi->param('searchSortDir') if $cgi->param('searchSortDir');
1394     $sortdir ||= '';
1395
1396     $terms .= " " if ($terms && $cgi->param('searchTerms'));
1397     $terms .= $cgi->param('searchTerms') if $cgi->param('searchTerms');
1398
1399     $class = $cgi->param('searchClass') if $cgi->param('searchClass');
1400     $class ||= '-';
1401
1402     $type = $cgi->param('responseType') if $cgi->param('responseType');
1403     $type ||= '-';
1404
1405     $org = $cgi->param('searchOrg') if $cgi->param('searchOrg');
1406     $org ||= '-';
1407
1408
1409     my $kwt = $cgi->param('kw');
1410     my $tit = $cgi->param('ti');
1411     my $aut = $cgi->param('au');
1412     my $sut = $cgi->param('su');
1413     my $set = $cgi->param('se');
1414
1415     $terms .= " " if ($terms && $kwt);
1416     $terms .= "keyword: $kwt" if ($kwt);
1417     $terms .= " " if ($terms && $tit);
1418     $terms .= "title: $tit" if ($tit);
1419     $terms .= " " if ($terms && $aut);
1420     $terms .= "author: $aut" if ($aut);
1421     $terms .= " " if ($terms && $sut);
1422     $terms .= "subject: $sut" if ($sut);
1423     $terms .= " " if ($terms && $set);
1424     $terms .= "series: $set" if ($set);
1425
1426     if ($version eq '1.0') {
1427         $type = 'rss2';
1428     } elsif ($type eq '-') {
1429         $type = 'atom';
1430     }
1431     my $flesh_feed = parse_feed_type($type);
1432
1433     $terms = decode_utf8($terms);
1434     $lang = 'eng' if ($lang eq 'en-US');
1435
1436     $log->debug("OpenSearch terms: $terms");
1437
1438     my $org_unit = get_ou($org);
1439
1440     my $safe_terms = $terms;
1441
1442     # XXX Apostrophes used to break search, but no longer do.  The following
1443     # XXX line breaks phrase searching in OpenSearch, and should be removed.
1444     $safe_terms =~ s{'}{ }go;
1445
1446     my $query_terms = 'site('.$org_unit->[0]->shortname.") $safe_terms";
1447     $query_terms = "sort($sort) $query_terms" if ($sort);
1448     $query_terms = "language($lang) $query_terms" if ($lang);
1449     $query_terms = "#$sortdir $query_terms" if ($sortdir);
1450
1451     my $recs = $search->request(
1452         'open-ils.search.biblio.multiclass.query' => {
1453             offset        => $offset,
1454             limit        => $limit
1455         } => $query_terms => 1
1456     )->gather(1);
1457
1458     $log->debug("Hits for [$terms]: $recs->{count}");
1459
1460     my $feed = create_record_feed(
1461         'record',
1462         $type,
1463         [ map { $_->[0] } @{$recs->{ids}} ],
1464         $unapi,
1465         $org,
1466         undef,
1467         $flesh_feed
1468     );
1469
1470     $log->debug("Feed created...");
1471
1472     $feed->root($root);
1473     $feed->lib($org);
1474     $feed->search($safe_terms);
1475     $feed->class($class);
1476
1477     $feed->title("Search results for [$terms] at ".$org_unit->[0]->name);
1478
1479     $feed->creator($host);
1480     $feed->update_ts();
1481
1482     $feed->_create_node(
1483         $feed->{item_xpath},
1484         'http://a9.com/-/spec/opensearch/1.1/',
1485         'totalResults',
1486         $recs->{count},
1487     );
1488
1489     $feed->_create_node(
1490         $feed->{item_xpath},
1491         'http://a9.com/-/spec/opensearch/1.1/',
1492         'startIndex',
1493         $offset + 1,
1494     );
1495
1496     $feed->_create_node(
1497         $feed->{item_xpath},
1498         'http://a9.com/-/spec/opensearch/1.1/',
1499         'itemsPerPage',
1500         $limit,
1501     );
1502
1503     $log->debug("...basic feed data added...");
1504
1505     $feed->link(
1506         next =>
1507         $base . "/$version/$org/$type/$class?searchTerms=$terms&searchSort=$sort&searchSortDir=$sortdir&searchLang=$lang&startIndex=" . int($offset + $limit + 1) . "&count=" . $limit =>
1508         'application/opensearch+xml'
1509     ) if ($offset + $limit < $recs->{count});
1510
1511     $feed->link(
1512         previous =>
1513         $base . "/$version/$org/$type/$class?searchTerms=$terms&searchSort=$sort&searchSortDir=$sortdir&searchLang=$lang&startIndex=" . int(($offset - $limit) + 1) . "&count=" . $limit =>
1514         'application/opensearch+xml'
1515     ) if ($offset);
1516
1517     $feed->link(
1518         self =>
1519         $base .  "/$version/$org/$type/$class?searchTerms=$terms&searchSort=$sort&searchSortDir=$sortdir&searchLang=$lang" =>
1520         'application/opensearch+xml'
1521     );
1522
1523     $feed->link(
1524         alternate =>
1525         $base .  "/$version/$org/rss2-full/$class?searchTerms=$terms&searchSort=$sort&searchSortDir=$sortdir&searchLang=$lang" =>
1526         'application/rss+xml'
1527     );
1528
1529     $feed->link(
1530         atom =>
1531         $base .  "/$version/$org/atom-full/$class?searchTerms=$terms&searchSort=$sort&searchSortDir=$sortdir&searchLang=$lang" =>
1532         'application/atom+xml'
1533     );
1534
1535     $feed->link(
1536         'html' =>
1537         $base .  "/$version/$org/html/$class?searchTerms=$terms&searchSort=$sort&searchSortDir=$sortdir&searchLang=$lang" =>
1538         'text/html'
1539     );
1540
1541     $feed->link(
1542         'html-full' =>
1543         $base .  "/$version/$org/html-full/$class?searchTerms=$terms&searchSort=$sort&searchSortDir=$sortdir&searchLang=$lang" =>
1544         'text/html'
1545     );
1546
1547     $feed->link( 'unapi-server' => $unapi);
1548
1549     $log->debug("...feed links added...");
1550
1551 #    $feed->link(
1552 #        opac =>
1553 #        $root . "../$lang/skin/default/xml/rresult.xml?rt=list&" .
1554 #            join('&', map { 'rl=' . $_->[0] } grep { ref $_ && defined $_->[0] } @{$recs->{ids}} ),
1555 #        'text/html'
1556 #    );
1557
1558     #print $cgi->header( -type => $feed->type, -charset => 'UTF-8') . entityize($feed->toString) . "\n";
1559     print $cgi->header(
1560         -type => $feed->type, -charset => 'UTF-8',
1561         extra_headers_per_type_to_cgi($type)
1562     ), $feed->toString, "\n";
1563
1564     $log->debug("...and feed returned.");
1565
1566     return Apache2::Const::OK;
1567 }
1568
1569 sub create_record_feed {
1570     my $search = shift;
1571     my $type = shift;
1572     my $records = shift;
1573     my $unapi = shift;
1574
1575     my $lib = uc(shift()) || '-';
1576     my $depth = shift;
1577     my $flesh = shift;
1578
1579     my $paging = shift;
1580
1581     my $cgi = new CGI;
1582     my $base = $cgi->url;
1583     my $host = $cgi->virtual_host || $cgi->server_name;
1584
1585     my ($year,$month,$day) = reverse( (localtime)[3,4,5] );
1586     $year += 1900;
1587     $month += 1;
1588
1589     my $tag_prefix = sprintf("tag:open-ils.org,$year-\%0.2d-\%0.2d", $month, $day);
1590
1591     my $flesh_feed = defined($flesh) ? $flesh : parse_feed_type($type);
1592
1593     $type =~ s/(-full|-uris)$//o;
1594
1595     my $feed = new OpenILS::WWW::SuperCat::Feed ($type);
1596     $feed->base($base) if ($flesh);
1597     $feed->unapi($unapi) if ($flesh);
1598
1599     $type = 'atom' if ($type eq 'html');
1600     $type = 'marcxml' if
1601         $type eq 'htmlholdings' or
1602         $type eq 'marctxt' or
1603         $type eq 'ris' or
1604         $type eq 'marc21';  # kludgy since it isn't an XML format, but needed
1605
1606     #$records = $supercat->request( "open-ils.supercat.record.object.retrieve", $records )->gather(1);
1607
1608     my $count = 0;
1609     for my $record (@$records) {
1610         next unless($record);
1611
1612         #my $rec = $record->id;
1613         my $rec = $record;
1614
1615         my $item_tag = "$tag_prefix:biblio-record_entry/$rec/$lib";
1616         $item_tag = "$tag_prefix:metabib-metarecord/$rec/$lib" if ($search eq 'metarecord');
1617         $item_tag = "$tag_prefix:isbn/$rec/$lib" if ($search eq 'isbn');
1618         $item_tag .= "/$depth" if (defined($depth));
1619
1620         $item_tag = "$tag_prefix:authority-record_entry/$rec" if ($search eq 'authority');
1621
1622         my $xml = $supercat->request(
1623             "open-ils.supercat.$search.$type.retrieve",
1624             $rec
1625         )->gather(1);
1626         next unless $xml;
1627
1628         my $node = $feed->add_item($xml);
1629         next unless $node;
1630
1631         $xml = '';
1632         if ($lib && ($type eq 'marcxml' || $type eq 'atom') && ($flesh > 0)) {
1633             my $r = $supercat->request( "open-ils.supercat.$search.holdings_xml.retrieve", $rec, $lib, $depth, $flesh_feed, $paging );
1634             while ( !$r->complete ) {
1635                 $xml .= join('', map {$_->content} $r->recv);
1636             }
1637             $xml .= join('', map {$_->content} $r->recv);
1638             $node->add_holdings($xml);
1639         }
1640
1641         $node->id($item_tag);
1642         #$node->update_ts(clean_ISO8601($record->edit_date));
1643         $node->link(alternate => $feed->unapi . "?id=$item_tag&format=opac" => 'text/html') if ($flesh > 0);
1644         $node->link(slimpac => $feed->unapi . "?id=$item_tag&format=htmlholdings-full" => 'text/html') if ($flesh > 0);
1645         $node->link(opac => $feed->unapi . "?id=$item_tag&format=opac") if ($flesh > 0);
1646         $node->link(unapi => $feed->unapi . "?id=$item_tag") if ($flesh);
1647         $node->link('unapi-id' => $item_tag) if ($flesh);
1648     }
1649
1650     return $feed;
1651 }
1652
1653 sub string_browse {
1654     my $apache = shift;
1655     return Apache2::Const::DECLINED if (-e $apache->filename);
1656
1657     check_child_init();
1658
1659     my $cgi = new CGI;
1660     my $year = (gmtime())[5] + 1900;
1661
1662     my $host = $cgi->virtual_host || $cgi->server_name;
1663
1664     my $add_path = 0;
1665     if ( $cgi->server_software !~ m|^Apache/2.2| ) {
1666         my $rel_name = $cgi->url(-relative=>1);
1667         $add_path = 1 if ($cgi->url(-path_info=>1) !~ /$rel_name$/);
1668     }
1669
1670     my $url = $cgi->url(-path_info=>$add_path);
1671     my $root = (split 'browse', $url)[0];
1672     my $base = (split 'browse', $url)[0] . 'browse';
1673     my $unapi = (split 'browse', $url)[0] . 'unapi';
1674
1675     my $path = $cgi->path_info;
1676     $path =~ s/^\///og;
1677
1678     my ($format,$axis,$site,$string,$page,$page_size,$thesauruses) = split '/', $path;
1679     #warn " >>> $format -> $axis -> $site -> $string -> $page -> $page_size -> $thesauruses";
1680
1681     return item_age_browse($apache) if ($axis eq 'item-age'); # short-circut to the item-age sub
1682
1683     my $status = [$cgi->param('status')];
1684     my $cpLoc = [$cgi->param('copyLocation')];
1685     $site ||= $cgi->param('searchOrg');
1686     $page ||= $cgi->param('startPage') || 0;
1687     $page_size ||= $cgi->param('count') || 9;
1688     $thesauruses //= '';
1689     $thesauruses =~ s/\s//g;
1690     # protect against cats bouncing on the comma key...
1691     $thesauruses = join(',', grep { $_ ne '' } split /,/, $thesauruses);
1692
1693     $page = 0 if ($page !~ /^-?\d+$/);
1694     $page_size = 9 if $page_size !~ /^\d+$/;
1695
1696     my $prev = join('/', $base,$format,$axis,$site,$string,$page - 1,$page_size,$thesauruses);
1697     my $next = join('/', $base,$format,$axis,$site,$string,$page + 1,$page_size,$thesauruses);
1698
1699     unless ($string and $axis and grep { $axis eq $_ } keys %browse_types) {
1700         warn "something's wrong...";
1701         warn " >>> format: $format -> axis: $axis -> site: $site -> string: $string -> page: $page -> page_size: $page_size ";
1702         return undef;
1703     }
1704
1705     $string = decode_utf8($string);
1706     $string =~ s/\+/ /go;
1707     $string =~ s/'//go;
1708
1709     my $tree;
1710     if ($axis =~ /^authority/) {
1711         my ($realaxis, $refs) = ($axis =~ $authority_axis_re);
1712
1713         my $method = "open-ils.supercat.authority.browse_center.by_axis";
1714         $method .= ".refs" if $refs;
1715
1716         $tree = $supercat->request(
1717             $method,
1718             $realaxis,
1719             $string,
1720             $page,
1721             $page_size,
1722             $thesauruses
1723         )->gather(1);
1724     } else {
1725         $tree = $supercat->request(
1726             "open-ils.supercat.$axis.browse",
1727             $string,
1728             $site,
1729             $page_size,
1730             $page,
1731             $status,
1732             $cpLoc
1733         )->gather(1);
1734     }
1735
1736     (my $norm_format = $format) =~ s/(-full|-uris)$//o;
1737
1738     my ($header,$content) = $browse_types{$axis}{$norm_format}->($tree,$prev,$next,$format,$unapi,$base,$site);
1739     print $header.$content;
1740     return Apache2::Const::OK;
1741 }
1742
1743 sub string_startwith {
1744     my $apache = shift;
1745     return Apache2::Const::DECLINED if (-e $apache->filename);
1746
1747     check_child_init();
1748
1749     my $cgi = new CGI;
1750     my $year = (gmtime())[5] + 1900;
1751
1752     my $host = $cgi->virtual_host || $cgi->server_name;
1753
1754     my $add_path = 0;
1755     if ( $cgi->server_software !~ m|^Apache/2.2| ) {
1756         my $rel_name = $cgi->url(-relative=>1);
1757         $add_path = 1 if ($cgi->url(-path_info=>1) !~ /$rel_name$/);
1758     }
1759
1760     my $url = $cgi->url(-path_info=>$add_path);
1761     my $root = (split 'startwith', $url)[0];
1762     my $base = (split 'startwith', $url)[0] . 'startwith';
1763     my $unapi = (split 'startwith', $url)[0] . 'unapi';
1764
1765     my $path = $cgi->path_info;
1766     $path =~ s/^\///og;
1767
1768     my ($format,$axis,$site,$string,$page,$page_size,$thesauruses) = split '/', $path;
1769     #warn " >>> $format -> $axis -> $site -> $string -> $page -> $page_size -> $thesauruses ";
1770
1771     my $status = [$cgi->param('status')];
1772     my $cpLoc = [$cgi->param('copyLocation')];
1773     $site ||= $cgi->param('searchOrg');
1774     $page ||= $cgi->param('startPage') || 0;
1775     $page_size ||= $cgi->param('count') || 9;
1776     $thesauruses //= '';
1777     $thesauruses =~ s/\s//g;
1778     # protect against cats bouncing on the comma key...
1779     $thesauruses = join(',', grep { $_ ne '' } split /,/, $thesauruses);
1780
1781     $page = 0 if ($page !~ /^-?\d+$/);
1782     $page_size = 9 if $page_size !~ /^\d+$/;
1783
1784     my $prev = join('/', $base,$format,$axis,$site,$string,$page - 1,$page_size,$thesauruses);
1785     my $next = join('/', $base,$format,$axis,$site,$string,$page + 1,$page_size,$thesauruses);
1786
1787     unless ($string and $axis and grep { $axis eq $_ } keys %browse_types) {
1788         warn "something's wrong...";
1789         warn " >>> format: $format -> axis: $axis -> site: $site -> string: $string -> page: $page -> page_size: $page_size ";
1790         return undef;
1791     }
1792
1793     $string = decode_utf8($string);
1794     $string =~ s/\+/ /go;
1795     $string =~ s/'//go;
1796
1797     my $tree;
1798     if ($axis =~ /^authority/) {
1799         my ($realaxis, $refs) = ($axis =~ $authority_axis_re);
1800
1801         my $method = "open-ils.supercat.authority.browse_top.by_axis";
1802         $method .= ".refs" if $refs;
1803
1804         $tree = $supercat->request(
1805             $method,
1806             $realaxis,
1807             $string,
1808             $page,
1809             $page_size,
1810             $thesauruses
1811         )->gather(1);
1812     } else {
1813         $tree = $supercat->request(
1814             "open-ils.supercat.$axis.startwith",
1815             $string,
1816             $site,
1817             $page_size,
1818             $page,
1819             $status,
1820             $cpLoc
1821         )->gather(1);
1822     }
1823
1824     (my $norm_format = $format) =~ s/(-full|-uris)$//o;
1825
1826     my ($header,$content) = $browse_types{$axis}{$norm_format}->($tree,$prev,$next,$format,$unapi,$base,$site);
1827     print $header.$content;
1828     return Apache2::Const::OK;
1829 }
1830
1831 sub item_age_browse {
1832     my $apache = shift;
1833     return Apache2::Const::DECLINED if (-e $apache->filename);
1834
1835     check_child_init();
1836
1837     my $cgi = new CGI;
1838     my $year = (gmtime())[5] + 1900;
1839
1840     my $host = $cgi->virtual_host || $cgi->server_name;
1841
1842     my $add_path = 0;
1843     if ( $cgi->server_software !~ m|^Apache/2.2| ) {
1844         my $rel_name = $cgi->url(-relative=>1);
1845         $add_path = 1 if ($cgi->url(-path_info=>1) !~ /$rel_name$/);
1846     }
1847
1848     my $url = $cgi->url(-path_info=>$add_path);
1849     my $root = (split 'browse', $url)[0];
1850     my $base = (split 'browse', $url)[0] . 'browse';
1851     my $unapi = (split 'browse', $url)[0] . 'unapi';
1852
1853     my $path = $cgi->path_info;
1854     $path =~ s/^\///og;
1855
1856     my ($format,$axis,$site,$page,$page_size) = split '/', $path;
1857     #warn " >>> $format -> $axis -> $site -> $page -> $page_size ";
1858
1859     unless ($axis eq 'item-age') {
1860         warn "something's wrong...";
1861         warn " >>> $format -> $axis -> $site -> $page -> $page_size ";
1862         return undef;
1863     }
1864
1865     my $status = [$cgi->param('status')];
1866     my $cpLoc = [$cgi->param('copyLocation')];
1867     $site ||= $cgi->param('searchOrg') || '-';
1868     $page ||= $cgi->param('startPage') || 1;
1869     $page_size ||= $cgi->param('count') || 10;
1870
1871     $page = 1 if ($page !~ /^-?\d+$/ || $page < 1);
1872     $page_size = 10 if $page_size !~ /^\d+$/;
1873
1874     my $prev = join('/', $base,$format,$axis,$site,$page - 1,$page_size);
1875     my $next = join('/', $base,$format,$axis,$site,$page + 1,$page_size);
1876
1877     my $recs = $supercat->request(
1878         "open-ils.supercat.new_book_list",
1879         $site,
1880         $page_size,
1881         $page,
1882         $status,
1883         $cpLoc
1884     )->gather(1);
1885
1886     (my $norm_format = $format) =~ s/(-full|-uris)$//o;
1887
1888     my ($header,$content) = $browse_types{$axis}{$norm_format}->($recs,$prev,$next,$format,$unapi,$base,$site);
1889     print $header.$content;
1890     return Apache2::Const::OK;
1891 }
1892
1893 our %qualifier_ids = (
1894     eg  => 'http://open-ils.org/spec/SRU/context-set/evergreen/v1',
1895     dc  => 'info:srw/cql-context-set/1/dc-v1.1',
1896     bib => 'info:srw/cql-context-set/1/bib-v1.0',
1897     srw => ''
1898 );
1899
1900 # Our authority search options are currently pretty impoverished;
1901 # just right-truncated string match on a few categories, or by
1902 # ID number
1903 our %nested_auth_qualifier_map = (
1904         eg => {
1905             id          => { index => 'id', title => 'Record number'},
1906             name        => { index => 'author', title => 'Personal or corporate author, or meeting name'},
1907             title       => { index => 'title', title => 'Uniform title'},
1908             subject     => { index => 'subject', title => 'Chronological term, topical term, geographic name, or genre/form term'},
1909             topic       => { index => 'topic', title => 'Topical term'},
1910         },
1911 );
1912
1913 my $base_explain = <<XML;
1914 <explain
1915         id="evergreen-sru-explain-full"
1916         authoritative="true"
1917         xmlns:z="http://explain.z3950.org/dtd/2.0/"
1918         xmlns="http://explain.z3950.org/dtd/2.0/">
1919     <serverInfo transport="http" protocol="SRU" version="1.1">
1920         <host/>
1921         <port/>
1922         <database/>
1923     </serverInfo>
1924
1925     <databaseInfo>
1926         <title primary="true"/>
1927         <description primary="true"/>
1928     </databaseInfo>
1929
1930     <indexInfo>
1931         <set identifier="info:srw/cql-context-set/1/cql-v1.2" name="cql"/>
1932     </indexInfo>
1933
1934     <schemaInfo>
1935         <schema
1936                 identifier="info:srw/schema/1/marcxml-v1.1"
1937                 location="http://www.loc.gov/standards/marcxml/schema/MARC21slim.xsd"
1938                 sort="true"
1939                 retrieve="true"
1940                 name="marcxml">
1941             <title>MARC21Slim (marcxml)</title>
1942         </schema>
1943     </schemaInfo>
1944
1945     <configInfo>
1946         <default type="numberOfRecords">10</default>
1947         <default type="contextSet">eg</default>
1948         <default type="index">keyword</default>
1949         <default type="relation">all</default>
1950         <default type="sortSchema">marcxml</default>
1951         <default type="retrieveSchema">marcxml</default>
1952         <setting type="maximumRecords">50</setting>
1953         <supports type="relationModifier">relevant</supports>
1954         <supports type="relationModifier">stem</supports>
1955         <supports type="relationModifier">fuzzy</supports>
1956         <supports type="relationModifier">word</supports>
1957     </configInfo>
1958
1959 </explain>
1960 XML
1961
1962
1963 my $ex_doc;
1964 sub sru_search {
1965     my $cgi = new CGI;
1966
1967     check_child_init();
1968
1969     my $req = SRU::Request->newFromCGI( $cgi );
1970     my $resp = SRU::Response->newFromRequest( $req );
1971
1972     # Find the org_unit shortname, if passed as part of the URL
1973     # http://example.com/opac/extras/sru/SHORTNAME
1974     my $url = $cgi->path_info;
1975     my ($shortname, $holdings) = $url =~ m#/?([^/]*)(/holdings)?#;
1976
1977     if ( $resp->type eq 'searchRetrieve' ) {
1978
1979         # Older versions of Debian packages returned terms to us double-encoded,
1980         # so we had to forcefully double-decode them a second time with
1981         # an outer decode('utf8', $string) call; this seems to be resolved with
1982         # Debian Lenny packages sometime between 2009-07-27 and 2010-02-15
1983         my $cql_query = decode_utf8($req->query);
1984         my $search_string = decode_utf8($req->cql->toEvergreen);
1985
1986         # Ensure the search string overrides the default site
1987         if ($shortname and $search_string !~ m#site:#) {
1988             $search_string .= " site:$shortname";
1989         }
1990
1991         my $offset = $req->startRecord;
1992         $offset-- if ($offset);
1993         $offset ||= 0;
1994
1995         my $limit = $req->maximumRecords;
1996         $limit ||= 10;
1997
1998         $log->info("SRU search string [$cql_query] converted to [$search_string]\n");
1999
2000         if (!$shortname || $shortname eq '-') {
2001             my $search_org = get_ou($shortname);
2002             $shortname = $search_org->[0]->shortname;
2003         }
2004
2005          my $recs = $search->request(
2006             'open-ils.search.biblio.multiclass.query' => {offset => $offset, limit => $limit} => $search_string => 1
2007         )->gather(1);
2008
2009         my $cstore = OpenSRF::AppSession->create('open-ils.cstore');
2010         foreach my $rec (@{$recs->{ids}}) {
2011             my $rec_id = shift @$rec;
2012             my $data = $cstore->request(
2013                 'open-ils.cstore.json_query' => {
2014                     from => [
2015                         'unapi.bre', $rec_id,
2016                         'marcxml', 'record',
2017                         ($holdings) ? '{holdings_xml,acp}' : '{}',
2018                         $shortname
2019                     ]
2020                 }
2021             )->gather(1);
2022             try {
2023                 my $marcxml = XML::LibXML->load_xml( string => $data->{'unapi.bre'} );
2024
2025                 # process <holdings> element, if any
2026                 my @copies;
2027                 for my $node ($marcxml->getElementsByTagName('holdings')) {
2028                     for my $volume ($node->getElementsByTagName('volume')) {
2029                         my $prefix = $volume->getChildrenByTagName('call_number_prefix')->[0]->getAttribute('label');
2030                         my $suffix = $volume->getChildrenByTagName('call_number_suffix')->[0]->getAttribute('label');
2031                         my $cn = $volume->getAttribute('label');
2032                         my $owning_lib = $volume->getAttribute('lib');
2033                         for my $copy ($volume->getElementsByTagName('copy')) {
2034                             # skip copies that aren't OPAC-visible
2035                             next if (
2036                                 $copy->getAttribute('opac_visible') eq 'false' ||
2037                                 $copy->getChildrenByTagName('status')->[0]->getAttribute('opac_visible') eq 'false' ||
2038                                 $copy->getChildrenByTagName('location')->[0]->getAttribute('opac_visible') eq 'false' ||
2039                                 $copy->getChildrenByTagName('circ_lib')->[0]->getAttribute('opac_visible') eq 'false'
2040                             );
2041                             push @copies, {
2042                                 a => $copy->getChildrenByTagName('location')->[0]->textContent,
2043                                 b => $owning_lib,
2044                                 c => $cn,
2045                                 d => $copy->getChildrenByTagName('circ_lib')->[0]->getAttribute('shortname'),
2046                                 g => $copy->getAttribute('barcode'),
2047                                 k => $prefix,
2048                                 m => $suffix,
2049                                 n => $copy->getChildrenByTagName('status')->[0]->textContent
2050                             };
2051                         }
2052                     }
2053                     # remove <holdings> element
2054                     $node->parentNode->removeChild($node);
2055                 }
2056
2057                 my $marc = MARC::Record->new_from_xml($marcxml->toString(), 'UTF8', 'XML');
2058
2059                 # Force record leader to 'a' as our data is always UTF8
2060                 # Avoids marc8_to_utf8 from being invoked with horrible results
2061                 # on the off-chance the record leader isn't correct
2062                 my $ldr = $marc->leader;
2063                 substr($ldr, 9, 1, 'a');
2064                 $marc->leader($ldr);
2065
2066                 # Expects the record ID in the 001
2067                 $marc->delete_field($_) for ($marc->field('001'));
2068                 if (!$marc->field('001')) {
2069                     $marc->insert_fields_ordered(
2070                         MARC::Field->new( '001', $rec_id )
2071                     );
2072                 }
2073
2074                 $marc->delete_field($_) for ($marc->field('852')); # remove any legacy 852s
2075                 for my $copy (@copies) {
2076                     $marc->insert_fields_ordered(
2077                         MARC::Field->new(
2078                             '852', '4', '',
2079                             a => $copy->{a},
2080                             b => $copy->{b},
2081                             c => $copy->{c},
2082                             d => $copy->{d},
2083                             g => $copy->{g},
2084                             ($copy->{k} ? (k => $copy->{k}) : ()),
2085                             ($copy->{m} ? (m => $copy->{m}) : ()),
2086                             n => $copy->{n}
2087                         )
2088                     );
2089                 }
2090
2091                 my $output = $marc->as_xml_record();
2092                 $output =~ s/^<\?xml version="1.0" encoding="UTF-8"\?>//o;
2093                 $resp->addRecord(
2094                     SRU::Response::Record->new(
2095                         recordSchema    => 'info:srw/schema/1/marcxml-v1.1',
2096                         recordData => $output,
2097                         recordPosition => ++$offset
2098                     )
2099                 );
2100
2101             } catch Error with {
2102                 $log->error("Failed to process record for SRU search");
2103             }
2104         }
2105
2106         $resp->numberOfRecords($recs->{count});
2107
2108     } elsif ( $resp->type eq 'explain' ) {
2109         return_sru_explain($cgi, $req, $resp, \$ex_doc,
2110             undef,
2111             \%OpenILS::WWW::SuperCat::qualifier_ids
2112         );
2113
2114         $resp->record(
2115             SRU::Response::Record->new(
2116                 recordSchema    => 'info:srw/cql-context-set/2/zeerex-1.1',
2117                 recordData        => $ex_doc
2118             )
2119         );
2120     }
2121
2122     print $cgi->header( -type => 'application/xml', -charset => 'UTF-8' );
2123     print $U->entityize($resp->asXML) . "\n";
2124     return Apache2::Const::OK;
2125 }
2126
2127
2128 {
2129     package CQL::BooleanNode;
2130
2131     sub toEvergreen {
2132         my $self     = shift;
2133         my $left     = $self->left();
2134         my $right    = $self->right();
2135         my $leftStr  = $left->toEvergreen;
2136         my $rightStr = $right->toEvergreen();
2137
2138         my $op =  '||' if uc $self->op() eq 'OR';
2139         $op ||=  '&&';
2140
2141         return  "$leftStr $op $rightStr";
2142     }
2143
2144     sub toEvergreenAuth {
2145         return toEvergreen(shift);
2146     }
2147
2148     package CQL::TermNode;
2149
2150     sub toEvergreen {
2151         my $self      = shift;
2152         my $qualifier = $self->getQualifier();
2153         my $term      = $self->getTerm();
2154         my $relation  = $self->getRelation();
2155
2156         my $query;
2157         if ( $qualifier ) {
2158             my ($qset, $qname) = split(/\./, $qualifier);
2159
2160             # Per http://www.loc.gov/standards/sru/specs/cql.html
2161             # "All parts of CQL are case insensitive [...] If any case insensitive
2162             # part of CQL is specified with both upper and lower case, it is for
2163             # aesthetic purposes only."
2164
2165             # So fold the qualifier and relation to lower case
2166             $qset = lc($qset);
2167             $qname = lc($qname);
2168
2169             if ( exists($qualifier_map{$qset}{$qname}) ) {
2170                 $qualifier = $qualifier_map{$qset}{$qname}{'index'} || 'kw';
2171                 $log->debug("SRU toEvergreen: $qset, $qname   $qualifier_map{$qset}{$qname}{'index'}\n");
2172             }
2173
2174             my @modifiers = $relation->getModifiers();
2175
2176             my $base = $relation->getBase();
2177             if ( grep { $base eq $_ } qw/= scr exact all/ ) {
2178
2179                 my $quote_it = 1;
2180                 foreach my $m ( @modifiers ) {
2181                     if( grep { $m->[ 1 ] eq $_ } qw/cql.fuzzy cql.stem cql.relevant cql.word/ ) {
2182                         $quote_it = 0;
2183                         last;
2184                     }
2185                 }
2186
2187                 $quote_it = 0 if ( $base eq 'all' );
2188                 $term = maybeQuote($term) if $quote_it;
2189
2190             } else {
2191                 croak( "Evergreen doesn't support the $base relations" );
2192             }
2193
2194
2195         } else {
2196             $qualifier = "kw";
2197         }
2198
2199         return "$qualifier:$term";
2200     }
2201
2202     sub toEvergreenAuth {
2203         my $self      = shift;
2204         my $qualifier = $self->getQualifier();
2205         my $term      = $self->getTerm();
2206         my $relation  = $self->getRelation();
2207
2208         my $query;
2209         if ( $qualifier ) {
2210             my ($qset, $qname) = split(/\./, $qualifier);
2211
2212             if ( exists($OpenILS::WWW::SuperCat::nested_auth_qualifier_map{$qset}{$qname}) ) {
2213                 $qualifier = $OpenILS::WWW::SuperCat::nested_auth_qualifier_map{$qset}{$qname}{'index'} || 'author';
2214                 $log->debug("SRU toEvergreenAuth: $qset, $qname   $OpenILS::WWW::SuperCat::nested_auth_qualifier_map{$qset}{$qname}{'index'}\n");
2215             }
2216         }
2217         return { qualifier => $qualifier, term => $term };
2218     }
2219 }
2220
2221 my $auth_ex_doc;
2222 sub sru_auth_search {
2223     my $cgi = new CGI;
2224
2225     check_child_init();
2226
2227     my $req = SRU::Request->newFromCGI( $cgi );
2228     my $resp = SRU::Response->newFromRequest( $req );
2229
2230     if ( $resp->type eq 'searchRetrieve' ) {
2231         return_auth_response($cgi, $req, $resp);
2232     } elsif ( $resp->type eq 'explain' ) {
2233         return_sru_explain($cgi, $req, $resp, \$auth_ex_doc,
2234             \%OpenILS::WWW::SuperCat::nested_auth_qualifier_map,
2235             \%OpenILS::WWW::SuperCat::qualifier_ids
2236         );
2237     }
2238
2239     print $cgi->header( -type => 'application/xml', -charset => 'UTF-8' );
2240     print $U->entityize($resp->asXML) . "\n";
2241     return Apache2::Const::OK;
2242 }
2243
2244 sub explain_header {
2245     my $cgi = shift;
2246
2247     my $host = $cgi->virtual_host || $cgi->server_name;
2248
2249     my $add_path = 0;
2250     if ( $cgi->server_software !~ m|^Apache/2.2| ) {
2251         my $rel_name = $cgi->url(-relative=>1);
2252         $add_path = 1 if ($cgi->url(-path_info=>1) !~ /$rel_name$/);
2253     }
2254     my $base = $cgi->url(-base=>1);
2255     my $url = $cgi->url(-path_info=>$add_path);
2256     $url =~ s/^$base\///o;
2257
2258     my $doc = $parser->parse_string($base_explain);
2259     my $e = $doc->documentElement;
2260     $e->findnodes('/z:explain/z:serverInfo/z:host')->shift->appendText( $host );
2261     $e->findnodes('/z:explain/z:serverInfo/z:port')->shift->appendText( $cgi->server_port );
2262     $e->findnodes('/z:explain/z:serverInfo/z:database')->shift->appendText( $url );
2263
2264     return ($doc, $e);
2265 }
2266
2267 sub return_sru_explain {
2268     my ($cgi, $req, $resp, $explain, $index_map, $qualifier_ids) = @_;
2269
2270     $index_map ||= \%qualifier_map;
2271     if (!$$explain) {
2272         my ($doc, $e) = explain_header($cgi);
2273         for my $name ( keys %{$index_map} ) {
2274
2275             my $identifier = $qualifier_ids->{ $name };
2276
2277             next unless $identifier;
2278
2279             my $set_node = $doc->createElementNS( 'http://explain.z3950.org/dtd/2.0/', 'set' );
2280             $set_node->setAttribute( identifier => $identifier );
2281             $set_node->setAttribute( name => $name );
2282
2283             $e->findnodes('/z:explain/z:indexInfo')->shift->appendChild( $set_node );
2284             for my $index ( sort keys %{$index_map->{$name}} ) {
2285                 my $name_node = $doc->createElementNS( 'http://explain.z3950.org/dtd/2.0/', 'name' );
2286
2287                 my $map_node = $doc->createElementNS( 'http://explain.z3950.org/dtd/2.0/', 'map' );
2288                 $map_node->appendChild( $name_node );
2289
2290                 my $title_node = $doc->createElementNS( 'http://explain.z3950.org/dtd/2.0/', 'title' );
2291
2292                 my $index_node = $doc->createElementNS( 'http://explain.z3950.org/dtd/2.0/', 'index' );
2293                 $index_node->appendChild( $title_node );
2294                 $index_node->appendChild( $map_node );
2295
2296                 $index_node->setAttribute( id => "$name.$index" );
2297                 $title_node->appendText($index_map->{$name}{$index}{'title'});
2298                 $name_node->setAttribute( set => $name );
2299                 $name_node->appendText($index_map->{$name}{$index}{'index'});
2300
2301                 $e->findnodes('/z:explain/z:indexInfo')->shift->appendChild( $index_node );
2302             }
2303         }
2304
2305         $$explain = $e->toString;
2306     }
2307
2308     $resp->record(
2309         SRU::Response::Record->new(
2310             recordSchema    => 'info:srw/cql-context-set/2/zeerex-1.1',
2311             recordData      => $$explain
2312         )
2313     );
2314
2315 }
2316
2317 sub return_auth_response {
2318     my ($cgi, $req, $resp) = @_;
2319
2320     my $cql_query = decode_utf8($req->query);
2321     my $search = $req->cql->toEvergreenAuth;
2322
2323     my $qualifier = decode_utf8($search->{qualifier});
2324     my $term = decode_utf8($search->{term});
2325
2326     $log->info("SRU NAF search string [$cql_query] converted to "
2327         . "[$qualifier:$term]\n");
2328
2329     my $page_size = $req->maximumRecords;
2330     $page_size ||= 10;
2331
2332     # startwith deals with pages, so convert startRecord to a page number
2333     my $page = ($req->startRecord / $page_size) || 0;
2334
2335     my $recs;
2336     if ($qualifier eq "id") {
2337         $recs = [ int($term) ];
2338     } else {
2339         my ($realaxis, $refs) = ($qualifier =~ $authority_axis_re);
2340
2341         my $method = "open-ils.supercat.authority.browse_top.by_axis";
2342         $method .= ".refs" if $refs;
2343
2344         $recs = $supercat->request(
2345             $method,
2346             $realaxis,
2347             $term,
2348             $page,
2349             $page_size
2350         )->gather(1);
2351     }
2352
2353     my $record_position = $req->startRecord;
2354     my $cstore = OpenSRF::AppSession->create('open-ils.cstore');
2355     foreach my $record (@$recs) {
2356         my $marcxml = $cstore->request(
2357             'open-ils.cstore.direct.authority.record_entry.retrieve', $record
2358         )->gather(1)->marc;
2359
2360         $resp->addRecord(
2361             SRU::Response::Record->new(
2362                 recordSchema    => 'info:srw/schema/1/marcxml-v1.1',
2363                 recordData => $marcxml,
2364                 recordPosition => ++$record_position
2365             )
2366         );
2367     }
2368
2369     $resp->numberOfRecords(scalar(@$recs));
2370 }
2371
2372 =head2 get_ou($org_unit)
2373
2374 Returns an aou object for a given actor.org_unit shortname or ID.
2375
2376 =cut
2377
2378 sub get_ou {
2379     my $org = shift || '-';
2380     my $org_unit;
2381
2382     if ($org eq '-') {
2383          $org_unit = $actor->request(
2384             'open-ils.actor.org_unit_list.search' => parent_ou => undef
2385         )->gather(1);
2386     } elsif ($org !~ /^\d+$/o) {
2387          $org_unit = $actor->request(
2388             'open-ils.actor.org_unit_list.search' => shortname => uc($org)
2389         )->gather(1);
2390     } else {
2391          $org_unit = $actor->request(
2392             'open-ils.actor.org_unit_list.search' => id => $org
2393         )->gather(1);
2394     }
2395
2396     return $org_unit;
2397 }
2398
2399 1;
2400
2401 # vim: et:ts=4:sw=4