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

   1 package OpenILS::WWW::SuperCat;
   2 use strict; use warnings;
   3
   4 use Apache2 ();
   5 use Apache2::Log;
   6 use Apache2::Const -compile => qw(OK REDIRECT DECLINED :log);
   7 use APR::Const    -compile => qw(:error SUCCESS);
   8 use Apache2::RequestRec ();
   9 use Apache2::RequestIO ();
  10 use Apache2::RequestUtil;
  11 use CGI;
  12 use Data::Dumper;
  13
  14 use OpenSRF::EX qw(:try);
  15 use OpenSRF::Utils qw/:datetime/;
  16 use OpenSRF::System;
  17 use OpenSRF::AppSession;
  18 use XML::LibXML;
  19
  20 use Unicode::Normalize;
  21 use OpenILS::Utils::Fieldmapper;
  22
  23
  24 # set the bootstrap config when this module is loaded
  25 my ($bootstrap, $supercat, $actor, $parser);
  26
  27 sub import {
  28         my $self = shift;
  29         $bootstrap = shift;
  30 }
  31
  32
  33 sub child_init {
  34         OpenSRF::System->bootstrap_client( config_file => $bootstrap );
  35         $supercat = OpenSRF::AppSession->create('open-ils.supercat');
  36         $actor = OpenSRF::AppSession->create('open-ils.actor');
  37         $parser = new XML::LibXML;
  38 }
  39
  40 sub oisbn {
  41
  42         my $apache = shift;
  43         return Apache2::Const::DECLINED if (-e $apache->filename);
  44
  45         (my $isbn = $apache->path_info) =~ s{^.*?([^/]+)$}{$1}o;
  46
  47         my $list = $supercat
  48                 ->request("open-ils.supercat.oisbn", $isbn)
  49                 ->gather(1);
  50
  51         print "Content-type: application/xml; charset=utf-8\n\n";
  52         print "<?xml version='1.0' encoding='UTF-8' ?>\n";
  53
  54         unless (exists $$list{metarecord}) {
  55                 print '<idlist/>';
  56                 return Apache2::Const::OK;
  57         }
  58
  59         print "<idlist metarecord='$$list{metarecord}'>\n";
  60
  61         for ( keys %{ $$list{record_list} } ) {
  62                 (my $o = $$list{record_list}{$_}) =~s/^(\S+).*?$/$1/o;
  63                 print "  <isbn record='$_'>$o</isbn>\n"
  64         }
  65
  66         print "</idlist>\n";
  67
  68         return Apache2::Const::OK;
  69 }
  70
  71 sub unapi {
  72
  73         my $apache = shift;
  74         return Apache2::Const::DECLINED if (-e $apache->filename);
  75
  76         print "Content-type: application/xml; charset=utf-8\n";
  77
  78         my $cgi = new CGI;
  79
  80         my $uri = $cgi->param('uri') || '';
  81         my $base = $cgi->url;
  82         my $host = $cgi->virtual_host || $cgi->server_name;
  83
  84         my $format = $cgi->param('format');
  85         my ($id,$type,$command) = ('','','');
  86
  87         if (!$format) {
  88                 if ($uri =~ m{^tag:[^:]+:([^\/]+)/(\d+)}o) {
  89                         $id = $2;
  90                         $type = 'record';
  91                         $type = 'metarecord' if ($1 =~ /^m/o);
  92
  93                         my $list = $supercat
  94                         ->request("open-ils.supercat.$type.formats")
  95                                 ->gather(1);
  96
  97                         print "\n";
  98
  99                         my $body =
 100                                 "<formats>
 101                                  <uri>$uri</uri>
 102                                    <format>
 103                                      <name>opac</name>
 104                                      <type>text/html</type>
 105                                    </format>";
 106
 107                         for my $h (@$list) {
 108                                 my ($type) = keys %$h;
 109                                 $body .= "<format><name>$type</name><type>application/$type+xml</type>";
 110
 111                                 for my $part ( qw/namespace_uri docs schema_location/ ) {
 112                                         $body .= "<$part>$$h{$type}{$part}</$part>"
 113                                                 if ($$h{$type}{$part});
 114                                 }
 115
 116                                 $body .= '</format>';
 117                         }
 118
 119                         $body .= "</formats>\n";
 120
 121                         $apache->custom_response( 300, $body);
 122                         return 300;
 123                 } else {
 124                         my $list = $supercat
 125                                 ->request("open-ils.supercat.record.formats")
 126                                 ->gather(1);
 127
 128                         push @$list,
 129                                 @{ $supercat
 130                                         ->request("open-ils.supercat.metarecord.formats")
 131                                         ->gather(1);
 132                                 };
 133
 134                         my %hash = map { ( (keys %$_)[0] => (values %$_)[0] ) } @$list;
 135                         $list = [ map { { $_ => $hash{$_} } } sort keys %hash ];
 136
 137                         print "\n<formats>
 138                                    <format>
 139                                      <name>opac</name>
 140                                      <type>text/html</type>
 141                                    </format>";
 142
 143                         for my $h (@$list) {
 144                                 my ($type) = keys %$h;
 145                                 print "<format><name>$type</name><type>application/$type+xml</type>";
 146
 147                                 for my $part ( qw/namespace_uri docs schema_location/ ) {
 148                                         print "<$part>$$h{$type}{$part}</$part>"
 149                                                 if ($$h{$type}{$part});
 150                                 }
 151
 152                                 print '</format>';
 153                         }
 154
 155                         print "</formats>\n";
 156
 157
 158                         return Apache2::Const::OK;
 159                 }
 160         }
 161
 162
 163         if ($uri =~ m{^tag:[^:]+:([^\/]+)/(\d+)}o) {
 164                 $id = $2;
 165                 $type = 'record';
 166                 $type = 'metarecord' if ($1 =~ /^m/o);
 167                 $command = 'retrieve';
 168         }
 169
 170         if ($format eq 'opac') {
 171                 print "Location: $base/../../en-US/skin/default/xml/rresult.xml?m=$id\n\n"
 172                         if ($type eq 'metarecord');
 173                 print "Location: $base/../../en-US/skin/default/xml/rdetail.xml?r=$id\n\n"
 174                         if ($type eq 'record');
 175                 return 302;
 176         }
 177
 178         print "\n" . $supercat->request("open-ils.supercat.$type.$format.$command",$id)->gather(1);
 179
 180         return Apache2::Const::OK;
 181 }
 182
 183 sub supercat {
 184
 185         my $apache = shift;
 186         return Apache2::Const::DECLINED if (-e $apache->filename);
 187
 188         my $path = $apache->path_info;
 189
 190         my $cgi = new CGI;
 191         my $base = $cgi->url;
 192
 193         my ($id,$type,$format,$command) = reverse split '/', $path;
 194
 195         print "Content-type: application/xml; charset=utf-8\n";
 196
 197         if ( $path =~ m{^/formats(?:/([^\/]+))?$}o ) {
 198                 if ($1) {
 199                         my $list = $supercat
 200                                 ->request("open-ils.supercat.$1.formats")
 201                                 ->gather(1);
 202
 203                         print "\n";
 204
 205                         print "<formats>
 206                                    <format>
 207                                      <name>opac</name>
 208                                      <type>text/html</type>
 209                                    </format>";
 210
 211                         for my $h (@$list) {
 212                                 my ($type) = keys %$h;
 213                                 print "<format><name>$type</name><type>application/$type+xml</type>";
 214
 215                                 for my $part ( qw/namespace_uri docs schema_location/ ) {
 216                                         print "<$part>$$h{$type}{$part}</$part>"
 217                                                 if ($$h{$type}{$part});
 218                                 }
 219
 220                                 print '</format>';
 221                         }
 222
 223                         print "</formats>\n";
 224
 225                         return Apache2::Const::OK;
 226                 }
 227
 228                 my $list = $supercat
 229                         ->request("open-ils.supercat.record.formats")
 230                         ->gather(1);
 231
 232                 push @$list,
 233                         @{ $supercat
 234                                 ->request("open-ils.supercat.metarecord.formats")
 235                                 ->gather(1);
 236                         };
 237
 238                 my %hash = map { ( (keys %$_)[0] => (values %$_)[0] ) } @$list;
 239                 $list = [ map { { $_ => $hash{$_} } } sort keys %hash ];
 240
 241                 print "\n<formats>
 242                            <format>
 243                              <name>opac</name>
 244                              <type>text/html</type>
 245                            </format>";
 246
 247                 for my $h (@$list) {
 248                         my ($type) = keys %$h;
 249                         print "<format><name>$type</name><type>application/$type+xml</type>";
 250
 251                         for my $part ( qw/namespace_uri docs schema_location/ ) {
 252                                 print "<$part>$$h{$type}{$part}</$part>"
 253                                         if ($$h{$type}{$part});
 254                         }
 255
 256                         print '</format>';
 257                 }
 258
 259                 print "</formats>\n";
 260
 261
 262                 return Apache2::Const::OK;
 263         }
 264
 265         if ($format eq 'opac') {
 266                 print "Location: $base/../../en-US/skin/default/xml/rresult.xml?m=$id\n\n"
 267                         if ($type eq 'metarecord');
 268                 print "Location: $base/../../en-US/skin/default/xml/rdetail.xml?r=$id\n\n"
 269                         if ($type eq 'record');
 270                 return 302;
 271         }
 272
 273         print "\n" . $supercat->request("open-ils.supercat.$type.$format.$command",$id)->gather(1);
 274
 275         return Apache2::Const::OK;
 276 }
 277
 278
 279 sub bookbag_feed {
 280         my $apache = shift;
 281         return Apache2::Const::DECLINED if (-e $apache->filename);
 282
 283         print "Content-type: application/xml; charset=utf-8\n\n";
 284
 285         my $cgi = new CGI;
 286         (my $unapi = $cgi->url) =~ s{[^/]+/?$}{unapi};
 287
 288         my $year = (gmtime())[5];
 289
 290         my $host = $cgi->virtual_host || $cgi->server_name;
 291         my $path = $apache->path_info;
 292
 293         my ($id,$type) = reverse split '/', $path;
 294
 295         my $bucket = $actor->request("open-ils.actor.container.public.flesh", 'biblio', $id)->gather(1);
 296         my $bucket_tag = "tag:$host,$year:record_bucket/$id";
 297
 298         my $feed = create_record_feed(
 299                 $type,
 300                 [ map { $_->target_biblio_record_entry } @{ $bucket->items } ],
 301                 $unapi,
 302         );
 303
 304         $feed->title("Items in Book Bag #".$bucket->id);
 305         $feed->creator($host);
 306         $feed->update_ts(gmtime_ISO8601());
 307
 308         $feed->link(atom => $id);
 309         $feed->link(rss2 => $id);
 310         $feed->link(html => $id);
 311
 312         print entityize($feed->toString) . "\n";
 313
 314         return Apache2::Const::OK;
 315 }
 316
 317 sub create_record_feed {
 318         my $type = shift;
 319         my $records = shift;
 320         my $unapi = shift;
 321
 322         my $cgi = new CGI;
 323         my $base = $cgi->url;
 324         my $host = $cgi->virtual_host || $cgi->server_name;
 325
 326         my $year = (gmtime())[5];
 327
 328         my $feed = new OpenILS::WWW::SuperCat::Feed ($type);
 329         $feed->base($base);
 330         $feed->unapi($unapi);
 331
 332         for my $rec (@$records) {
 333                 my $item_tag = "tag:$host,$year:biblio-record_entry/" . $rec;
 334
 335                 my $xml = $supercat->request(
 336                         "open-ils.supercat.record.$type.retrieve",
 337                         $rec
 338                 )->gather(1);
 339
 340                 my $node = $feed->add_item($xml);
 341
 342                 $node->id($item_tag);
 343                 $node->link(unapi => $item_tag);
 344         }
 345
 346         return $feed;
 347 }
 348
 349 sub entityize {
 350         my $stuff = NFC(shift());
 351         $stuff =~ s/([\x{0080}-\x{fffd}])/sprintf('&#x%X;',ord($1))/sgoe;
 352         return $stuff;
 353 }
 354
 355 package OpenILS::WWW::SuperCat::Feed;
 356
 357 sub new {
 358         my $class = shift;
 359         my $type = shift;
 360         if ($type) {
 361                 $class .= '::'.$type;
 362                 return $class->new;
 363         }
 364         throw OpenSRF::EX::ERROR ("I need a feed type!") ;
 365 }
 366
 367 sub build {
 368         my $class = shift;
 369         my $xml = shift;
 370
 371         my $self = { doc => $parser->parse_string($xml), items => [] };
 372
 373         return bless $self => $class;
 374 }
 375
 376 sub base {
 377         my $self = shift;
 378         my $base = shift;
 379         $self->{base} = $base if ($base);
 380         return $self->{base};
 381 }
 382
 383 sub unapi {
 384         my $self = shift;
 385         my $unapi = shift;
 386         $self->{unapi} = $unapi if ($unapi);
 387         return $self->{unapi};
 388 }
 389
 390 sub push_item {
 391         my $self = shift;
 392         push @{ $self->{items} }, @_;
 393 }
 394
 395 sub items {
 396         my $self = shift;
 397         return @{ $self->{items} } if (wantarray);
 398         return $self->{items};
 399 }
 400
 401 sub _add_node {
 402         my $self = shift;
 403
 404         my $xpath = shift;
 405         my $new = shift;
 406
 407         for my $node ($self->{doc}->findnodes($xpath)) {
 408                 $node->appendChild($new);
 409                 last;
 410         }
 411 }
 412
 413 sub _create_node {
 414         my $self = shift;
 415
 416         my $xpath = shift;
 417         my $ns = shift;
 418         my $name = shift;
 419         my $text = shift;
 420         my $attrs = shift;
 421
 422         for my $node ($self->{doc}->findnodes($xpath)) {
 423                 my $new = $self->{doc}->createElement($name) if (!$ns);
 424                 $new = $self->{doc}->createElementNS($ns,$name) if ($ns);
 425
 426                 $new->appendChild( $self->{doc}->createTextNode( $text ) )
 427                         if ($text);
 428
 429                 if (ref($attrs)) {
 430                         for my $key (keys %$attrs) {
 431                                 $new->setAttribute( $key => $$attrs{$key} );
 432                         }
 433                 }
 434
 435                 $node->appendChild( $new );
 436
 437                 return $new;
 438         }
 439 }
 440
 441 sub add_item {
 442         my $self = shift;
 443         my $class = ref($self) || $self;
 444         $class .= '::item';
 445
 446         my $item_xml = shift;
 447         my $entry = $class->new($item_xml);
 448
 449         $entry->base($self->base);
 450         $entry->unapi($self->unapi);
 451
 452         $self->push_item($entry);
 453         return $entry;
 454 }
 455
 456 sub toString {
 457         my $self = shift;
 458         for my $root ( $self->{doc}->findnodes($self->{item_xpath}) ) {
 459                 for my $item ( $self->items ) {
 460                         $root->appendChild( $item->{doc}->documentElement );
 461                 }
 462                 last;
 463         }
 464
 465         return $self->{doc}->toString;
 466 }
 467
 468 sub id {};
 469 sub link {};
 470 sub title {};
 471 sub update_ts {};
 472 sub creator {};
 473
 474 #----------------------------------------------------------
 475
 476 package OpenILS::WWW::SuperCat::Feed::atom;
 477 use base 'OpenILS::WWW::SuperCat::Feed';
 478
 479 sub new {
 480         my $class = shift;
 481         my $self = $class->SUPER::build('<atom:feed xmlns:atom="http://www.w3.org/2005/Atom"/>');
 482         $self->{type} = 'atom';
 483         $self->{item_xpath} = '/atom:feed';
 484         return $self;
 485 }
 486
 487 sub title {
 488         my $self = shift;
 489         my $text = shift;
 490         $self->_create_node('/atom:feed','http://www.w3.org/2005/Atom','atom:title', $text);
 491 }
 492
 493 sub update_ts {
 494         my $self = shift;
 495         my $text = shift;
 496         $self->_create_node('/atom:feed','http://www.w3.org/2005/Atom','atom:updated', $text);
 497 }
 498
 499 sub creator {
 500         my $self = shift;
 501         my $text = shift;
 502         $self->_create_node('/atom:feed','http://www.w3.org/2005/Atom','atom:author');
 503         $self->_create_node('/atom:feed/atom:author', 'http://www.w3.org/2005/Atom','atom:name', $text);
 504 }
 505
 506 sub link {
 507         my $self = shift;
 508         my $type = shift;
 509         my $id = shift;
 510
 511         $self->_create_node(
 512                 '/atom:feed',
 513                 'http://www.w3.org/2005/Atom',
 514                 'atom:link',
 515                 undef,
 516                 { rel => $type,
 517                   href => $self->base . '/' . $type . '/' . $id,
 518                   type => "application/$type+xml",
 519                 }
 520         );
 521 }
 522
 523 sub id {
 524         my $self = shift;
 525         my $id = shift;
 526
 527         $self->_create_node( '/atom:feed', 'http://www.w3.org/2005/Atom', 'atom:id', $id );
 528 }
 529
 530 package OpenILS::WWW::SuperCat::Feed::atom::item;
 531 use base 'OpenILS::WWW::SuperCat::Feed::atom';
 532
 533 sub new {
 534         my $class = shift;
 535         my $xml = shift;
 536         my $self = $class->SUPER::build($xml);
 537         $self->{doc}->documentElement->setNamespace('http://www.w3.org/2005/Atom', 'atom');
 538         $self->{type} = 'atom::item';
 539         return $self;
 540 }
 541
 542 sub link {
 543         my $self = shift;
 544         my $type = shift;
 545         my $id = shift;
 546
 547         if ($type eq 'unapi') {
 548                 $self->_create_node(
 549                         'atom:entry',
 550                         'http://www.w3.org/2005/Atom',
 551                         'atom:link',
 552                         undef,
 553                         { rel => $type,
 554                           type => "application/xml",
 555                           href => $self->unapi . '?uri=' . $id,
 556                         }
 557                 );
 558         }
 559 }
 560
 561
 562 #----------------------------------------------------------
 563
 564 package OpenILS::WWW::SuperCat::Feed::rss2;
 565 use base 'OpenILS::WWW::SuperCat::Feed';
 566
 567 sub new {
 568         my $class = shift;
 569         my $self = $class->SUPER::build('<rss version="2.0"><channel/></rss>');
 570         $self->{type} = 'rss2';
 571         $self->{item_xpath} = '/rss/channel';
 572         return $self;
 573 }
 574
 575 sub title {
 576         my $self = shift;
 577         my $text = shift;
 578         $self->_create_node('/rss/channel',undef,'title', $text);
 579 }
 580
 581 sub update_ts {
 582         my $self = shift;
 583         my $text = shift;
 584         $self->_create_node('/rss/channel',undef,'lastBuildDate', $text);
 585 }
 586
 587 sub creator {
 588         my $self = shift;
 589         my $text = shift;
 590         $self->_create_node('/rss/channel', undef,'generator', $text);
 591 }
 592
 593 sub link {
 594         my $self = shift;
 595         my $type = shift;
 596         my $id = shift;
 597
 598         $self->_create_node(
 599                 '/rss/channel',
 600                 undef,
 601                 'link',
 602                 $self->base . '/' . $type . '/' . $id,
 603                 { rel => $type }
 604         );
 605 }
 606
 607 package OpenILS::WWW::SuperCat::Feed::rss2::item;
 608 use base 'OpenILS::WWW::SuperCat::Feed::rss2';
 609
 610 sub new {
 611         my $class = shift;
 612         my $xml = shift;
 613         my $self = $class->SUPER::build($xml);
 614         $self->{type} = 'atom::item';
 615         return $self;
 616 }
 617
 618 sub link {
 619         my $self = shift;
 620         my $type = shift;
 621         my $id = shift;
 622
 623         $self->_create_node( item => undef, 'link' => $self->unapi . '?uri=' . $id )
 624                 if ($type eq 'unapi');
 625 }
 626
 627
 628 #----------------------------------------------------------
 629
 630 package OpenILS::WWW::SuperCat::Feed::mods;
 631 use base 'OpenILS::WWW::SuperCat::Feed';
 632
 633 sub new {
 634         my $class = shift;
 635         my $self = $class->SUPER::build('<mods:modsCollection version="3.0" xmlns:mods="http://www.loc.gov/mods/"/>');
 636         $self->{type} = 'mods';
 637         $self->{item_xpath} = '/mods:modsCollection';
 638         return $self;
 639 }
 640
 641 package OpenILS::WWW::SuperCat::Feed::mods::item;
 642 use base 'OpenILS::WWW::SuperCat::Feed::mods';
 643
 644 sub new {
 645         my $class = shift;
 646         my $xml = shift;
 647         my $self = $class->SUPER::build($xml);
 648         $self->{doc}->documentElement->setNamespace('http://www.loc.gov/mods/', 'mods');
 649         $self->{type} = 'mods::item';
 650         return $self;
 651 }
 652
 653 my $linkid = 1;
 654
 655 sub link {
 656         my $self = shift;
 657         my $type = shift;
 658         my $id = shift;
 659
 660         if ($type eq 'unapi') {
 661                 $self->_create_node(
 662                         'mods:mods',
 663                         'http://www.loc.gov/mods/',
 664                         'mods:relatedItem',
 665                         undef,
 666                         { type => 'otherFormat', id => 'link-'.$linkid }
 667                 );
 668                 $self->_create_node(
 669                         "mods:mods/mods:relatedItem[\@id='link-$linkid']",
 670                         'http://www.loc.gov/mods/',
 671                         'mods:recordIdentifier',
 672                         $self->unapi .'?uri=' . $id
 673                 );
 674                 $linkid++;
 675         }
 676 }
 677
 678
 679 #----------------------------------------------------------
 680
 681 package OpenILS::WWW::SuperCat::Feed::html;
 682 use base 'OpenILS::WWW::SuperCat::Feed';
 683
 684 sub new {
 685         my $class = shift;
 686         my $self = $class->SUPER::build('<html><head/><body/></html>');
 687         $self->{type} = 'html';
 688         $self->{item_xpath} = '/html/body';
 689         return $self;
 690 }
 691
 692
 693 1;