changed OAI-PMH implementation
Replaced older OAI-PMH server implementation with new one by Frédéric Demians. Signed-off-by: Galen Charlton <galen.charlton@liblime.com>
This commit is contained in:
Galen Charlton
parent
ac6cfb28a3
commit
1e6b61cdb1
232
C4/OAI/DC.pm
232
C4/OAI/DC.pm
|
|
@ -1,232 +0,0 @@
|
|||
# ---------------------------------------------------------------------
|
||||
# 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<new>: initialization step,
|
||||
|
||||
=item B<dispose>: clean up step,
|
||||
|
||||
=item B<Archive_ListSets>: return list of defined sets,
|
||||
|
||||
=item B<Archive_GetRecord>: return a record,
|
||||
|
||||
=item B<Archive_ListRecords>: return a list of records,
|
||||
|
||||
=item B<Archive_ListIdentifiers>: 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<completeListSize>
|
||||
and the I<cursor> keys set.
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
|
||||
package C4::OAI::DC;
|
||||
|
||||
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 = "<oaidc:dc xmlns=\"http://purl.org/dc/elements/1.1/\" ".
|
||||
"xmlns:oaidc=\"http://www.openarchives.org/OAI/2.0/oai_dc/\" ".
|
||||
"xmlns:xsi=\"http://www.w3.org/2001/XMLSchema-instance\" ".
|
||||
"xsi:schemaLocation=\"http://www.openarchives.org/OAI/2.0/oai_dc/ ".
|
||||
"http://www.openarchives.org/OAI/2.0/oai_dc.xsd\">\n";
|
||||
my $footer = "</oaidc:dc>\n";
|
||||
my $metadata = '';
|
||||
|
||||
$metadata = $header . $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;
|
||||
|
||||
923
C4/OAI/DP.pm
923
C4/OAI/DP.pm
|
|
@ -1,923 +0,0 @@
|
|||
# ---------------------------------------------------------------------
|
||||
# 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
|
||||
# -------------------------------------------------------+-------------
|
||||
# January 2008
|
||||
# ------------------+--------------------------------------------------
|
||||
# Ph. Jaillon |
|
||||
# ------------------+----------------------+---------------------------
|
||||
# Department of Computer Science |
|
||||
# -----------------------------------------+-------------+-------------
|
||||
# Ecole Nationale Superieure des Mines de St-Etienne | www.emse.fr
|
||||
# -------------------------------------------------------+-------------
|
||||
|
||||
|
||||
$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;
|
||||
|
||||
# setting binmode to utf8 (any characters printed on STDOUT are utf8 encoded)
|
||||
binmode(STDOUT, ":utf8");
|
||||
|
||||
# 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 .= "<error code=\"$error->[0]\">$error->[1]</error>\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 = '<request';
|
||||
if ($fullrequest == 1)
|
||||
{
|
||||
foreach my $param ($self->{'cgi'}->param)
|
||||
{
|
||||
$request .= " $param=\"".$self->{'cgi'}->param ($param)."\"";
|
||||
}
|
||||
}
|
||||
$request .= '>'.$self->{'cgi'}->{'baseURL'}.'</request>';
|
||||
|
||||
"Content-type: text/xml\n\n".
|
||||
"<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n\n".
|
||||
"<OAI-PMH xmlns=\"$self->{'xmlnsprefix'}\" ".
|
||||
"xmlns:xsi=\"http://www.w3.org/2001/XMLSchema-instance\" ".
|
||||
"xsi:schemaLocation=\"$self->{'xmlnsprefix'} ".
|
||||
"$self->{'xmlnsprefix'}OAI-PMH.xsd\">\n\n".
|
||||
"<responseDate>$datestring</responseDate>\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 = '</'.$self->{'verb'}.">\n";
|
||||
}
|
||||
|
||||
$verbcontainer.
|
||||
"\n</OAI-PMH>\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>'.$setSpec."</setSpec>\n";
|
||||
}
|
||||
}
|
||||
|
||||
"<header$statusattribute>\n".
|
||||
"<identifier>$identifier</identifier>\n".
|
||||
"<datestamp>$datestamp</datestamp>\n".
|
||||
$setstring.
|
||||
"</header>\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 =
|
||||
"<record>\n".
|
||||
$header;
|
||||
|
||||
if ((defined $metadata) && ($metadata ne ''))
|
||||
{
|
||||
$output .= "<metadata>\n$metadata</metadata>\n";
|
||||
}
|
||||
if ((defined $about) && ($about ne ''))
|
||||
{
|
||||
$output .= "<about>\n$about</about>\n";
|
||||
}
|
||||
|
||||
$output."</record>\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 ) ],
|
||||
},
|
||||
{
|
||||
'name' => 'Philippe Jaillon',
|
||||
'email' => 'jaillon@emse.fr',
|
||||
'institution' => 'École Nationale Supérieure des Mines de Saint-Étienne',
|
||||
'mdorder' => [ qw ( name email institution ) ],
|
||||
}
|
||||
],
|
||||
'version' => '3.05',
|
||||
'URL' => [
|
||||
'http://www.dlib.vt.edu/projects/OAI/',
|
||||
'http://oai-pmh.emse.fr/'
|
||||
],
|
||||
'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 .= "<metadataFormat>\n".
|
||||
"<metadataPrefix>$i</metadataPrefix>\n".
|
||||
"<schema>$metadataSchema->{$i}</schema>\n".
|
||||
"<metadataNamespace>$metadataNamespace->{$i}</metadataNamespace>\n".
|
||||
"</metadataFormat>\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 .= "<set>\n".
|
||||
" <setSpec>".$self->{'utility'}->lclean ($$item[0])."</setSpec>\n".
|
||||
" <setName>".$self->{'utility'}->lclean ($$item[1])."</setName>\n";
|
||||
if (defined $$item[2])
|
||||
{
|
||||
$buffer .= '<setDescription>'.$$item[2].'</setDescription>';
|
||||
}
|
||||
$buffer .= "</set>\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".$attrs.">$resumptionToken</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
|
||||
|
|
@ -1,204 +0,0 @@
|
|||
# ---------------------------------------------------------------------
|
||||
# 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;
|
||||
$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;
|
||||
$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</$key>\n";
|
||||
}
|
||||
elsif (ref ($i) eq 'HASH')
|
||||
{
|
||||
my $nestedbuffer = $self->FormatXML ($i, $indent);
|
||||
if ($nestedbuffer ne '')
|
||||
{
|
||||
$buffer .= "$indent<$key>\n$nestedbuffer$indent</$key>\n";
|
||||
}
|
||||
}
|
||||
else
|
||||
{
|
||||
$buffer .= "$indent<$key>$i</$key>\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</$key>\n";
|
||||
}
|
||||
}
|
||||
elsif ((exists ($head->{$key})) && ($head->{$key} ne ''))
|
||||
{
|
||||
$buffer .= "$indent<$key>$head->{$key}</$key>\n";
|
||||
}
|
||||
}
|
||||
$buffer;
|
||||
}
|
||||
|
||||
|
||||
1;
|
||||
812
opac/oai.pl
812
opac/oai.pl
|
|
@ -1,399 +1,471 @@
|
|||
#!/usr/bin/perl
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use diagnostics;
|
||||
|
||||
use CGI qw/:standard -oldstyle_urls/;
|
||||
use vars qw( $GZIP );
|
||||
use C4::Context;
|
||||
|
||||
|
||||
BEGIN {
|
||||
eval { require PerlIO::gzip };
|
||||
$GZIP = $@ ? 0 : 1;
|
||||
}
|
||||
|
||||
unless ( C4::Context->preference('OAI-PMH') ) {
|
||||
print
|
||||
header(
|
||||
-type => 'text/plain; charset=utf-8',
|
||||
-charset => 'utf-8',
|
||||
-status => '404 OAI-PMH service is disabled',
|
||||
),
|
||||
"OAI-PMH service is disabled";
|
||||
exit;
|
||||
}
|
||||
|
||||
my @encodings = http('HTTP_ACCEPT_ENCODING');
|
||||
if ( $GZIP && grep { defined($_) && $_ eq 'gzip' } @encodings ) {
|
||||
print header(
|
||||
-type => 'text/xml; charset=utf-8',
|
||||
-charset => 'utf-8',
|
||||
-Content-Encoding => 'gzip',
|
||||
);
|
||||
binmode( STDOUT, ":gzip" );
|
||||
}
|
||||
else {
|
||||
print header(
|
||||
-type => 'text/xml; charset=utf-8',
|
||||
-charset => 'utf-8',
|
||||
);
|
||||
}
|
||||
|
||||
binmode( STDOUT, ":utf8" );
|
||||
my $repository = C4::OAI::Repository->new();
|
||||
|
||||
# __END__ Main Prog
|
||||
|
||||
|
||||
#
|
||||
# Extends HTTP::OAI::ResumptionToken
|
||||
# A token is identified by:
|
||||
# - metadataPrefix
|
||||
# - from
|
||||
# - until
|
||||
# - offset
|
||||
#
|
||||
package C4::OAI::ResumptionToken;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use diagnostics;
|
||||
use HTTP::OAI;
|
||||
|
||||
use base ("HTTP::OAI::ResumptionToken");
|
||||
|
||||
|
||||
sub new {
|
||||
my ($class, %args) = @_;
|
||||
|
||||
my $self = $class->SUPER::new(%args);
|
||||
|
||||
my ($metadata_prefix, $offset, $from, $until);
|
||||
if ( $args{ resumptionToken } ) {
|
||||
($metadata_prefix, $offset, $from, $until)
|
||||
= split( ':', $args{resumptionToken} );
|
||||
}
|
||||
else {
|
||||
$metadata_prefix = $args{ metadataPrefix };
|
||||
$from = $args{ from } || '1970-01-01';
|
||||
$until = $args{ until };
|
||||
unless ( $until) {
|
||||
my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday) = gmtime( time );
|
||||
$until = sprintf( "%.4d-%.2d-%.2d", $year+1900, $mon+1,$mday );
|
||||
}
|
||||
$offset = $args{ offset } || 0;
|
||||
}
|
||||
|
||||
$self->{ metadata_prefix } = $metadata_prefix;
|
||||
$self->{ offset } = $offset;
|
||||
$self->{ from } = $from;
|
||||
$self->{ until } = $until;
|
||||
|
||||
$self->resumptionToken(
|
||||
join( ':', $metadata_prefix, $offset, $from, $until ) );
|
||||
$self->cursor( $offset );
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
# __END__ C4::OAI::ResumptionToken
|
||||
|
||||
|
||||
|
||||
package C4::OAI::Identify;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use diagnostics;
|
||||
use HTTP::OAI;
|
||||
use C4::Context;
|
||||
|
||||
use base ("HTTP::OAI::Identify");
|
||||
|
||||
sub new {
|
||||
my ($class, $repository) = @_;
|
||||
|
||||
my ($baseURL) = $repository->self_url() =~ /(.*)\?.*/;
|
||||
my $self = $class->SUPER::new(
|
||||
baseURL => $baseURL,
|
||||
repositoryName => C4::Context->preference("LibraryName"),
|
||||
adminEmail => C4::Context->preference("KohaAdminEmailAddress"),
|
||||
MaxCount => C4::Context->preference("OAI-PMH:MaxCount"),
|
||||
granularity => 'YYYY-MM-DD',
|
||||
earliestDatestamp => '0001-01-01',
|
||||
);
|
||||
$self->description( "Koha OAI Repository" );
|
||||
$self->compression( 'gzip' );
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
# __END__ C4::OAI::Identify
|
||||
|
||||
|
||||
|
||||
package C4::OAI::ListMetadataFormats;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use diagnostics;
|
||||
use HTTP::OAI;
|
||||
|
||||
use base ("HTTP::OAI::ListMetadataFormats");
|
||||
|
||||
sub new {
|
||||
my ($class, $repository) = @_;
|
||||
|
||||
my $self = $class->SUPER::new();
|
||||
|
||||
$self->metadataFormat( HTTP::OAI::MetadataFormat->new(
|
||||
metadataPrefix => 'oai_dc',
|
||||
schema => 'http://www.openarchives.org/OAI/2.0/oai_dc.xsd',
|
||||
metadataNamespace => 'http://www.openarchives.org/OAI/2.0/oai_dc/'
|
||||
) );
|
||||
$self->metadataFormat( HTTP::OAI::MetadataFormat->new(
|
||||
metadataPrefix => 'marcxml',
|
||||
schema => 'http://www.loc.gov/MARC21/slim http://www.loc.gov/ standards/marcxml/schema/MARC21slim.xsd',
|
||||
metadataNamespace => 'http://www.loc.gov/MARC21/slim http://www.loc.gov/ standards/marcxml/schema/MARC21slim'
|
||||
) );
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
# __END__ C4::OAI::ListMetadataFormats
|
||||
|
||||
|
||||
|
||||
package C4::OAI::Record;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use diagnostics;
|
||||
use HTTP::OAI;
|
||||
use HTTP::OAI::Metadata::OAI_DC;
|
||||
|
||||
use base ("HTTP::OAI::Record");
|
||||
|
||||
sub new {
|
||||
my ($class, $repository, $marcxml, $timestamp, %args) = @_;
|
||||
|
||||
my $self = $class->SUPER::new(%args);
|
||||
|
||||
$timestamp =~ s/ /T/, $timestamp .= 'Z';
|
||||
$self->header( new HTTP::OAI::Header(
|
||||
identifier => $args{identifier},
|
||||
datestamp => $timestamp,
|
||||
) );
|
||||
|
||||
my $parser = XML::LibXML->new();
|
||||
my $record_dom = $parser->parse_string( $marcxml );
|
||||
if ( $args{metadataPrefix} ne 'marcxml' ) {
|
||||
$record_dom = $repository->oai_dc_stylesheet()->transform( $record_dom );
|
||||
}
|
||||
$self->metadata( HTTP::OAI::Metadata->new( dom => $record_dom ) );
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
# __END__ C4::OAI::Record
|
||||
|
||||
|
||||
|
||||
package C4::OAI::GetRecord;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use diagnostics;
|
||||
use HTTP::OAI;
|
||||
|
||||
use base ("HTTP::OAI::GetRecord");
|
||||
|
||||
|
||||
sub new {
|
||||
my ($class, $repository, %args) = @_;
|
||||
|
||||
my $self = HTTP::OAI::GetRecord->new(%args);
|
||||
|
||||
my $dbh = C4::Context->dbh;
|
||||
my $sth = $dbh->prepare("
|
||||
SELECT marcxml, timestamp
|
||||
FROM biblioitems
|
||||
WHERE biblionumber=? " );
|
||||
my $prefix = $repository->{koha_identifier} . ':';
|
||||
my ($biblionumber) = $args{identifier} =~ /^$prefix(.*)/;
|
||||
$sth->execute( $biblionumber );
|
||||
my ($marcxml, $timestamp);
|
||||
unless ( ($marcxml, $timestamp) = $sth->fetchrow ) {
|
||||
return HTTP::OAI::Response->new(
|
||||
requestURL => $repository->self_url(),
|
||||
errors => [ new HTTP::OAI::Error(
|
||||
code => 'idDoesNotExist',
|
||||
message => "There is no biblio record with this identifier",
|
||||
) ] ,
|
||||
);
|
||||
}
|
||||
|
||||
#$self->header( HTTP::OAI::Header->new( identifier => $args{identifier} ) );
|
||||
$self->record( C4::OAI::Record->new(
|
||||
$repository, $marcxml, $timestamp, %args ) );
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
# __END__ C4::OAI::GetRecord
|
||||
|
||||
|
||||
|
||||
package C4::OAI::ListIdentifiers;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use diagnostics;
|
||||
use HTTP::OAI;
|
||||
|
||||
use base ("HTTP::OAI::ListIdentifiers");
|
||||
|
||||
|
||||
sub new {
|
||||
my ($class, $repository, %args) = @_;
|
||||
|
||||
my $self = HTTP::OAI::ListIdentifiers->new(%args);
|
||||
|
||||
my $token = new C4::OAI::ResumptionToken( %args );
|
||||
my $dbh = C4::Context->dbh;
|
||||
my $sql = "SELECT biblionumber, timestamp
|
||||
FROM biblioitems
|
||||
WHERE timestamp >= ? AND timestamp <= ?
|
||||
LIMIT " . $repository->{koha_max_count} . "
|
||||
OFFSET " . $token->{offset};
|
||||
my $sth = $dbh->prepare( $sql );
|
||||
$sth->execute( $token->{from}, $token->{until} );
|
||||
|
||||
my $pos = $token->{offset};
|
||||
while ( my ($biblionumber, $timestamp) = $sth->fetchrow ) {
|
||||
$timestamp =~ s/ /T/, $timestamp .= 'Z';
|
||||
$self->identifier( new HTTP::OAI::Header(
|
||||
identifier => $repository->{ koha_identifier} . ':' . $biblionumber,
|
||||
datestamp => $timestamp,
|
||||
) );
|
||||
$pos++;
|
||||
}
|
||||
$self->resumptionToken( new C4::OAI::ResumptionToken(
|
||||
metadataPrefix => $token->{metadata_prefix},
|
||||
from => $token->{from},
|
||||
until => $token->{until},
|
||||
offset => $pos ) );
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
# __END__ C4::OAI::ListIdentifiers
|
||||
|
||||
|
||||
|
||||
package C4::OAI::ListRecords;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use diagnostics;
|
||||
use HTTP::OAI;
|
||||
|
||||
use base ("HTTP::OAI::ListRecords");
|
||||
|
||||
|
||||
sub new {
|
||||
my ($class, $repository, %args) = @_;
|
||||
|
||||
my $self = HTTP::OAI::ListRecords->new(%args);
|
||||
|
||||
my $token = new C4::OAI::ResumptionToken( %args );
|
||||
my $dbh = C4::Context->dbh;
|
||||
my $sql = "SELECT biblionumber, marcxml, timestamp
|
||||
FROM biblioitems
|
||||
WHERE timestamp >= ? AND timestamp <= ?
|
||||
LIMIT " . $repository->{koha_max_count} . "
|
||||
OFFSET " . $token->{offset};
|
||||
my $sth = $dbh->prepare( $sql );
|
||||
$sth->execute( $token->{from}, $token->{until} );
|
||||
|
||||
my $pos = $token->{offset};
|
||||
while ( my ($biblionumber, $marcxml, $timestamp) = $sth->fetchrow ) {
|
||||
$self->record( C4::OAI::Record->new(
|
||||
$repository, $marcxml, $timestamp,
|
||||
identifier => $repository->{ koha_identifier } . ':' . $biblionumber,
|
||||
metadataPrefix => $token->{metadata_prefix}
|
||||
) );
|
||||
$pos++;
|
||||
}
|
||||
$self->resumptionToken( new C4::OAI::ResumptionToken(
|
||||
metadataPrefix => $token->{metadata_prefix},
|
||||
from => $token->{from},
|
||||
until => $token->{until},
|
||||
offset => $pos ) );
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
# __END__ C4::OAI::ListRecords
|
||||
|
||||
|
||||
|
||||
package C4::OAI::Repository;
|
||||
|
||||
use base ("HTTP::OAI::Repository");
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use diagnostics;
|
||||
|
||||
use HTTP::OAI;
|
||||
use HTTP::OAI::Repository qw/:validate/;
|
||||
|
||||
use XML::SAX::Writer;
|
||||
use XML::LibXML;
|
||||
use XML::LibXSLT;
|
||||
use CGI qw/:standard -oldstyle_urls/;
|
||||
|
||||
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 NAME
|
||||
|
||||
=head1 Package MARC::Record::KOHADC
|
||||
C4::OAI::Repository - Handles OAI-PMH requests for a Koha database.
|
||||
|
||||
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).
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use C4::OAI::Repository;
|
||||
|
||||
my $repository = C4::OAI::Repository->new();
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This object extend HTTP::OAI::Repository object.
|
||||
|
||||
=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;
|
||||
my $marc = shift;
|
||||
bless $marc if( ref( $marc ) );
|
||||
}
|
||||
sub new {
|
||||
my ($class, %args) = @_;
|
||||
my $self = $class->SUPER::new(%args);
|
||||
|
||||
sub subfield {
|
||||
my $self = shift;
|
||||
my ($t,$sf) = @_;
|
||||
$self->{ koha_identifier } = C4::Context->preference("OAI-PMH:archiveID");
|
||||
$self->{ koha_max_count } = C4::Context->preference("OAI-PMH:MaxCount");
|
||||
$self->{ koha_metadata_format } = ['oai_dc', 'marcxml'];
|
||||
|
||||
return $self->SUPER::subfield( @_ ) unless wantarray;
|
||||
# Check for grammatical errors in the request
|
||||
my @errs = validate_request( CGI::Vars() );
|
||||
|
||||
my @field = $self->field($t);
|
||||
my @list = ();
|
||||
my $f;
|
||||
|
||||
foreach $f ( @field ) {
|
||||
push( @list, $f->subfield( $sf ) );
|
||||
# Is metadataPrefix supported by the respository?
|
||||
my $mdp = param('metadataPrefix') || '';
|
||||
if ( $mdp && !grep { $_ eq $mdp } @{$self->{ koha_metadata_format }} ) {
|
||||
push @errs, new HTTP::OAI::Error(
|
||||
code => 'cannotDisseminateFormat',
|
||||
message => "Dissemination as '$mdp' is not supported",
|
||||
);
|
||||
}
|
||||
return @list;
|
||||
}
|
||||
|
||||
sub getfields {
|
||||
my $marc = shift;
|
||||
my @result = ();
|
||||
|
||||
foreach my $kohafield ( @_ ) {
|
||||
my ( $field, $subfield ) = ::GetMarcFromKohaField( $kohafield, '' );
|
||||
next unless defined $field; # $kohafield not defined in framework
|
||||
push( @result, $field < 10 ? $marc->field( $field )->as_string() : $marc->subfield( $field, $subfield ) );
|
||||
my $response;
|
||||
if ( @errs ) {
|
||||
$response = HTTP::OAI::Response->new(
|
||||
requestURL => self_url(),
|
||||
errors => \@errs,
|
||||
);
|
||||
}
|
||||
else {
|
||||
my %attr = CGI::Vars();
|
||||
my $verb = delete( $attr{verb} );
|
||||
if ( grep { $_ eq $verb } qw( ListSets ) ) {
|
||||
$response = HTTP::OAI::Response->new(
|
||||
requestURL => $self->self_url(),
|
||||
errors => [ new HTTP::OAI::Error(
|
||||
code => 'noSetHierarchy',
|
||||
message => "Koha repository doesn't have sets",
|
||||
) ] ,
|
||||
);
|
||||
}
|
||||
# @result>1 ? \@result : $result[0];
|
||||
\@result;
|
||||
}
|
||||
elsif ( $verb eq 'Identify' ) {
|
||||
$response = C4::OAI::Identify->new( $self );
|
||||
}
|
||||
elsif ( $verb eq 'ListMetadataFormats' ) {
|
||||
$response = C4::OAI::ListMetadataFormats->new( $self );
|
||||
}
|
||||
elsif ( $verb eq 'GetRecord' ) {
|
||||
$response = C4::OAI::GetRecord->new( $self, %attr );
|
||||
}
|
||||
elsif ( $verb eq 'ListRecords' ) {
|
||||
$response = C4::OAI::ListRecords->new( $self, %attr );
|
||||
}
|
||||
elsif ( $verb eq 'ListIdentifiers' ) {
|
||||
$response = C4::OAI::ListIdentifiers->new( $self, %attr );
|
||||
}
|
||||
}
|
||||
|
||||
sub XMLescape {
|
||||
my ($t) = shift;
|
||||
$response->set_handler( XML::SAX::Writer->new( Output => *STDOUT ) );
|
||||
$response->generate;
|
||||
|
||||
foreach (@$t ) {
|
||||
s/\&/\&/g; s/</</g;
|
||||
}
|
||||
$t;
|
||||
}
|
||||
|
||||
sub Status {
|
||||
my $self = shift;
|
||||
undef;
|
||||
bless $self, $class;
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub Title {
|
||||
my $self = shift;
|
||||
&XMLescape( $self->getfields('biblio.title') );
|
||||
}
|
||||
|
||||
sub Creator {
|
||||
my $self = shift;
|
||||
&XMLescape( $self->getfields('biblio.author') );
|
||||
}
|
||||
|
||||
sub Subject {
|
||||
my $self = shift;
|
||||
&XMLescape( $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;
|
||||
&XMLescape( $self->getfields('biblioitems.itemtype') );
|
||||
}
|
||||
|
||||
sub Publisher {
|
||||
my $self = shift;
|
||||
&XMLescape( $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<bibio>.
|
||||
|
||||
=cut
|
||||
|
||||
package OAI::KOHA;
|
||||
|
||||
use C4::OAI::DC;
|
||||
use vars ('@ISA');
|
||||
@ISA = ("C4::OAI::DC");
|
||||
|
||||
=head2 Set
|
||||
|
||||
return the Set list to the I<verb=ListSets> 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") ) ) ];
|
||||
# XSLT stylesheet used to transform MARCXML record into OAI Dublin Core.
|
||||
# The object is constructed the fist time this method is called.
|
||||
#
|
||||
# Styleeet file is located in /koha-tmpl/intranet-tmpl/prog/en/xslt/ directory.
|
||||
# Its name is constructed with 'marcflavour' syspref:
|
||||
# - MARC21slim2OAIDC.xsl
|
||||
# - UNIMARCslim2OADIC.xsl
|
||||
#
|
||||
sub oai_dc_stylesheet {
|
||||
my $self = shift;
|
||||
|
||||
unless ( $self->{ oai_dc_stylesheet } ) {
|
||||
my $xslt_file = C4::Context->config('intranetdir') .
|
||||
"/koha-tmpl/intranet-tmpl/prog/en/xslt/" .
|
||||
C4::Context->preference('marcflavour') .
|
||||
"slim2OAIDC.xsl";
|
||||
my $parser = XML::LibXML->new();
|
||||
my $xslt = XML::LibXSLT->new();
|
||||
my $style_doc = $parser->parse_file( $xslt_file );
|
||||
my $stylesheet = $xslt->parse_stylesheet( $style_doc );
|
||||
$self->{ oai_dc_stylesheet } = $stylesheet;
|
||||
}
|
||||
|
||||
return $self->{ oai_dc_stylesheet };
|
||||
}
|
||||
|
||||
=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<LibraryName> is used to identify the
|
||||
OAI-PMH repository, I<OAI-PMH:MaxCount> is used to set the maximun number of records
|
||||
returned at the same time in answers to I<verb=ListRecords> or I<verb=ListIdentifiers>
|
||||
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<buildResumptionToken> get the four elements as parameters and return the ':' separated
|
||||
string.
|
||||
|
||||
I<parseResumptionToken> 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<verb=ListSets> 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<biblio>
|
||||
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 ) );
|
||||
if( $marc ) {
|
||||
$marc->{'biblio.timestamp'} = $r->{'timestamp'};
|
||||
return $marc ;
|
||||
}
|
||||
else {
|
||||
warn("Archive_GetRecord : no MARC record for " . C4::Context->preference("OAI-PMH:archiveID") . ":" . $identifier);
|
||||
}
|
||||
}
|
||||
|
||||
$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<biblio> 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'} ) );
|
||||
unless( $marc ) { # somme time there is problems within koha, and we can't get valid marc record
|
||||
warn("Archive_ListRecords : no MARC record for " . C4::Context->preference("OAI-PMH:archiveID") .":" . $r->{'biblionumber'} );
|
||||
next;
|
||||
}
|
||||
$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<main> 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;
|
||||
|
|
|
|||
471
opac/oai2.pl
471
opac/oai2.pl
|
|
@ -1,471 +0,0 @@
|
|||
#!/usr/bin/perl
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use diagnostics;
|
||||
|
||||
use CGI qw/:standard -oldstyle_urls/;
|
||||
use vars qw( $GZIP );
|
||||
use C4::Context;
|
||||
|
||||
|
||||
BEGIN {
|
||||
eval { require PerlIO::gzip };
|
||||
$GZIP = $@ ? 0 : 1;
|
||||
}
|
||||
|
||||
unless ( C4::Context->preference('OAI-PMH') ) {
|
||||
print
|
||||
header(
|
||||
-type => 'text/plain; charset=utf-8',
|
||||
-charset => 'utf-8',
|
||||
-status => '404 OAI-PMH service is disabled',
|
||||
),
|
||||
"OAI-PMH service is disabled";
|
||||
exit;
|
||||
}
|
||||
|
||||
my @encodings = http('HTTP_ACCEPT_ENCODING');
|
||||
if ( $GZIP && grep { defined($_) && $_ eq 'gzip' } @encodings ) {
|
||||
print header(
|
||||
-type => 'text/xml; charset=utf-8',
|
||||
-charset => 'utf-8',
|
||||
-Content-Encoding => 'gzip',
|
||||
);
|
||||
binmode( STDOUT, ":gzip" );
|
||||
}
|
||||
else {
|
||||
print header(
|
||||
-type => 'text/xml; charset=utf-8',
|
||||
-charset => 'utf-8',
|
||||
);
|
||||
}
|
||||
|
||||
binmode( STDOUT, ":utf8" );
|
||||
my $repository = C4::OAI::Repository->new();
|
||||
|
||||
# __END__ Main Prog
|
||||
|
||||
|
||||
#
|
||||
# Extends HTTP::OAI::ResumptionToken
|
||||
# A token is identified by:
|
||||
# - metadataPrefix
|
||||
# - from
|
||||
# - until
|
||||
# - offset
|
||||
#
|
||||
package C4::OAI::ResumptionToken;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use diagnostics;
|
||||
use HTTP::OAI;
|
||||
|
||||
use base ("HTTP::OAI::ResumptionToken");
|
||||
|
||||
|
||||
sub new {
|
||||
my ($class, %args) = @_;
|
||||
|
||||
my $self = $class->SUPER::new(%args);
|
||||
|
||||
my ($metadata_prefix, $offset, $from, $until);
|
||||
if ( $args{ resumptionToken } ) {
|
||||
($metadata_prefix, $offset, $from, $until)
|
||||
= split( ':', $args{resumptionToken} );
|
||||
}
|
||||
else {
|
||||
$metadata_prefix = $args{ metadataPrefix };
|
||||
$from = $args{ from } || '1970-01-01';
|
||||
$until = $args{ until };
|
||||
unless ( $until) {
|
||||
my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday) = gmtime( time );
|
||||
$until = sprintf( "%.4d-%.2d-%.2d", $year+1900, $mon+1,$mday );
|
||||
}
|
||||
$offset = $args{ offset } || 0;
|
||||
}
|
||||
|
||||
$self->{ metadata_prefix } = $metadata_prefix;
|
||||
$self->{ offset } = $offset;
|
||||
$self->{ from } = $from;
|
||||
$self->{ until } = $until;
|
||||
|
||||
$self->resumptionToken(
|
||||
join( ':', $metadata_prefix, $offset, $from, $until ) );
|
||||
$self->cursor( $offset );
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
# __END__ C4::OAI::ResumptionToken
|
||||
|
||||
|
||||
|
||||
package C4::OAI::Identify;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use diagnostics;
|
||||
use HTTP::OAI;
|
||||
use C4::Context;
|
||||
|
||||
use base ("HTTP::OAI::Identify");
|
||||
|
||||
sub new {
|
||||
my ($class, $repository) = @_;
|
||||
|
||||
my ($baseURL) = $repository->self_url() =~ /(.*)\?.*/;
|
||||
my $self = $class->SUPER::new(
|
||||
baseURL => $baseURL,
|
||||
repositoryName => C4::Context->preference("LibraryName"),
|
||||
adminEmail => C4::Context->preference("KohaAdminEmailAddress"),
|
||||
MaxCount => C4::Context->preference("OAI-PMH:MaxCount"),
|
||||
granularity => 'YYYY-MM-DD',
|
||||
earliestDatestamp => '0001-01-01',
|
||||
);
|
||||
$self->description( "Koha OAI Repository" );
|
||||
$self->compression( 'gzip' );
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
# __END__ C4::OAI::Identify
|
||||
|
||||
|
||||
|
||||
package C4::OAI::ListMetadataFormats;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use diagnostics;
|
||||
use HTTP::OAI;
|
||||
|
||||
use base ("HTTP::OAI::ListMetadataFormats");
|
||||
|
||||
sub new {
|
||||
my ($class, $repository) = @_;
|
||||
|
||||
my $self = $class->SUPER::new();
|
||||
|
||||
$self->metadataFormat( HTTP::OAI::MetadataFormat->new(
|
||||
metadataPrefix => 'oai_dc',
|
||||
schema => 'http://www.openarchives.org/OAI/2.0/oai_dc.xsd',
|
||||
metadataNamespace => 'http://www.openarchives.org/OAI/2.0/oai_dc/'
|
||||
) );
|
||||
$self->metadataFormat( HTTP::OAI::MetadataFormat->new(
|
||||
metadataPrefix => 'marcxml',
|
||||
schema => 'http://www.loc.gov/MARC21/slim http://www.loc.gov/ standards/marcxml/schema/MARC21slim.xsd',
|
||||
metadataNamespace => 'http://www.loc.gov/MARC21/slim http://www.loc.gov/ standards/marcxml/schema/MARC21slim'
|
||||
) );
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
# __END__ C4::OAI::ListMetadataFormats
|
||||
|
||||
|
||||
|
||||
package C4::OAI::Record;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use diagnostics;
|
||||
use HTTP::OAI;
|
||||
use HTTP::OAI::Metadata::OAI_DC;
|
||||
|
||||
use base ("HTTP::OAI::Record");
|
||||
|
||||
sub new {
|
||||
my ($class, $repository, $marcxml, $timestamp, %args) = @_;
|
||||
|
||||
my $self = $class->SUPER::new(%args);
|
||||
|
||||
$timestamp =~ s/ /T/, $timestamp .= 'Z';
|
||||
$self->header( new HTTP::OAI::Header(
|
||||
identifier => $args{identifier},
|
||||
datestamp => $timestamp,
|
||||
) );
|
||||
|
||||
my $parser = XML::LibXML->new();
|
||||
my $record_dom = $parser->parse_string( $marcxml );
|
||||
if ( $args{metadataPrefix} ne 'marcxml' ) {
|
||||
$record_dom = $repository->oai_dc_stylesheet()->transform( $record_dom );
|
||||
}
|
||||
$self->metadata( HTTP::OAI::Metadata->new( dom => $record_dom ) );
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
# __END__ C4::OAI::Record
|
||||
|
||||
|
||||
|
||||
package C4::OAI::GetRecord;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use diagnostics;
|
||||
use HTTP::OAI;
|
||||
|
||||
use base ("HTTP::OAI::GetRecord");
|
||||
|
||||
|
||||
sub new {
|
||||
my ($class, $repository, %args) = @_;
|
||||
|
||||
my $self = HTTP::OAI::GetRecord->new(%args);
|
||||
|
||||
my $dbh = C4::Context->dbh;
|
||||
my $sth = $dbh->prepare("
|
||||
SELECT marcxml, timestamp
|
||||
FROM biblioitems
|
||||
WHERE biblionumber=? " );
|
||||
my $prefix = $repository->{koha_identifier} . ':';
|
||||
my ($biblionumber) = $args{identifier} =~ /^$prefix(.*)/;
|
||||
$sth->execute( $biblionumber );
|
||||
my ($marcxml, $timestamp);
|
||||
unless ( ($marcxml, $timestamp) = $sth->fetchrow ) {
|
||||
return HTTP::OAI::Response->new(
|
||||
requestURL => $repository->self_url(),
|
||||
errors => [ new HTTP::OAI::Error(
|
||||
code => 'idDoesNotExist',
|
||||
message => "There is no biblio record with this identifier",
|
||||
) ] ,
|
||||
);
|
||||
}
|
||||
|
||||
#$self->header( HTTP::OAI::Header->new( identifier => $args{identifier} ) );
|
||||
$self->record( C4::OAI::Record->new(
|
||||
$repository, $marcxml, $timestamp, %args ) );
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
# __END__ C4::OAI::GetRecord
|
||||
|
||||
|
||||
|
||||
package C4::OAI::ListIdentifiers;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use diagnostics;
|
||||
use HTTP::OAI;
|
||||
|
||||
use base ("HTTP::OAI::ListIdentifiers");
|
||||
|
||||
|
||||
sub new {
|
||||
my ($class, $repository, %args) = @_;
|
||||
|
||||
my $self = HTTP::OAI::ListIdentifiers->new(%args);
|
||||
|
||||
my $token = new C4::OAI::ResumptionToken( %args );
|
||||
my $dbh = C4::Context->dbh;
|
||||
my $sql = "SELECT biblionumber, timestamp
|
||||
FROM biblioitems
|
||||
WHERE timestamp >= ? AND timestamp <= ?
|
||||
LIMIT " . $repository->{koha_max_count} . "
|
||||
OFFSET " . $token->{offset};
|
||||
my $sth = $dbh->prepare( $sql );
|
||||
$sth->execute( $token->{from}, $token->{until} );
|
||||
|
||||
my $pos = $token->{offset};
|
||||
while ( my ($biblionumber, $timestamp) = $sth->fetchrow ) {
|
||||
$timestamp =~ s/ /T/, $timestamp .= 'Z';
|
||||
$self->identifier( new HTTP::OAI::Header(
|
||||
identifier => $repository->{ koha_identifier} . ':' . $biblionumber,
|
||||
datestamp => $timestamp,
|
||||
) );
|
||||
$pos++;
|
||||
}
|
||||
$self->resumptionToken( new C4::OAI::ResumptionToken(
|
||||
metadataPrefix => $token->{metadata_prefix},
|
||||
from => $token->{from},
|
||||
until => $token->{until},
|
||||
offset => $pos ) );
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
# __END__ C4::OAI::ListIdentifiers
|
||||
|
||||
|
||||
|
||||
package C4::OAI::ListRecords;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use diagnostics;
|
||||
use HTTP::OAI;
|
||||
|
||||
use base ("HTTP::OAI::ListRecords");
|
||||
|
||||
|
||||
sub new {
|
||||
my ($class, $repository, %args) = @_;
|
||||
|
||||
my $self = HTTP::OAI::ListRecords->new(%args);
|
||||
|
||||
my $token = new C4::OAI::ResumptionToken( %args );
|
||||
my $dbh = C4::Context->dbh;
|
||||
my $sql = "SELECT biblionumber, marcxml, timestamp
|
||||
FROM biblioitems
|
||||
WHERE timestamp >= ? AND timestamp <= ?
|
||||
LIMIT " . $repository->{koha_max_count} . "
|
||||
OFFSET " . $token->{offset};
|
||||
my $sth = $dbh->prepare( $sql );
|
||||
$sth->execute( $token->{from}, $token->{until} );
|
||||
|
||||
my $pos = $token->{offset};
|
||||
while ( my ($biblionumber, $marcxml, $timestamp) = $sth->fetchrow ) {
|
||||
$self->record( C4::OAI::Record->new(
|
||||
$repository, $marcxml, $timestamp,
|
||||
identifier => $repository->{ koha_identifier } . ':' . $biblionumber,
|
||||
metadataPrefix => $token->{metadata_prefix}
|
||||
) );
|
||||
$pos++;
|
||||
}
|
||||
$self->resumptionToken( new C4::OAI::ResumptionToken(
|
||||
metadataPrefix => $token->{metadata_prefix},
|
||||
from => $token->{from},
|
||||
until => $token->{until},
|
||||
offset => $pos ) );
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
# __END__ C4::OAI::ListRecords
|
||||
|
||||
|
||||
|
||||
package C4::OAI::Repository;
|
||||
|
||||
use base ("HTTP::OAI::Repository");
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use diagnostics;
|
||||
|
||||
use HTTP::OAI;
|
||||
use HTTP::OAI::Repository qw/:validate/;
|
||||
|
||||
use XML::SAX::Writer;
|
||||
use XML::LibXML;
|
||||
use XML::LibXSLT;
|
||||
use CGI qw/:standard -oldstyle_urls/;
|
||||
|
||||
use C4::Context;
|
||||
use C4::Biblio;
|
||||
|
||||
|
||||
=head1 NAME
|
||||
|
||||
C4::OAI::Repository - Handles OAI-PMH requests for a Koha database.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use C4::OAI::Repository;
|
||||
|
||||
my $repository = C4::OAI::Repository->new();
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This object extend HTTP::OAI::Repository object.
|
||||
|
||||
=cut
|
||||
|
||||
|
||||
|
||||
sub new {
|
||||
my ($class, %args) = @_;
|
||||
my $self = $class->SUPER::new(%args);
|
||||
|
||||
$self->{ koha_identifier } = C4::Context->preference("OAI-PMH:archiveID");
|
||||
$self->{ koha_max_count } = C4::Context->preference("OAI-PMH:MaxCount");
|
||||
$self->{ koha_metadata_format } = ['oai_dc', 'marcxml'];
|
||||
|
||||
# Check for grammatical errors in the request
|
||||
my @errs = validate_request( CGI::Vars() );
|
||||
|
||||
# Is metadataPrefix supported by the respository?
|
||||
my $mdp = param('metadataPrefix') || '';
|
||||
if ( $mdp && !grep { $_ eq $mdp } @{$self->{ koha_metadata_format }} ) {
|
||||
push @errs, new HTTP::OAI::Error(
|
||||
code => 'cannotDisseminateFormat',
|
||||
message => "Dissemination as '$mdp' is not supported",
|
||||
);
|
||||
}
|
||||
|
||||
my $response;
|
||||
if ( @errs ) {
|
||||
$response = HTTP::OAI::Response->new(
|
||||
requestURL => self_url(),
|
||||
errors => \@errs,
|
||||
);
|
||||
}
|
||||
else {
|
||||
my %attr = CGI::Vars();
|
||||
my $verb = delete( $attr{verb} );
|
||||
if ( grep { $_ eq $verb } qw( ListSets ) ) {
|
||||
$response = HTTP::OAI::Response->new(
|
||||
requestURL => $self->self_url(),
|
||||
errors => [ new HTTP::OAI::Error(
|
||||
code => 'noSetHierarchy',
|
||||
message => "Koha repository doesn't have sets",
|
||||
) ] ,
|
||||
);
|
||||
}
|
||||
elsif ( $verb eq 'Identify' ) {
|
||||
$response = C4::OAI::Identify->new( $self );
|
||||
}
|
||||
elsif ( $verb eq 'ListMetadataFormats' ) {
|
||||
$response = C4::OAI::ListMetadataFormats->new( $self );
|
||||
}
|
||||
elsif ( $verb eq 'GetRecord' ) {
|
||||
$response = C4::OAI::GetRecord->new( $self, %attr );
|
||||
}
|
||||
elsif ( $verb eq 'ListRecords' ) {
|
||||
$response = C4::OAI::ListRecords->new( $self, %attr );
|
||||
}
|
||||
elsif ( $verb eq 'ListIdentifiers' ) {
|
||||
$response = C4::OAI::ListIdentifiers->new( $self, %attr );
|
||||
}
|
||||
}
|
||||
|
||||
$response->set_handler( XML::SAX::Writer->new( Output => *STDOUT ) );
|
||||
$response->generate;
|
||||
|
||||
bless $self, $class;
|
||||
return $self;
|
||||
}
|
||||
|
||||
|
||||
#
|
||||
# XSLT stylesheet used to transform MARCXML record into OAI Dublin Core.
|
||||
# The object is constructed the fist time this method is called.
|
||||
#
|
||||
# Styleeet file is located in /koha-tmpl/intranet-tmpl/prog/en/xslt/ directory.
|
||||
# Its name is constructed with 'marcflavour' syspref:
|
||||
# - MARC21slim2OAIDC.xsl
|
||||
# - UNIMARCslim2OADIC.xsl
|
||||
#
|
||||
sub oai_dc_stylesheet {
|
||||
my $self = shift;
|
||||
|
||||
unless ( $self->{ oai_dc_stylesheet } ) {
|
||||
my $xslt_file = C4::Context->config('intranetdir') .
|
||||
"/koha-tmpl/intranet-tmpl/prog/en/xslt/" .
|
||||
C4::Context->preference('marcflavour') .
|
||||
"slim2OAIDC.xsl";
|
||||
my $parser = XML::LibXML->new();
|
||||
my $xslt = XML::LibXSLT->new();
|
||||
my $style_doc = $parser->parse_file( $xslt_file );
|
||||
my $stylesheet = $xslt->parse_stylesheet( $style_doc );
|
||||
$self->{ oai_dc_stylesheet } = $stylesheet;
|
||||
}
|
||||
|
||||
return $self->{ oai_dc_stylesheet };
|
||||
}
|
||||
|
||||
Loading…
Reference in New Issue