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