--- /dev/null
+# ---------------------------------------------------------------------
+# 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 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 = "<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 . 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;
+
--- /dev/null
+# ---------------------------------------------------------------------
+# 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 .= "<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 ) ],
+ },
+ '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 .= "<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
--- /dev/null
+# ---------------------------------------------------------------------
+# 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;
$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;
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');
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');
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)) {
<li <!-- TMPL_IF NAME="Patrons" -->class="active" <!-- /TMPL_IF -->><a title="Patrons" href="/cgi-bin/koha/admin/systempreferences.pl?tab=Patrons">Patrons</a></li>
<li <!-- TMPL_IF NAME="Searching" -->class="active" <!-- /TMPL_IF -->><a title="Searching" href="/cgi-bin/koha/admin/systempreferences.pl?tab=Searching">Searching</a></li>
<li <!-- TMPL_IF NAME="StaffClient" -->class="active" <!-- /TMPL_IF -->><a title="Staff Client" href="/cgi-bin/koha/admin/systempreferences.pl?tab=StaffClient">Staff Client</a></li>
+ <li <!-- TMPL_IF NAME="OAI-PMH" -->class="active" <!-- /TMPL_IF -->><a title="OAI-PMH" href="/cgi-bin/koha/admin/systempreferences.pl?tab=OAI-PMH">OAI-PMH</a></li>
<li <!-- TMPL_IF NAME="" -->class="active" <!-- /TMPL_IF -->><a href="/cgi-bin/koha/admin/systempreferences.pl">Local Use</a></li>
</ul>
</div>
<li>Andrew Arensburger (the small and great C4::Context module)</li>
<li>Benedykt P. Barszcz (Polish for 2.0)</li>
<li>Brig C. McCoy</li>
- <li>Chris Catalfo (new plugin MARC editor)</li>
+ <li>Chris Catalfo (new plugin MARC editor)</li>
<li>Daniel Holth</li>
<li>David Strainchamps</li>
<li>Dorian Meid (German translation)</li>
<li>doXulting (Matthieu Branlat) OPAC basket</li>
<li>Ed Summers (Some code and Perl packages like MARC::Record)</li>
+ <li>Ecole des Mines de Saint Etienne, Philippe Jaillon (OAI-PMH support)</li>
<li>Esiee School (Jérome Vizcaino, Michel Lerenard, Pierre Cauchois)</li>
- <li>Finlay Thompson</li>
+ <li>Finlay Thompson</li>
<li>Florian Bischof</li>
<li>Francisco M. Marzoa Alonso</li>
<li>Glen Stewart</li>
- <li>Gynn Lomax</li>
+ <li>Gynn Lomax</li>
<li>Jo Ransom</li>
<li>Kip DeGraaf</li>
<li>Marco Gaiarin</li>
--- /dev/null
+#!/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<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") ) ) ];
+}
+
+=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 ) );
+ $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<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'} ) );
+ $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;
projects / koha.git / commitdiff