opac/oai.pl

   1 #!/usr/bin/perl
   2
   3 use strict;
   4
   5 use C4::Context;
   6 use C4::Biblio;
   7
   8 =head1 OAI-PMH for koha
   9
  10 This file is an implementation of the OAI-PMH protocol for koha. Its purpose
  11 is to share metadata in Dublin core format with harvester like PKP-Harverster.
  12 Presently, all the bibliographic records managed by the runing koha instance
  13 are publicly shared (as the opac is).
  14
  15 =head1 Package MARC::Record::KOHADC
  16
  17 This package is a sub-class of the MARC::File::USMARC. It add methods and functions
  18 to map the content of a marc record (of any flavor) to Dublin core.
  19 As soon as it is possible, mapping between marc fields and there semantic
  20 are got from ::GetMarcFromKohaField fonction from C4::Biblio (see also the "Koha
  21 to MARC mapping" preferences).
  22
  23 =cut
  24
  25 package MARC::Record::KOHADC;
  26 use vars ('@ISA');
  27 @ISA = qw(MARC::Record);
  28
  29 use MARC::File::USMARC;
  30
  31 sub new { # Get a MAR::Record as parameter and bless it as MARC::Record::KOHADC
  32         shift;
  33         my $marc = shift;
  34         bless $marc  if( ref( $marc ) );
  35 }
  36
  37 sub subfield {
  38     my $self = shift;
  39     my ($t,$sf) = @_;
  40
  41     return $self->SUPER::subfield( @_ ) unless wantarray;
  42
  43     my @field = $self->field($t);
  44     my @list = ();
  45     my $f;
  46
  47     foreach $f ( @field ) {
  48                 push( @list, $f->subfield( $sf ) );
  49     }
  50     return @list;
  51 }
  52
  53 sub getfields {
  54 my $marc = shift;
  55 my @result = ();
  56
  57         foreach my $kohafield ( @_ ) {
  58                 my ( $field, $subfield ) = ::GetMarcFromKohaField( $kohafield, '' );
  59                 push( @result, $field < 10 ? $marc->field( $field )->as_string() : $marc->subfield( $field, $subfield ) );
  60         }
  61 #        @result>1 ? \@result : $result[0];
  62         \@result;
  63 }
  64
  65 sub XMLescape {
  66 my ($t) = shift;
  67
  68         foreach (@$t ) {
  69                 s/\&/\&amp;/g; s/</&lt;/g;
  70         }
  71         $t;
  72 }
  73
  74 sub Status {
  75   my $self = shift;
  76         undef;
  77 }
  78
  79 sub Title {
  80   my $self = shift;
  81         &XMLescape( $self->getfields('biblio.title') );
  82 }
  83
  84 sub Creator {
  85   my $self = shift;
  86         &XMLescape( $self->getfields('biblio.author') );
  87 }
  88
  89 sub Subject {
  90   my $self = shift;
  91         &XMLescape( $self->getfields('bibliosubject.subject') );
  92 }
  93
  94 sub DateStamp {
  95   my $self = shift;
  96         my ($d,$h) = split( ' ', $self->{'biblio.timestamp'} );
  97         $d . "T" . $h . "Z";
  98 }
  99
 100 sub Date {
 101   my $self = shift;
 102     my ($str) = @{$self->getfields('biblioitems.publicationyear')};
 103     my ($y,$m,$d) = (substr($str,0,4), substr($str,4,2), substr($str,6,2));
 104
 105     $y=1970 unless($y>0); $m=1 unless($m>0); $d=1 unless($d>0);
 106
 107     sprintf( "%.4d-%.2d-%.2d", $y,$m,$d);
 108 }
 109
 110 sub Description {
 111   my $self = shift;
 112         undef;
 113 }
 114
 115 sub Identifier {
 116   my $self = shift;
 117   my $id = $self->getfields('biblio.biblionumber')->[0];
 118
 119 # get url of this script and assume that OAI server is in the same place as opac-detail script
 120 # and build a direct link to the record.
 121   my $uri = $ENV{'SCRIPT_URI'};
 122   $uri= "http://" . $ENV{'HTTP_HOST'} . $ENV{'REQUEST_URI'} unless( $uri ); # SCRIPT_URI doesn't exist on all httpd server
 123   $uri =~ s#[^/]+$##;
 124         [
 125                 C4::Context->preference("OAI-PMH:archiveID") .":" .$id,
 126                 "${uri}opac-detail.pl?bib=$id",
 127                 @{$self->getfields('biblioitems.isbn', 'biblioitems.issn')}
 128         ];
 129 }
 130
 131 sub Language {
 132   my $self = shift;
 133         undef;
 134 }
 135
 136 sub Type {
 137   my $self = shift;
 138         &XMLescape( $self->getfields('biblioitems.itemtype') );
 139 }
 140
 141 sub Publisher {
 142   my $self = shift;
 143         &XMLescape( $self->getfields('biblioitems.publishercode') );
 144 }
 145
 146 sub Set {
 147 my $set = &OAI::KOHA::Set();
 148         [ map( $_=$_->[0], @$set) ];
 149 }
 150
 151 =head1 The OAI::KOHA package
 152
 153 This package is a subclass of the OAI::DC data provider. It overides needed methods
 154 and provide the links between the OAI-PMH request and the koha application.
 155 The data used in answers are from the koha table I<bibio>.
 156
 157 =cut
 158
 159 package OAI::KOHA;
 160
 161 use C4::OAI::DC;
 162 use vars ('@ISA');
 163 @ISA = ("C4::OAI::DC");
 164
 165 =head2 Set
 166
 167 return the Set list to the I<verb=ListSets> query. Data are from the 'OAI-PMH:Set' preference.
 168
 169 =cut
 170
 171 sub Set {
 172 #   [
 173 #       ['BRISE','Experimental unimarc set for BRISE network'],
 174 #       ['BRISE:EMSE','EMSE set in BRISE network']
 175 #   ];
 176 #
 177 # A blinder correctement
 178         [ map( $_ = [ split(",", $_)], split( "\n",C4::Context->preference("OAI-PMH:Set") ) ) ];
 179 }
 180
 181 =head2 new
 182
 183 The new method is the constructor for this class. It doesn't have any parameters and
 184 get required data from koha preferences. Koha I<LibraryName> is used to identify the
 185 OAI-PMH repository, I<OAI-PMH:MaxCount> is used to set the maximun number of records
 186 returned at the same time in answers to I<verb=ListRecords> or I<verb=ListIdentifiers>
 187 queries.
 188
 189 The method return a blessed reference.
 190
 191 =cut
 192
 193 # constructor
 194 sub new
 195 {
 196    my $classname = shift;
 197    my $self = $classname->SUPER::new ();
 198
 199    # set configuration
 200    $self->{'repositoryName'} = C4::Context->preference("LibraryName");
 201    $self->{'MaxCount'} = C4::Context->preference("OAI-PMH:MaxCount");
 202    $self->{'adminEmail'} = C4::Context->preference("KohaAdminEmailAddress");
 203
 204    bless $self, $classname;
 205    return $self;
 206 }
 207
 208 =head2 dispose
 209
 210 The dispose method is used as a destructor. It call just the SUPER::dispose method.
 211
 212 =cut
 213
 214 # destructor
 215 sub dispose
 216 {
 217    my ($self) = @_;
 218    $self->SUPER::dispose ();
 219 }
 220
 221 # now date
 222 sub now {
 223 my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday) = gmtime( time );
 224
 225         sprintf( "%.4d-%.2d-%.2d", $year+1900, $mon+1,$mday );
 226 }
 227
 228 # build the resumptionTocken fom ($metadataPrefix,$offset,$from,$until)
 229
 230 =head2 buildResumptionToken and parseResumptionToken
 231
 232 Theses two functions are used to manage resumption tokens. The choosed syntax is simple as
 233 possible, a token is only the metadata prefix, the offset in the full answer, the from and
 234 the until date (in the yyyy-mm-dd format) joined by ':' caracter.
 235
 236 I<buildResumptionToken> get the four elements as parameters and return the ':' separated
 237 string.
 238
 239 I<parseResumptionToken> is used to set the default values to the from and until date, the
 240 metadata prefix using the resumption tocken if necessary. This function have four parameters
 241 (from,until,metadata prefix and resumption tocken) which can be undefined and return every
 242 time this list of values correctly set. The missing values are set with defaults: offset=0,
 243 from= 1970-01-01 and until is set to current date.
 244
 245 =cut
 246
 247 sub buildResumptionToken {
 248         join( ':', @_ );
 249 }
 250
 251 # parse the resumptionTocken
 252 sub parseResumptionToken {
 253 my ($from, $until, $metadataPrefix, $resumptionToken) = @_;
 254 my $offset = 0;
 255
 256         if( $resumptionToken ) {
 257                 ($metadataPrefix,$offset,$from,$until) = split( ':', $resumptionToken );
 258         }
 259
 260         $from  = "1970-01-01" unless( $from );
 261         $until = &now unless( $until );
 262         ($metadataPrefix, $offset, $from, $until );
 263 }
 264
 265 =head2 Archive_ListSets
 266
 267 return the full list Set to the I<verb=ListSets> query. Data are from the 'OAI-PMH:Set' preference.
 268
 269 =cut
 270
 271 # get full list of sets from the archive
 272 sub Archive_ListSets
 273 {
 274         &Set();
 275 }
 276
 277 =head2 Archive_GetRecord
 278
 279 This method select the record specified as its first parameter from the koha I<biblio>
 280 table and return a reference to a MARC::Record::KOHADC object.
 281
 282 =cut
 283
 284 # get a single record from the archive
 285 sub Archive_GetRecord
 286 {
 287    my ($self, $identifier, $metadataFormat) = @_;
 288    my $dbh = C4::Context->dbh;
 289    my $sth = $dbh->prepare("SELECT biblionumber,timestamp FROM biblio WHERE biblionumber=?");
 290    my $prefixID = C4::Context->preference("OAI-PMH:archiveID"); $prefixID=qr{$prefixID:};
 291
 292    $identifier =~ s/^$prefixID//;
 293
 294    $sth->execute( $identifier );
 295
 296    if( my $r = $sth->fetchrow_hashref() ) {
 297         my $marc = new MARC::Record::KOHADC( ::GetMarcBiblio( $identifier ) );
 298         if( $marc ) {
 299                 $marc->{'biblio.timestamp'} = $r->{'timestamp'};
 300                 return $marc ;
 301         }
 302         else {
 303                 warn("Archive_GetRecord : no MARC record for " . C4::Context->preference("OAI-PMH:archiveID") . ":" . $identifier);
 304         }
 305    }
 306
 307    $self->AddError ('idDoesNotExist', 'The value of the identifier argument is unknown or illegal in this repository');
 308    undef;
 309 }
 310
 311 =head2 Archive_ListRecords
 312
 313 This method return a list of 'MaxCount' references to MARC::Record::KOHADC object build from the
 314 koha I<biblio> table according to its parameters : set, from and until date, metadata prefix
 315 and resumption token.
 316
 317 =cut
 318
 319 # list metadata records from the archive
 320 sub Archive_ListRecords
 321 {
 322    my ($self, $set, $from, $until, $metadataPrefix, $resumptionToken) = @_;
 323
 324    my @allrows = ();
 325    my $marc;
 326    my $offset;
 327    my $tokenInfo;
 328    my $dbh = C4::Context->dbh;
 329    my $sth = $dbh->prepare("SELECT biblionumber,timestamp FROM biblio WHERE DATE(timestamp) >= ? and DATE(timestamp) <= ? LIMIT ? OFFSET ?");
 330    my $count;
 331
 332         ($metadataPrefix, $offset, $from, $until ) = &parseResumptionToken($from, $until, $metadataPrefix, $resumptionToken);
 333
 334 #warn( "Archive_ListRecords : $set, $from, $until, $metadataPrefix, $resumptionToken\n");
 335         $sth->execute( $from,$until,$self->{'MaxCount'}?$self->{'MaxCount'}:100000, $offset );
 336
 337         while( my $r = $sth->fetchrow_hashref() ) {
 338                 my $marc = new MARC::Record::KOHADC( ::GetMarcBiblio( $r->{'biblionumber'} ) );
 339                 unless( $marc ) { # somme time there is problems within koha, and we can't get valid marc record
 340                         warn("Archive_ListRecords : no MARC record for " . C4::Context->preference("OAI-PMH:archiveID") .":" . $r->{'biblionumber'} );
 341                         next;
 342                 }
 343                 $marc->{'biblio.timestamp'} = $r->{'timestamp'};
 344                 push( @allrows, $marc );
 345         }
 346
 347         $sth = $dbh->prepare("SELECT count(*) FROM biblioitems WHERE DATE(timestamp) >= ? and DATE(timestamp) <= ?");
 348         $sth->execute($from, $until);
 349         ( $count ) = $sth->fetchrow_array();
 350
 351         unless( @allrows ) {
 352                 $self->AddError ('noRecordsMatch', 'The combination of the values of arguments results in an empty set');
 353         }
 354
 355         if( $offset + $self->{'MaxCount'} < $count ) { # Not at the end
 356                 $offset = $offset + $self->{'MaxCount'};
 357                 $resumptionToken = &buildResumptionToken($metadataPrefix,$offset,$from,$until);
 358                 $tokenInfo = { 'completeListSize' => $count, 'cursor' => $offset };
 359         }
 360         else {
 361                 $resumptionToken = '';
 362                 $tokenInfo = {};
 363         }
 364         ( \@allrows, $resumptionToken, $metadataPrefix, $tokenInfo );
 365 }
 366
 367 package main;
 368
 369 =head1 Main package
 370
 371 The I<main> function is the starting point of the service. The first step is
 372 to verify if the service is enable using the 'OAI-PMH' preference value
 373 (See Koha systeme preferences).
 374
 375 If the service is enable, it create a new instance of the OAI::KOHA data
 376 provider (see before) and run the service.
 377
 378 =cut
 379
 380 sub disable {
 381         print "Status:404 OAI-PMH service is disabled\n";
 382         print "Content-type: text/plain\n\n";
 383
 384         print "OAI-PMH service is disable.\n";
 385 }
 386
 387 sub main
 388 {
 389    return &disable() unless( C4::Context->preference('OAI-PMH') );
 390
 391    my $OAI = new OAI::KOHA();
 392    $OAI->Run;
 393    $OAI->dispose;
 394 }
 395
 396 main;
 397
 398 1;