From 90b69c9e4078f7aa6c48717ba32dbaf0108677d2 Mon Sep 17 00:00:00 2001 From: Paul POULAIN Date: Tue, 26 Feb 2008 09:30:20 +1300 Subject: [PATCH] OAI-PMH second try Signed-off-by: Chris Cormack Signed-off-by: Joshua Ferraro --- C4/OAI/DC.pm | 233 +++++ C4/OAI/DP.pm | 901 ++++++++++++++++++ C4/OAI/Utility.pm | 204 ++++ admin/systempreferences.pl | 8 + .../data/mysql/en/mandatory/sysprefs.sql | 6 + .../unimarc_standard_systemprefs.sql | 5 + installer/data/mysql/updatedatabase.pl | 12 +- .../prog/en/includes/sysprefs-menu.inc | 1 + .../intranet-tmpl/prog/en/modules/about.tmpl | 7 +- opac/oai.pl | 379 ++++++++ 10 files changed, 1751 insertions(+), 5 deletions(-) create mode 100644 C4/OAI/DC.pm create mode 100644 C4/OAI/DP.pm create mode 100644 C4/OAI/Utility.pm create mode 100755 opac/oai.pl diff --git a/C4/OAI/DC.pm b/C4/OAI/DC.pm new file mode 100644 index 0000000000..4c9eca50e7 --- /dev/null +++ b/C4/OAI/DC.pm @@ -0,0 +1,233 @@ +# --------------------------------------------------------------------- +# Dublin Core helper class +# v1.0 +# January 2007 +# ------------------+-------------------------------------------------- +# Ph. Jaillon | +# ------------------+----------------------+--------------------------- +# Department of Computer Science | +# -----------------------------------------+-------------+------------- +# Ecole Nationale Superieure des Mines de St-Etienne | www.emse.fr +# -------------------------------------------------------+------------- + +=head1 OAI::DC Dublin Core formating helper + +OAI::DC is an helper class for Dublin Core metadata. As Dublin Core have a well known +set of fields, OAI::DC is a subclass of the OAI::DP class and it implements a default +behavior to build correct answers. The data references returned by Archive_GetRecord +and Archive_ListRecords must be instance providing the following method (they are used +to translate your own data to Dublin Core) : Title(), Identifier(), Subject(), Creator(), +Date(), Description(), Publisher(), Language() and Type(). The semantic of these methods is +the same as the corresponding Dublin Core field. + +To return correct metadata, you must provide or overide theses methods: + +=over + +=over + +=item B: initialization step, + +=item B: clean up step, + +=item B: return list of defined sets, + +=item B: return a record, + +=item B: return a list of records, + +=item B: return a list of record identifiers, + +=back + +=back + +=head2 new + +=over + +Object of this method is to build a new instance of your OAI data provider. At this step +you can overide somme default information about the repository, you can also initiate +connexion to a database... Parameters to the new method are user defined. + +=back + +=head2 dispose + +=over + +It's time to disconnect from database (if required). Must explicitly call SUPER::dispose(). + +=back + +=head2 Archive_ListSets + +=over + +Return a reference to an array of list set. Each list set is a reference to a two element array. +The first element is the set name of the set and the second is its short description. + + sub Archive_ListSets { + [ + [ 'SET1', 'Description of the SET1'], + [ 'SET2', 'Description of the SET2'], + ]; + } + +=back + +=head2 Archive_GetRecord + +=over + +This method take a record identifier and metadata format as parameter. It must return a reference to +the data associated to identifier. Data are reference to a hash and must provide methodes describe +at the begining of DC section. + +=back + +=head2 Archive_ListRecords + +=over + +Object of this method is to return a list of records occording to the user query. Parameters of the method +are the set, the from date, the until date, the metadata type required and a resumption token if supported. + +The method must return a reference to a list of records, the metadata type of the answer and reference to +token information. Token information must be undefined or a reference to a hash with the I +and the I keys set. + +=back + +=cut + +package C4::OAI::DC; + +use Encode; +use C4::OAI::DP; +use vars ('@ISA'); +@ISA = ("C4::OAI::DP"); + +# format DC record +sub FormatDC +{ + my ($self, $hashref) = @_; + + return undef if( $hashref->Status() eq 'deleted' ); + + { + title => $hashref->Title(), + identifier => $hashref->Identifier(), + subject => $hashref->Subject(), + creator => $hashref->Creator(), + date => $hashref->Date(), + description => $hashref->Description(), + publisher => $hashref->Publisher(), + language => $hashref->Language(), + type => $hashref->Type(), + mdorder => [ qw (title creator subject description contributor publisher date type format identifier source language relation coverage rights) ] + }; +} + +# format header for ListIdentifiers +sub Archive_FormatHeader +{ + my ($self, $hashref, $metadataFormat) = @_; + + $self->FormatHeader ($hashref->Identifier()->[0] , + $hashref->DateStamp(), + '', + $hashref->Set() + ); +} + +# retrieve records from the source archive as required +sub Archive_FormatRecord +{ + my ($self, $hashref, $metadataFormat) = @_; + + if ($self->MetadataFormatisValid ($metadataFormat) == 0) + { + $self->AddError ('cannotDisseminateFormat', 'The value of metadataPrefix ('.$metadataFormat.') is not supported by the repository'); + return ''; + } + + my $dc = $self->FormatDC ($hashref); + my $header = "\n"; + my $footer = "\n"; + my $metadata = ''; + + $metadata = $header . encode("utf8", decode( "iso-8859-1",$self->{'utility'}->FormatXML($dc))) . $footer if( $dc ); + + $self->FormatRecord ($hashref->Identifier()->[0] , + $hashref->DateStamp(), + $hashref->Status(), + $hashref->Set(), + $metadata, + '', + ); +} + + +# get full list of mdps or list for specific identifier +sub Archive_ListMetadataFormats +{ + my ($self, $identifier) = @_; + + if ((! defined $identifier) || ($identifier eq '')) { + return ['oai_dc']; + } + else { + $self->AddError ('idDoesNotExist', 'The value of the identifier argument is unknown or illegal in this repository'); + } + return []; +} + + +# get full list of sets from the archive +sub Archive_ListSets +{ + []; +} + + +# get a single record from the archive +sub Archive_GetRecord +{ + my ($self, $identifier, $metadataFormat) = @_; + + $self->AddError ('idDoesNotExist', 'The value of the identifier argument is unknown or illegal in this repository'); + undef; +} + +# list metadata records from the archive +sub Archive_ListRecords +{ + my ($self, $set, $from, $until, $metadataPrefix, $resumptionToken) = @_; + my $tokenInfo = undef; + + $self->AddError ('noRecordsMatch', 'The combination of the values of arguments results in an empty set'); + ( [], $resumptionToken, $metadataPrefix, $tokenInfo ); +} + + +# list identifiers (headers) from the archive +sub Archive_ListIdentifiers +{ + my ($self, $set, $from, $until, $metadataPrefix, $resumptionToken) = @_; + + if (($metadataPrefix ne '') && ($self->MetadataFormatisValid ($metadataPrefix) == 0)) + { + $self->AddError ('cannotDisseminateFormat', 'The value of metadataPrefix ('.$metadataPrefix.')is not supported by the repository'); + return ''; + } + + $self->Archive_ListRecords ($set, $from, $until, $metadataPrefix, $resumptionToken); +} + +1; + diff --git a/C4/OAI/DP.pm b/C4/OAI/DP.pm new file mode 100644 index 0000000000..d67a85410e --- /dev/null +++ b/C4/OAI/DP.pm @@ -0,0 +1,901 @@ +# --------------------------------------------------------------------- +# OAI Data Provider template (OAI-PMH v2.0) +# v3.05 +# June 2002 +# ------------------+--------------------+----------------------------- +# Hussein Suleman | hussein@vt.edu | www.husseinsspace.com +# ------------------+--------------------+-+--------------------------- +# Department of Computer Science | www.cs.vt.edu +# Digital Library Research Laboratory | www.dlib.vt.edu +# -----------------------------------------+-------------+------------- +# Virginia Polytechnic Institute and State University | www.vt.edu +# -------------------------------------------------------+------------- + +$VERSION = '1.0.0'; + +package C4::OAI::DP; + +=head1 OAI::DP OAI Data Provider + +This module provide a full implementation of the OAI-PMH v2 protocol +specification (http://www.openarchives.org/OAI/openarchivesprotocol.html). + +It is simple to use, to answer to OAI-PMH requests you must create a new OAI::DP +instance and call its run() method. + +This new instance is an instance of a subclass of the OAI::DP class and the job +of this subclass is to manage data and to format answers according to the meta data +model used (see OAI::DC for an example). + +Tipical OAI service looks like: + + my $OAI = new A_OAI_SUBCLASS(some parameters); + + $OAI->run(); + $OAI->dispose(); + +=cut + +use POSIX; + +use CGI; +use C4::OAI::Utility; + + +# constructor +sub new +{ + my ($classname) = @_; + + my $self = { + class => $classname, + xmlnsprefix => 'http://www.openarchives.org/OAI/2.0/', + protocolversion => '2.0', + repositoryName => 'NoName Repository', + adminEmail => 'someone@somewhere.org', + granularity => 'YYYY-MM-DD', + deletedRecord => 'no', + metadatanamespace => { + oai_dc => 'http://www.openarchives.org/OAI/2.0/oai_dc/', + }, + metadataschema => { + oai_dc => 'http://www.openarchives.org/OAI/2.0/oai_dc.xsd', + }, + metadataroot => { + oai_dc => 'dc', + }, + metadatarootparameters => { + oai_dc => '', + }, + utility => new C4::OAI::Utility, + error => [], + }; + + bless $self, $classname; + return $self; +} + + +# destructor +sub dispose +{ + my ($self) = @_; +} + + +# output XML HTTP header +sub xmlheader +{ + my ($self) = @_; + + # calculate timezone automatically + my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst)=gmtime (time); + my $timezone = 'Z'; + my $datestring = sprintf ("%04d-%02d-%02dT%02d:%02d:%02d%s", + $year+1900, $mon+1, $mday, $hour, $min, $sec, + $timezone); + + # make error strings + my $errors = ''; + my $fullrequest = 1; + foreach my $error (@{$self->{'error'}}) + { + $errors .= "[0]\">$error->[1]\n"; + if (($error->[0] eq 'badVerb') || ($error->[0] eq 'badArgument')) + { + $fullrequest = 0; + } + } + + # add verb container if no errors + my $verbcontainer = ''; + if ($#{$self->{'error'}} == -1) + { + $verbcontainer = '<'.$self->{'verb'}.">\n"; + } + + # compute request element with its parameters included if necessary + my $request = '{'cgi'}->param) + { + $request .= " $param=\"".$self->{'cgi'}->param ($param)."\""; + } + } + $request .= '>'.$self->{'cgi'}->{'baseURL'}.''; + + "Content-type: text/xml\n\n". + "\n\n". + "{'xmlnsprefix'}\" ". + "xmlns:xsi=\"http://www.w3.org/2001/XMLSchema-instance\" ". + "xsi:schemaLocation=\"$self->{'xmlnsprefix'} ". + "$self->{'xmlnsprefix'}OAI-PMH.xsd\">\n\n". + "$datestring\n". + $request."\n\n". + $errors. + $verbcontainer; +} + + +# output XML HTTP footer +sub xmlfooter +{ + my ($self) = @_; + + # add verb container if no errors + my $verbcontainer = ''; + if ($#{$self->{'error'}} == -1) + { + $verbcontainer = '{'verb'}.">\n"; + } + + $verbcontainer. + "\n\n"; +} + + +# add an error to the running list of errors (if its not there already) +sub AddError +{ + my ($self, $errorcode, $errorstring) = @_; + + my $found = 0; + foreach my $error (@{$self->{'error'}}) + { + if (($error->[0] eq $errorcode) && ($error->[1] eq $errorstring)) + { $found = 1 }; + } + + if ($found == 0) + { + push (@{$self->{'error'}}, [ $errorcode, $errorstring ] ); + } +} + + +# create an error and output response +sub Error +{ + my ($self, $errorcode, $errorstring) = @_; + + $self->AddError ($errorcode, $errorstring); + $self->xmlheader.$self->xmlfooter; +} + + +# check for the validity of the date according to the OAI spec +sub DateisValid +{ + my ($self, $date) = @_; + + my ($year, $month, $day, $hour, $minute, $second); + + if ($date =~ /^([0-9]{4})-([0-9]{2})-([0-9]{2})/) + { + $year = $1; + if ($year <= 0) + { return 0; } + + $month = $2; + if (($month <= 0) || ($month > 12)) + { return 0; } + + $day = $3; + my $daysinmonth; + if ((((($year % 4) == 0) && (($year % 100) != 0)) || (($year % 400) == 0)) + && ($month == 2)) + { $daysinmonth = 29; } + elsif (($month == 4) || ($month == 6) || ($month == 9) || ($month == 11)) + { $daysinmonth = 30; } + elsif ($month == 2) + { $daysinmonth = 28; } + else + { $daysinmonth = 31; } + if (($day <= 0) || ($day > $daysinmonth)) + { return 0; } + } + else + { return 0; } + + if ($date =~ /^[0-9]{4}-[0-9]{2}-[0-9]{2}T([0-9]{2}):([0-9]{2}):([0-9]{2})Z$/) + { + $hour = $1; + $minute = $2; + if (($hour < 0) || ($hour > 23) || ($minute < 0) || ($minute > 59)) + { return 0; } + + $second = $3; + if (($second < 0) || ($second > 59)) + { return 0; } + } + elsif (length ($date) > 10) + { return 0; } + + return 1; +} + + +# check that the granularity is ok +sub GranularityisValid +{ + my ($self, $date1, $date2) = @_; + + my $granularity = $self->{'granularity'}; + + if (($granularity ne 'YYYY-MM-DDThh:mm:ssZ') && (length ($date1) > 10)) + { + return 0; + } + if (defined $date2) + { + if (($granularity ne 'YYYY-MM-DDThh:mm:ssZ') && (length ($date2) > 10)) + { + return 0; + } + if (length ($date1) != length ($date2)) + { + return 0; + } + } + + return 1; +} + + +# check for bad arguments +sub ArgumentisValid +{ + my ($self) = @_; + + my %required = ( + 'Identify' => [], + 'ListSets' => [], + 'ListMetadataFormats' => [], + 'ListIdentifiers' => [ 'metadataPrefix' ], + 'GetRecord' => [ 'identifier', 'metadataPrefix' ], + 'ListRecords' => [ 'metadataPrefix' ] + ); + my %optional = ( + 'Identify' => [], + 'ListSets' => [], + 'ListMetadataFormats' => [ 'identifier' ], + 'ListIdentifiers' => [ 'set', 'from', 'until', 'resumptionToken' ], + 'GetRecord' => [], + 'ListRecords' => [ 'set', 'from', 'until', 'resumptionToken' ] + ); + + # get parameter lists + my $verb = $self->{'cgi'}->param ('verb'); + my @parmsrequired = @{$required{$verb}}; + my @parmsoptional = @{$optional{$verb}}; + my @parmsall = (@parmsrequired, @parmsoptional); + my @names = $self->{'cgi'}->param; + my %paramhash = (); + foreach my $name (@names) + { + $paramhash{$name} = 1; + } + + # check for required parameters + foreach my $name (@parmsrequired) + { + if ((! exists $paramhash{$name}) && + ((($verb ne 'ListIdentifiers') && ($verb ne 'ListRecords')) || + (! exists $paramhash{'resumptionToken'}))) + { + return $self->Error ('badArgument', "missing $name parameter"); + } + } + + # check for illegal parameters + foreach my $name (@names) + { + my $found = 0; + foreach my $name2 (@parmsall) + { + if ($name eq $name2) + { $found = 1; } + } + if (($found == 0) && ($name ne 'verb')) + { + return $self->Error ('badArgument', "$name is an illegal parameter"); + } + } + + # check for duplicate parameters + foreach my $name (@names) + { + my @values = $self->{'cgi'}->param ($name); + if ($#values != 0) + { + return $self->Error ('badArgument', "multiple values are not allowed for the $name parameter"); + } + } + + # check for resumptionToken exclusivity + if ((($verb eq 'ListIdentifiers') || ($verb eq 'ListRecords')) && + (exists $paramhash{'resumptionToken'}) && + ($#names > 1)) + { + return $self->Error ('badArgument', 'resumptionToken cannot be combined with other parameters'); + } + + return ''; +} + + +# convert date/timestamp into seconds for comparisons +sub ToSeconds +{ + my ($self, $date, $from) = @_; + + my ($month, $day, $hour, $minute, $second); + + if ((defined $from) && ($from == 1)) + { + ($month, $day, $hour, $minute, $second) = (1, 1, 0, 0, 0); + } + else + { + ($month, $day, $hour, $minute, $second) = (12, 31, 23, 59, 59); + } + + if ($date =~ /([0-9]{4})-([0-9]{2})-([0-9]{2})T([0-9]{2}):([0-9]{2}):([0-9]{2})Z/) + { + return mktime ($6, $5, $4, $3, $2-1, $1-1900); + } + elsif ($date =~ /([0-9]{4})-([0-9]{2})-([0-9]{2})/) + { + return mktime ($second, $minute, $hour, $3, $2-1, $1-1900); + } + else + { + return 0; + } +} + + +# check if the metadata format is valid +sub MetadataFormatisValid +{ + my ($self, $metadataFormat) = @_; + + my $found = 0; + foreach my $i (keys %{$self->{'metadatanamespace'}}) + { + if ($metadataFormat eq $i) + { $found = 1; } + } + + if ($found == 1) + { return 1; } + else + { return 0; } +} + + +# format the header for a record +sub FormatHeader +{ + my ($self, $identifier, $datestamp, $status, $setSpecs) = @_; + + my $statusattribute = ''; + if ((defined $status) && ($status eq 'deleted')) + { + $statusattribute = " status=\"deleted\""; + } + + my $setstring = ''; + if (defined $setSpecs) + { + foreach my $setSpec (@$setSpecs) + { + $setstring .= ''.$setSpec."\n"; + } + } + + "\n". + "$identifier\n". + "$datestamp\n". + $setstring. + "\n"; +} + + +# format the record by encapsulating it in a "record" container +sub FormatRecord +{ + my ($self, $identifier, $datestamp, $status, $setSpecs, $metadata, $about) = @_; + + my $header = $self->FormatHeader ($identifier, $datestamp, $status, $setSpecs); + + my $output = + "\n". + $header; + + if ((defined $metadata) && ($metadata ne '')) + { + $output .= "\n$metadata\n"; + } + if ((defined $about) && ($about ne '')) + { + $output .= "\n$about\n"; + } + + $output."\n"; +} + + +# standard handler for Identify verb +sub Identify +{ + my ($self) = @_; + + my $identity = $self->Archive_Identify; + if (! exists $identity->{'repositoryName'}) + { + $identity->{'repositoryName'} = $self->{'repositoryName'}; + } + if (! exists $identity->{'adminEmail'}) + { + $identity->{'adminEmail'} = $self->{'adminEmail'}; + } + $identity->{'protocolVersion'} = $self->{'protocolversion'}; + $identity->{'baseURL'} = $self->{'cgi'}->{'baseURL'}; + if (! exists $identity->{'granularity'}) + { + $identity->{'granularity'} = $self->{'granularity'}; + } + if (! exists $identity->{'deletedRecord'}) + { + $identity->{'deletedRecord'} = $self->{'deletedRecord'}; + } + if (! exists $identity->{'earliestDatestamp'}) + { + my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst)=gmtime (0); + my $timezone = 'Z'; + my $datestring = sprintf ("%04d-%02d-%02dT%02d:%02d:%02d%s", + $year+1900, $mon+1, $mday, $hour, $min, $sec, + $timezone); + $identity->{'earliestDatestamp'} = $datestring; + } + + $identity->{'mdorder'} = [ qw ( repositoryName baseURL protocolVersion adminEmail earliestDatestamp deletedRecord granularity compression description ) ]; + + # add in description for toolkit + if (! exists $identity->{'description'}) + { + $identity->{'description'} = []; + } + my $desc = { + 'toolkit' => [[ + { + 'xmlns' => 'http://oai.dlib.vt.edu/OAI/metadata/toolkit', + 'xsi:schemaLocation' => + 'http://oai.dlib.vt.edu/OAI/metadata/toolkit '. + 'http://oai.dlib.vt.edu/OAI/metadata/toolkit.xsd' + }, + { + 'title' => 'VTOAI Perl Data Provider', + 'author' => { + 'name' => 'Hussein Suleman', + 'email' => 'hussein@vt.edu', + 'institution' => 'Virginia Tech', + 'mdorder' => [ qw ( name email institution ) ], + }, + 'version' => '3.05', + 'URL' => 'http://www.dlib.vt.edu/projects/OAI/', + 'mdorder' => [ qw ( title author version URL ) ] + } + ]] + }; + push (@{$identity->{'description'}}, $desc); + + $self->xmlheader. + $self->{'utility'}->FormatXML ($identity). + $self->xmlfooter; +} + + +# standard handler for ListMetadataFormats verb +sub ListMetadataFormats +{ + my ($self) = @_; + + my $identifier = $self->{'cgi'}->param ('identifier'); + my $metadataNamespace = $self->{'metadatanamespace'}; + my $metadataSchema = $self->{'metadataschema'}; + + my $lmf = $self->Archive_ListMetadataFormats ($identifier); + if ($#$lmf > 0) + { + $metadataNamespace = $$lmf[0]; + $metadataSchema = $$lmf[1]; + } + + my $buffer = $self->xmlheader; + if ($#{$self->{'error'}} == -1) + { + foreach my $i (keys %{$metadataNamespace}) + { + $buffer .= "\n". + "$i\n". + "$metadataSchema->{$i}\n". + "$metadataNamespace->{$i}\n". + "\n"; + } + } + $buffer.$self->xmlfooter; +} + + +# standard handler for ListSets verb +sub ListSets +{ + my ($self) = @_; + + my $setlist = $self->Archive_ListSets; + + if ($#$setlist == -1) + { + $self->AddError ('noSetHierarchy', 'The repository does not support sets'); + } + + my $buffer = $self->xmlheader; + if ($#{$self->{'error'}} == -1) + { + foreach my $item (@$setlist) + { + $buffer .= "\n". + " ".$self->{'utility'}->lclean ($$item[0])."\n". + " ".$self->{'utility'}->lclean ($$item[1])."\n"; + if (defined $$item[2]) + { + $buffer .= ''.$$item[2].''; + } + $buffer .= "\n"; + } + } + $buffer.$self->xmlfooter; +} + + +# standard handler for GetRecord verb +sub GetRecord +{ + my ($self) = @_; + + my $identifier = $self->{'cgi'}->param ('identifier'); + my $metadataPrefix = $self->{'cgi'}->param ('metadataPrefix'); + + my $recref = $self->Archive_GetRecord ($identifier, $metadataPrefix); + my $recbuffer; + if ($recref) + { + $recbuffer = $self->Archive_FormatRecord ($recref, $metadataPrefix); + } + + my $buffer = $self->xmlheader; + if ($#{$self->{'error'}} == -1) + { + $buffer .= $recbuffer; + } + $buffer.$self->xmlfooter; +} + + +# create extended resumptionToken +sub createResumptionToken +{ + my ($self, $resumptionToken, $resumptionParameters) = @_; + + my $attrs = ''; + if (defined $resumptionParameters) + { + foreach my $key (keys %{$resumptionParameters}) + { + $attrs .= " $key=\"$resumptionParameters->{$key}\""; + } + } + + if (($resumptionToken ne '') || ($attrs ne '')) + { + "$resumptionToken\n"; + } + else + { + ''; + } +} + + +# standard handler for ListRecords verb +sub ListRecords +{ + my ($self) = @_; + + my ($set, $from, $until, $metadataPrefix); + my ($resumptionToken, $allrows, $resumptionParameters); + + $resumptionToken = $self->{'cgi'}->param ('resumptionToken'); + if ($resumptionToken eq '') + { + $set = $self->{'cgi'}->param ('set'); + $from = $self->{'cgi'}->param ('from'); + $until = $self->{'cgi'}->param ('until'); + $metadataPrefix = $self->{'cgi'}->param ('metadataPrefix'); + + if ($from ne '') + { + if (!($self->DateisValid ($from))) + { return $self->Error ('badArgument', 'illegal from parameter'); } + if (!($self->GranularityisValid ($from))) + { return $self->Error ('badArgument', 'illegal granularity for from parameter'); } + } + if ($until ne '') + { + if (!($self->DateisValid ($until))) + { return $self->Error ('badArgument', 'illegal until parameter'); } + if (!($self->GranularityisValid ($until))) + { return $self->Error ('badArgument', 'illegal granularity for until parameter'); } + } + if (($from ne '') && ($until ne '') && (!($self->GranularityisValid ($from, $until)))) + { + return $self->Error ('badArgument', 'mismatched granularities in from/until'); + } + } + + ($allrows, $resumptionToken, $metadataPrefix, $resumptionParameters) = + $self->Archive_ListRecords ($set, $from, $until, $metadataPrefix, $resumptionToken); + + my $recbuffer; + foreach my $recref (@$allrows) + { + $recbuffer .= $self->Archive_FormatRecord ($recref, $metadataPrefix); + } + + my $buffer = $self->xmlheader; + if ($#{$self->{'error'}} == -1) + { + $buffer .= $recbuffer.$self->createResumptionToken ($resumptionToken, $resumptionParameters); + } + $buffer.$self->xmlfooter; +} + + +# standard handler for ListIdentifiers verb +sub ListIdentifiers +{ + my ($self) = @_; + + my ($set, $from, $until, $metadataPrefix); + my ($resumptionToken, $allrows, $resumptionParameters); + + $resumptionToken = $self->{'cgi'}->param ('resumptionToken'); + if ($resumptionToken eq '') + { + $set = $self->{'cgi'}->param ('set'); + $from = $self->{'cgi'}->param ('from'); + $until = $self->{'cgi'}->param ('until'); + $metadataPrefix = $self->{'cgi'}->param ('metadataPrefix'); + + if ($from ne '') + { + if (!($self->DateisValid ($from))) + { return $self->Error ('badArgument', 'illegal from parameter'); } + if (!($self->GranularityisValid ($from))) + { return $self->Error ('badArgument', 'illegal granularity for from parameter'); } + } + if ($until ne '') + { + if (!($self->DateisValid ($until))) + { return $self->Error ('badArgument', 'illegal until parameter'); } + if (!($self->GranularityisValid ($until))) + { return $self->Error ('badArgument', 'illegal granularity for until parameter'); } + } + if (($from ne '') && ($until ne '') && (!($self->GranularityisValid ($from, $until)))) + { + return $self->Error ('badArgument', 'mismatched granularities in from/until'); + } + } + + ($allrows, $resumptionToken, $metadataPrefix, $resumptionParameters) = + $self->Archive_ListIdentifiers ($set, $from, $until, $metadataPrefix, $resumptionToken); + + my $recbuffer = ''; + foreach my $recref (@$allrows) + { + $recbuffer .= $self->Archive_FormatHeader ($recref, $metadataPrefix); + } + + my $buffer = $self->xmlheader; + if ($#{$self->{'error'}} == -1) + { + $buffer .= $recbuffer.$self->createResumptionToken ($resumptionToken, $resumptionParameters); + } + $buffer.$self->xmlfooter; +} + + +# stub routines to get actual data from archives + + +sub Archive_FormatRecord +{ + my ($self, $recref, $metadataFormat) = @_; + + $self->FormatRecord ('identifier', + '1000-01-01', + '', + '', + $self->{'utility'}->FormatXML ({}), + $self->{'utility'}->FormatXML ({}) + ); +} + + +sub Archive_FormatHeader +{ + my ($self, $recref, $metadataFormat) = @_; + + $self->FormatHeader ('identifier', + '1000-01-01', + '', + '' + ); +} + + +sub Archive_Identify +{ + my ($self) = @_; + + {}; +} + + +sub Archive_ListSets +{ + my ($self) = @_; + + []; +} + + +sub Archive_ListMetadataFormats +{ + my ($self, $identifier) = @_; + + []; +} + + +sub Archive_GetRecord +{ + my ($self, $identifier, $metadataPrefix) = @_; + + my %records = (); + + undef; +} + + +sub Archive_ListRecords +{ + my ($self, $set, $from, $until, $metadataPrefix, $resumptionToken) = @_; + + my $results = []; + my @allrows = (); + $resumptionToken = ''; + + ( \@allrows, $resumptionToken, $metadataPrefix, {} ); +} + + +sub Archive_ListIdentifiers +{ + my ($self, $set, $from, $until, $metadataPrefix, $resumptionToken) = @_; + + my $results = []; + my @allrows = (); + $resumptionToken = ''; + + ( \@allrows, $resumptionToken, $metadataPrefix, {} ); +} + + +# main loop to process parameters and call appropriate verb handler +sub Run +{ + my ($self) = @_; + + if (! exists $self->{'cgi'}) + { +## PJ 20071021 + ##$self->{'cgi'} = new Pure::EZCGI; + $self->{'cgi'} = new CGI; + } + $self->{'verb'} = $self->{'cgi'}->param ('verb'); + + # check for illegal verb + if (($self->{'verb'} ne 'Identify') && + ($self->{'verb'} ne 'ListMetadataFormats') && + ($self->{'verb'} ne 'ListSets') && + ($self->{'verb'} ne 'ListIdentifiers') && + ($self->{'verb'} ne 'GetRecord') && + ($self->{'verb'} ne 'ListRecords')) + { + print $self->Error ('badVerb', 'illegal OAI verb'); + } + else + { + # check for illegal parameters + my $aiv = $self->ArgumentisValid; + if ($aiv ne '') + { + print $aiv; + } + else + { + # run appropriate handler procedure + if ($self->{'verb'} eq 'Identify') + { print $self->Identify; } + elsif ($self->{'verb'} eq 'ListMetadataFormats') + { print $self->ListMetadataFormats; } + elsif ($self->{'verb'} eq 'GetRecord') + { print $self->GetRecord; } + elsif ($self->{'verb'} eq 'ListSets') + { print $self->ListSets; } + elsif ($self->{'verb'} eq 'ListRecords') + { print $self->ListRecords; } + elsif ($self->{'verb'} eq 'ListIdentifiers') + { print $self->ListIdentifiers; } + } + } +} + + +1; + + +# HISTORY +# +# 2.01 +# fixed ($identifier) error +# added status to FormatRecord +# 2.02 +# added metadataPrefix to GetRecord hander +# 3.0 +# converted to OAI2.0 alpha1 +# 3.01 +# converted to OAI2.0 alpha2 +# 3.02 +# converted to OAI2.0 alpha3 +# 3.03 +# converted to OAI2.0 beta1 +# 3.04 +# converted to OAI2.0 beta2 +# added better argument handling +# 3.05 +# polished for OAI2.0 diff --git a/C4/OAI/Utility.pm b/C4/OAI/Utility.pm new file mode 100644 index 0000000000..a4c9812e70 --- /dev/null +++ b/C4/OAI/Utility.pm @@ -0,0 +1,204 @@ +# --------------------------------------------------------------------- +# Utility routines for cleaning and formatting XML related to OAI +# v1.1 +# January 2002 +# ------------------+--------------------+----------------------------- +# Hussein Suleman | hussein@vt.edu | www.husseinsspace.com +# ------------------+--------------------+-+--------------------------- +# Department of Computer Science | www.cs.vt.edu +# Digital Library Research Laboratory | www.dlib.vt.edu +# -----------------------------------------+-------------+------------- +# Virginia Polytechnic Institute and State University | www.vt.edu +# -------------------------------------------------------+------------- + + +package C4::OAI::Utility; + + +# constructor [create mapping for latin entities to Unicode] +sub new +{ + my $classname = shift; + + my $self = { XMLindent => ' ' }; + + my @upperentities = qw (nbsp iexcl cent pound curren yen brvbar sect + uml copy ordf laquo not 173 reg macr deg plusmn + sup2 sup3 acute micro para middot cedil supl + ordm raquo frac14 half frac34 iquest Agrave + Aacute Acirc Atilde Auml Aring AElig Ccedil + Egrave Eacute Ecirc Euml Igrave Iacute Icirc + Iuml ETH Ntilde Ograve Oacute Ocirc Otilde Ouml + times Oslash Ugrave Uacute Ucirc Uuml Yacute + THORN szlig agrave aacute acirc atilde auml + aring aelig ccedil egrave eacute ecirc euml + igrave iacute icirc iuml eth ntilde ograve + oacute ocirc otilde ouml divide oslash ugrave + uacute ucirc uuml yacute thorn yuml); + $upperentities[12] = '#173'; + + $self->{'hashentity'} = {}; + for ( my $i=0; $i<=$#upperentities; $i++ ) + { + my $key = '&'.$upperentities[$i].';'; + $self->{'hashentity'}->{$key}=$i+160; + } + + $self->{'hashstr'} = (join (';|', @upperentities)).';'; + + bless $self, $classname; + return $self; +} + + +# clean XML version one - for paragraphs +sub pclean +{ + my ($self, $t) = @_; + return undef if (! defined $t); + # make ISOlat1 entities into Unicode character entities + $t =~ s/&($self->{'hashstr'})/sprintf ("&#x%04X;", $self->{'hashentity'}->{$&})/geo; + # escape non-XML-encoded ampersands (including from other characters sets) + $t =~ s/&(?!((#[0-9]*)|(#x[0-9]*)|(amp)|(lt)|(gt)|(apos)|(quot));)/&/go; + # convert extended ascii into Unicode character entities + $t =~ s/[\xa0-\xff]/'&#'.ord ($&).';'/geo; + # remove extended ascii that doesnt translate into ISO8859/1 + $t =~ s/[\x00-\x08\x0B\x0C\x0E-\x1f\x80-\x9f]//go; + # make tags delimiters into entities + $t =~ s//>/go; + # convert any whitespace containing lf or cr into a single cr + $t =~ s/(\s*[\r\n]\s+)|(\s+[\r\n]\s*)/\n/go; + # convert multiples spaces/tabs into a single space + $t =~ s/[ \t]+/ /go; + # kill leading and terminating spaces + $t =~ s/^[ ]+(.+)[ ]+$/$1/; + return $t; +} + + +# clean XML version two - for single-line streams +sub lclean +{ + my ($self, $t) = @_; + return undef if (! defined $t ); + # make ISOlat1 entities into Unicode character entities + $t =~ s/&($self->{'hashstr'})/sprintf ("&#x%04X;", $self->{'hashentity'}->{$&})/geo; + # escape non-XML-encoded ampersands (including from other characters sets) + $t =~ s/&(?!((#[0-9]*)|(#x[0-9]*)|(amp)|(lt)|(gt)|(apos)|(quot));)/&/go; + # convert extended ascii into Unicode character entities + $t =~ s/[\xa0-\xff]/'&#'.ord ($&).';'/geo; + # remove extended ascii that doesnt translate into ISO8859/1 + $t =~ s/[\x00-\x08\x0B\x0C\x0E-\x1f\x80-\x9f]//go; + # make tags delimiters into entities + $t =~ s//>/go; + # flatten whitespace + $t =~ s/[\s\t\r\n]+/ /go; + # kill leading and terminating spaces + $t =~ s/^[ ]+(.+)[ ]+$/$1/; + return $t; +} + + +# remove newlines and carriage returns +sub straighten +{ + my ($self, $t) = @_; + # eliminate all carriage returns and linefeeds + $t =~ s/[\t\r\s\n]+/ /go; + return $t; +} + + +# convert a data structure in Perl to XML +# format of $head: +# { +# tag1 => [ +# [ +# { attr1 => val1, attr2 => val2, ... }, +# { children } +# ], +# [ +# { attr1 => val1, attr2 => val2, ... }, +# "text string" +# ], +# { children }, +# "text string" +# ], +# tag2 => { children }, +# tag3 => "text string", +# mdorder => [ "tag1", "tag2", "tag3" ] +# } +# +sub FormatXML +{ + my ($self, $head, $indent) = @_; + $indent .= $self->{'XMLindent'}; + my ($key, $i, $j, $buffer, @orderedkeys); + $buffer = ''; + if (exists ($head->{'mdorder'})) + { @orderedkeys = @{$head->{'mdorder'}}; } + else + { @orderedkeys = keys %$head; } + foreach $key (@orderedkeys) + { + if ((exists ($head->{$key})) && (ref ($head->{$key}) eq 'ARRAY')) + { + foreach $i (@{$head->{$key}}) + { + if (ref ($i) eq 'ARRAY') + { + my $atthash = $$i[0]; + my $childhash = $$i[1]; + + $buffer .= "$indent<$key"; + foreach $j (keys %$atthash) + { + $buffer .= " $j=\"$atthash->{$j}\""; + } + $buffer .= ">\n"; + + if (ref ($childhash) eq 'HASH') + { + $buffer .= $self->FormatXML ($childhash, $indent); + } + else + { + $buffer .= "$indent$childhash\n"; + } + + $buffer .= "$indent\n"; + } + elsif (ref ($i) eq 'HASH') + { + my $nestedbuffer = $self->FormatXML ($i, $indent); + if ($nestedbuffer ne '') + { + $buffer .= "$indent<$key>\n$nestedbuffer$indent\n"; + } + } + else + { + $buffer .= "$indent<$key>$i\n"; + } + } + } + elsif ((exists ($head->{$key})) && (ref ($head->{$key}) eq 'HASH')) + { + my $nestedbuffer = $self->FormatXML ($head->{$key}, $indent); + if ($nestedbuffer ne '') + { + $buffer .= "$indent<$key>\n$nestedbuffer$indent\n"; + } + } + elsif ((exists ($head->{$key})) && ($head->{$key} ne '')) + { + $buffer .= "$indent<$key>$head->{$key}\n"; + } + } + $buffer; +} + + +1; diff --git a/admin/systempreferences.pl b/admin/systempreferences.pl index 1804a535a8..8d6219f8f1 100755 --- a/admin/systempreferences.pl +++ b/admin/systempreferences.pl @@ -263,6 +263,14 @@ my %tabsysprefs; $tabsysprefs{LetterLog} = "LOGFeatures"; $tabsysprefs{FinesLog} = "LOGFeatures"; +# OAI-PMH variables + $tabsysprefs{'OAI-PMH'} = "OAI-PMH"; + $tabsysprefs{'OAI-PMH:archiveID'} = "OAI-PMH"; + $tabsysprefs{'OAI-PMH:MaxCount'} = "OAI-PMH"; + $tabsysprefs{'OAI-PMH:Set'} = "OAI-PMH"; + $tabsysprefs{'OAI-PMH:Subset'} = "OAI-PMH"; + + sub StringSearch { my ($searchstring,$type)=@_; my $dbh = C4::Context->dbh; diff --git a/installer/data/mysql/en/mandatory/sysprefs.sql b/installer/data/mysql/en/mandatory/sysprefs.sql index abdf59022e..8bac4b1c1a 100644 --- a/installer/data/mysql/en/mandatory/sysprefs.sql +++ b/installer/data/mysql/en/mandatory/sysprefs.sql @@ -174,3 +174,9 @@ INSERT INTO `systempreferences` (variable,value,explanation,options,type) VALUES INSERT INTO `systempreferences` (variable,value,explanation,options,type) VALUES('PatronsPerPage','20','Number of Patrons Per Page displayed by default','20','Integer'); INSERT INTO `systempreferences` (variable,value,explanation,options,type) VALUES('HomeOrHoldingBranch','holdingbranch','Used by Circulation to determine which branch of an item to check with independent branches on, and by search to determine which branch to choose for availability ','holdingbranch|homebranch','Choice'); INSERT INTO `systempreferences` (variable,value,explanation,options,type) VALUES('OpacHighlightedWords','1','If Set, then queried words are higlighted in OPAC','','YesNo'); + +INSERT INTO `systempreferences` (variable,value,explanation,options,type) VALUES('OAI-PMH','0','if ON, OAI-PMH server is enabled',NULL,'YesNo'); +INSERT INTO `systempreferences` (variable,value,explanation,options,type) VALUES('OAI-PMH:archiveID','KOHA-OAI-TEST','OAI-PMH archive identification',NULL,'Free'); +INSERT INTO `systempreferences` (variable,value,explanation,options,type) VALUES('OAI-PMH:MaxCount','50','OAI-PMH maximum number of records by answer to ListRecords and ListIdentifiers queries',NULL,'Integer'); +INSERT INTO `systempreferences` (variable,value,explanation,options,type) VALUES('OAI-PMH:Set','SET,Experimental set\r\nSET:SUBSET,Experimental subset','OAI-PMH exported set, the set name is followed by a comma and a short description, one set by line',NULL,'Free'); +INSERT INTO `systempreferences` (variable,value,explanation,options,type) VALUES('OAI-PMH:Subset','itemtype=\'BOOK\'','Restrict answer to matching raws of the biblioitems table (experimental)',NULL,'Free'); diff --git a/installer/data/mysql/fr-FR/1-Obligatoire/unimarc_standard_systemprefs.sql b/installer/data/mysql/fr-FR/1-Obligatoire/unimarc_standard_systemprefs.sql index f22bb70cd0..c39b68ad28 100644 --- a/installer/data/mysql/fr-FR/1-Obligatoire/unimarc_standard_systemprefs.sql +++ b/installer/data/mysql/fr-FR/1-Obligatoire/unimarc_standard_systemprefs.sql @@ -171,3 +171,8 @@ INSERT INTO `systempreferences` (variable,value,explanation,options,type) VALUES INSERT INTO `systempreferences` (variable,value,explanation,options,type) VALUES('OpacRenewalAllowed',0,'Si activé, les utilisateurs peuvent renouveller leurs prêts directement depuis leur compte à l''OPAC',NULL,'YesNo'); INSERT INTO `systempreferences` (variable,value,explanation,options,type) VALUES('HomeOrHoldingBranch','holdingbranch','Détermine si l''on utilise le site propriétaire ou le site dépositaire dans les opérations de circulation ou d''affichage de la disponibilité','holdingbranch|homebranch','Choice'); INSERT INTO `systempreferences` (variable,value,explanation,options,type) VALUES('OpacHighlightedWords','0','Si activé, les mots recherchés dans la notices sont affichés dans l''OPAC','','YesNo'); +INSERT INTO `systempreferences` (variable,value,explanation,options,type) VALUES('OAI-PMH','0','Si activé, le service OAI-PMH est disponible',NULL,'YesNo'); +INSERT INTO `systempreferences` (variable,value,explanation,options,type) VALUES('OAI-PMH:archiveID','KOHA-OAI-TEST','Identification de l''archive OAI-PMH',NULL,'Free'); +INSERT INTO `systempreferences` (variable,value,explanation,options,type) VALUES('OAI-PMH:MaxCount','50','Nombre maximum d''enregistrements retournés simultanément aux requêtes ListRecords et ListIdentifiers',NULL,'Integer'); +INSERT INTO `systempreferences` (variable,value,explanation,options,type) VALUES('OAI-PMH:Set','SET,Set experimental\r\nSET:SUBSET,Sous-set experimental','Sets OAI-PMH exportés, Le nom du set est d''une virgule et d''une brève description. Un set par ligne.',NULL,'Free'); +INSERT INTO `systempreferences` (variable,value,explanation,options,type) VALUES('OAI-PMH:Subset','itemtype=\'BOOK\'','Exprime le sous ensemble des éléments de la table biblioitem à exporter (expérimental)',NULL,'Free'); diff --git a/installer/data/mysql/updatedatabase.pl b/installer/data/mysql/updatedatabase.pl index 7e0aa1a186..63508ca9c2 100755 --- a/installer/data/mysql/updatedatabase.pl +++ b/installer/data/mysql/updatedatabase.pl @@ -1027,15 +1027,23 @@ if (C4::Context->preference("Version") < TransformToNum($DBversion)) { print "Upgrade to $DBversion done ( Added index on zebraqueue. )\n"; SetVersion ($DBversion); } - $DBversion = "3.00.00.056"; if (C4::Context->preference("Version") < TransformToNum($DBversion)) { - $dbh->do("INSERT INTO `marc_subfield_structure` (`tagfield`, `tagsubfield`, `liblibrarian`, `libopac`, `repeatable`, `mandatory`, `kohafield`, `tab`, `authorised_value` , `authtypecode`, `value_builder`, `isurl`, `hidden`, `frameworkcode`, `seealso`, `link`, `defaultvalue`) VALUES ('952', 'h', 'Serial Enumeration / chronology','Serial Enumeration / chronology', 0, 0, 'items.enumchron', 10, '', '', '', 0, 0, '', '', '', NULL) "); $dbh->do("ALTER TABLE `items` ADD `enumchron` VARCHAR(80) DEFAULT NULL;"); print "Upgrade to $DBversion done ( Added item.enumchron column, and framework map to 952h )\n"; SetVersion ($DBversion); } + +$DBversion = "3.00.00.057"; +if (C4::Context->preference("Version") < TransformToNum($DBversion)) { + $dbh->do("INSERT INTO `systempreferences` (variable,value,explanation,options,type) VALUES('OAI-PMH','0','if ON, OAI-PMH server is enabled',NULL,'YesNo');"); + $dbh->do("INSERT INTO `systempreferences` (variable,value,explanation,options,type) VALUES('OAI-PMH:archiveID','KOHA-OAI-TEST','OAI-PMH archive identification',NULL,'Free');"); + $dbh->do("INSERT INTO `systempreferences` (variable,value,explanation,options,type) VALUES('OAI-PMH:MaxCount','50','OAI-PMH maximum number of records by answer to ListRecords and ListIdentifiers queries',NULL,'Integer');"); + $dbh->do("INSERT INTO `systempreferences` (variable,value,explanation,options,type) VALUES('OAI-PMH:Set','SET,Experimental set\r\nSET:SUBSET,Experimental subset','OAI-PMH exported set, the set name is followed by a comma and a short description, one set by line',NULL,'Free');"); + $dbh->do("INSERT INTO `systempreferences` (variable,value,explanation,options,type) VALUES('OAI-PMH:Subset',\"itemtype='BOOK'\",'Restrict answer to matching raws of the biblioitems table (experimental)',NULL,'Free');"); + SetVersion ($DBversion); +} $DBversion = "3.00.00.057"; if (C4::Context->preference("Version") < TransformToNum($DBversion)) { diff --git a/koha-tmpl/intranet-tmpl/prog/en/includes/sysprefs-menu.inc b/koha-tmpl/intranet-tmpl/prog/en/includes/sysprefs-menu.inc index 1f71084d8f..7cd34e81aa 100644 --- a/koha-tmpl/intranet-tmpl/prog/en/includes/sysprefs-menu.inc +++ b/koha-tmpl/intranet-tmpl/prog/en/includes/sysprefs-menu.inc @@ -14,6 +14,7 @@
  • class="active" >Patrons
  • class="active" >Searching
  • class="active" >Staff Client
    • +
  • class="active" >OAI-PMH
  • class="active" >Local Use
    • diff --git a/koha-tmpl/intranet-tmpl/prog/en/modules/about.tmpl b/koha-tmpl/intranet-tmpl/prog/en/modules/about.tmpl index e5f1f00140..705378e184 100644 --- a/koha-tmpl/intranet-tmpl/prog/en/modules/about.tmpl +++ b/koha-tmpl/intranet-tmpl/prog/en/modules/about.tmpl @@ -89,18 +89,19 @@
  • Andrew Arensburger (the small and great C4::Context module)
  • Benedykt P. Barszcz (Polish for 2.0)
  • Brig C. McCoy
    • -
  • Chris Catalfo (new plugin MARC editor)
    • +
  • Chris Catalfo (new plugin MARC editor)
  • Daniel Holth
  • David Strainchamps
  • Dorian Meid (German translation)
  • doXulting (Matthieu Branlat) OPAC basket
  • Ed Summers (Some code and Perl packages like MARC::Record)
    • +
  • Ecole des Mines de Saint Etienne, Philippe Jaillon (OAI-PMH support)
  • Esiee School (Jérome Vizcaino, Michel Lerenard, Pierre Cauchois)
    • -
  • Finlay Thompson
    • +
  • Finlay Thompson
  • Florian Bischof
  • Francisco M. Marzoa Alonso
  • Glen Stewart
    • -
  • Gynn Lomax
    • +
  • Gynn Lomax
  • Jo Ransom
  • Kip DeGraaf
  • Marco Gaiarin
    • diff --git a/opac/oai.pl b/opac/oai.pl new file mode 100755 index 0000000000..73f352f4f7 --- /dev/null +++ b/opac/oai.pl @@ -0,0 +1,379 @@ +#!/usr/bin/perl + +use strict; + +use C4::Context; +use C4::Biblio; + +=head1 OAI-PMH for koha + +This file is an implementation of the OAI-PMH protocol for koha. Its purpose +is to share metadata in Dublin core format with harvester like PKP-Harverster. +Presently, all the bibliographic records managed by the runing koha instance +are publicly shared (as the opac is). + +=head1 Package MARC::Record::KOHADC + +This package is a sub-class of the MARC::File::USMARC. It add methods and functions +to map the content of a marc record (of any flavor) to Dublin core. +As soon as it is possible, mapping between marc fields and there semantic +are got from ::GetMarcFromKohaField fonction from C4::Biblio (see also the "Koha +to MARC mapping" preferences). + +=cut + +package MARC::Record::KOHADC; +use vars ('@ISA'); +@ISA = qw(MARC::Record); + +use MARC::File::USMARC; + +sub new { # Get a MAR::Record as parameter and bless it as MARC::Record::KOHADC + shift; + bless shift; +} + +sub subfield { + my $self = shift; + my ($t,$sf) = @_; + + return $self->SUPER::subfield( @_ ) unless wantarray; + + my @field = $self->field($t); + my @list = (); + my $f; + + foreach $f ( @field ) { + push( @list, $f->subfield( $sf ) ); + } + return @list; +} + +sub getfields { +my $marc = shift; +my @result = (); + + foreach my $kohafield ( @_ ) { + my ( $field, $subfield ) = ::GetMarcFromKohaField( $kohafield, '' ); + push( @result, $field < 10 ? $marc->field( $field )->as_string() : $marc->subfield( $field, $subfield ) ); + } +# @result>1 ? \@result : $result[0]; + \@result; +} + +sub Status { + my $self = shift; + undef; +} + +sub Title { + my $self = shift; + $self->getfields('biblio.title'); +} + +sub Creator { + my $self = shift; + $self->getfields('biblio.author'); +} + +sub Subject { + my $self = shift; + $self->getfields('bibliosubject.subject'); +} + +sub DateStamp { + my $self = shift; + my ($d,$h) = split( ' ', $self->{'biblio.timestamp'} ); + $d . "T" . $h . "Z"; +} + +sub Date { + my $self = shift; + my ($str) = @{$self->getfields('biblioitems.publicationyear')}; + my ($y,$m,$d) = (substr($str,0,4), substr($str,4,2), substr($str,6,2)); + + $y=1970 unless($y>0); $m=1 unless($m>0); $d=1 unless($d>0); + + sprintf( "%.4d-%.2d-%.2d", $y,$m,$d); +} + +sub Description { + my $self = shift; + undef; +} + +sub Identifier { + my $self = shift; + my $id = $self->getfields('biblio.biblionumber')->[0]; + +# get url of this script and assume that OAI server is in the same place as opac-detail script +# and build a direct link to the record. + my $uri = $ENV{'SCRIPT_URI'}; + $uri= "http://" . $ENV{'HTTP_HOST'} . $ENV{'REQUEST_URI'} unless( $uri ); # SCRIPT_URI doesn't exist on all httpd server + $uri =~ s#[^/]+$##; + [ + C4::Context->preference("OAI-PMH:archiveID") .":" .$id, + "${uri}opac-detail.pl?bib=$id", + @{$self->getfields('biblioitems.isbn', 'biblioitems.issn')} + ]; +} + +sub Language { + my $self = shift; + undef; +} + +sub Type { + my $self = shift; + $self->getfields('biblioitems.itemtype'); +} + +sub Publisher { + my $self = shift; + $self->getfields('biblioitems.publishercode'); +} + +sub Set { +my $set = &OAI::KOHA::Set(); + [ map( $_=$_->[0], @$set) ]; +} + +=head1 The OAI::KOHA package + +This package is a subclass of the OAI::DC data provider. It overides needed methods +and provide the links between the OAI-PMH request and the koha application. +The data used in answers are from the koha table I. + +=cut + +package OAI::KOHA; + +use C4::OAI::DC; +use vars ('@ISA'); +@ISA = ("C4::OAI::DC"); + +=head2 Set + +return the Set list to the I query. Data are from the 'OAI-PMH:Set' preference. + +=cut + +sub Set { +# [ +# ['BRISE','Experimental unimarc set for BRISE network'], +# ['BRISE:EMSE','EMSE set in BRISE network'] +# ]; +# +# A blinder correctement + [ map( $_ = [ split(",", $_)], split( "\n",C4::Context->preference("OAI-PMH:Set") ) ) ]; +} + +=head2 new + +The new method is the constructor for this class. It doesn't have any parameters and +get required data from koha preferences. Koha I is used to identify the +OAI-PMH repository, I is used to set the maximun number of records +returned at the same time in answers to I or I +queries. + +The method return a blessed reference. + +=cut + +# constructor +sub new +{ + my $classname = shift; + my $self = $classname->SUPER::new (); + + # set configuration + $self->{'repositoryName'} = C4::Context->preference("LibraryName"); + $self->{'MaxCount'} = C4::Context->preference("OAI-PMH:MaxCount"); + $self->{'adminEmail'} = C4::Context->preference("KohaAdminEmailAddress"); + + bless $self, $classname; + return $self; +} + +=head2 dispose + +The dispose method is used as a destructor. It call just the SUPER::dispose method. + +=cut + +# destructor +sub dispose +{ + my ($self) = @_; + $self->SUPER::dispose (); +} + +# now date +sub now { +my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday) = gmtime( time ); + + sprintf( "%.4d-%.2d-%.2d", $year+1900, $mon+1,$mday ); +} + +# build the resumptionTocken fom ($metadataPrefix,$offset,$from,$until) + +=head2 buildResumptionToken and parseResumptionToken + +Theses two functions are used to manage resumption tokens. The choosed syntax is simple as +possible, a token is only the metadata prefix, the offset in the full answer, the from and +the until date (in the yyyy-mm-dd format) joined by ':' caracter. + +I get the four elements as parameters and return the ':' separated +string. + +I is used to set the default values to the from and until date, the +metadata prefix using the resumption tocken if necessary. This function have four parameters +(from,until,metadata prefix and resumption tocken) which can be undefined and return every +time this list of values correctly set. The missing values are set with defaults: offset=0, +from= 1970-01-01 and until is set to current date. + +=cut + +sub buildResumptionToken { + join( ':', @_ ); +} + +# parse the resumptionTocken +sub parseResumptionToken { +my ($from, $until, $metadataPrefix, $resumptionToken) = @_; +my $offset = 0; + + if( $resumptionToken ) { + ($metadataPrefix,$offset,$from,$until) = split( ':', $resumptionToken ); + } + + $from = "1970-01-01" unless( $from ); + $until = &now unless( $until ); + ($metadataPrefix, $offset, $from, $until ); +} + +=head2 Archive_ListSets + +return the full list Set to the I query. Data are from the 'OAI-PMH:Set' preference. + +=cut + +# get full list of sets from the archive +sub Archive_ListSets +{ + &Set(); +} + +=head2 Archive_GetRecord + +This method select the record specified as its first parameter from the koha I +table and return a reference to a MARC::Record::KOHADC object. + +=cut + +# get a single record from the archive +sub Archive_GetRecord +{ + my ($self, $identifier, $metadataFormat) = @_; + my $dbh = C4::Context->dbh; + my $sth = $dbh->prepare("SELECT biblionumber,timestamp FROM biblio WHERE biblionumber=?"); + my $prefixID = C4::Context->preference("OAI-PMH:archiveID"); $prefixID=qr{$prefixID:}; + + $identifier =~ s/^$prefixID//; + + $sth->execute( $identifier ); + + if( my $r = $sth->fetchrow_hashref() ) { + my $marc = new MARC::Record::KOHADC( ::GetMarcBiblio( $identifier ) ); + $marc->{'biblio.timestamp'} = $r->{'timestamp'}; + return $marc ; + } + + $self->AddError ('idDoesNotExist', 'The value of the identifier argument is unknown or illegal in this repository'); + undef; +} + +=head2 Archive_ListRecords + +This method return a list of 'MaxCount' references to MARC::Record::KOHADC object build from the +koha I table according to its parameters : set, from and until date, metadata prefix +and resumption token. + +=cut + +# list metadata records from the archive +sub Archive_ListRecords +{ + my ($self, $set, $from, $until, $metadataPrefix, $resumptionToken) = @_; + + my @allrows = (); + my $marc; + my $offset; + my $tokenInfo; + my $dbh = C4::Context->dbh; + my $sth = $dbh->prepare("SELECT biblionumber,timestamp FROM biblio WHERE DATE(timestamp) >= ? and DATE(timestamp) <= ? LIMIT ? OFFSET ?"); + my $count; + + ($metadataPrefix, $offset, $from, $until ) = &parseResumptionToken($from, $until, $metadataPrefix, $resumptionToken); + +warn( "Archive_ListRecords : $set, $from, $until, $metadataPrefix, $resumptionToken\n"); + $sth->execute( $from,$until,$self->{'MaxCount'}?$self->{'MaxCount'}:100000, $offset ); + + while( my $r = $sth->fetchrow_hashref() ) { + my $marc = new MARC::Record::KOHADC( ::GetMarcBiblio( $r->{'biblionumber'} ) ); + $marc->{'biblio.timestamp'} = $r->{'timestamp'}; + push( @allrows, $marc ); + } + + $sth = $dbh->prepare("SELECT count(*) FROM biblioitems WHERE DATE(timestamp) >= ? and DATE(timestamp) <= ?"); + $sth->execute($from, $until); + ( $count ) = $sth->fetchrow_array(); + + unless( @allrows ) { + $self->AddError ('noRecordsMatch', 'The combination of the values of arguments results in an empty set'); + } + + if( $offset + $self->{'MaxCount'} < $count ) { # Not at the end + $offset = $offset + $self->{'MaxCount'}; + $resumptionToken = &buildResumptionToken($metadataPrefix,$offset,$from,$until); + $tokenInfo = { 'completeListSize' => $count, 'cursor' => $offset }; + } + else { + $resumptionToken = ''; + $tokenInfo = {}; + } + ( \@allrows, $resumptionToken, $metadataPrefix, $tokenInfo ); +} + +package main; + +=head1 Main package + +The I
    function is the starting point of the service. The first step is +to verify if the service is enable using the 'OAI-PMH' preference value +(See Koha systeme preferences). + +If the service is enable, it create a new instance of the OAI::KOHA data +provider (see before) and run the service. + +=cut + +sub disable { + print "Status:404 OAI-PMH service is disabled\n"; + print "Content-type: text/plain\n\n"; + + print "OAI-PMH service is disable.\n"; +} + +sub main +{ + return &disable() unless( C4::Context->preference('OAI-PMH') ); + + my $OAI = new OAI::KOHA(); + $OAI->Run; + $OAI->dispose; +} + +main; + +1; -- 2.39.5