From 84d43a75786567d5bcf6a9c6cbc7c76ce3271a4e Mon Sep 17 00:00:00 2001 From: Tomas Cohen Arazi Date: Tue, 20 Mar 2018 11:22:02 -0300 Subject: [PATCH] [ALTERNATIVE] Bug 20437: Add HTTP::OAI@3.27 to the source tree --- HTTP/OAI.pm | 96 ++++++++ HTTP/OAI/Debug.pm | 80 +++++++ HTTP/OAI/Encapsulation.pm | 109 +++++++++ HTTP/OAI/Error.pm | 118 +++++++++ HTTP/OAI/GetRecord.pm | 114 +++++++++ HTTP/OAI/Harvester.pm | 464 ++++++++++++++++++++++++++++++++++++ HTTP/OAI/Header.pm | 166 +++++++++++++ HTTP/OAI/Headers.pm | 249 +++++++++++++++++++ HTTP/OAI/Identify.pm | 194 +++++++++++++++ HTTP/OAI/ListIdentifiers.pm | 118 +++++++++ HTTP/OAI/ListMetadataFormats.pm | 103 ++++++++ HTTP/OAI/ListRecords.pm | 133 +++++++++++ HTTP/OAI/ListSets.pm | 120 ++++++++++ HTTP/OAI/Metadata.pm | 35 +++ HTTP/OAI/Metadata/METS.pm | 66 +++++ HTTP/OAI/Metadata/OAI_DC.pm | 161 +++++++++++++ HTTP/OAI/Metadata/OAI_Eprints.pm | 42 ++++ HTTP/OAI/Metadata/OAI_Identifier.pm | 29 +++ HTTP/OAI/MetadataFormat.pm | 94 ++++++++ HTTP/OAI/PartialList.pm | 43 ++++ HTTP/OAI/Record.pm | 157 ++++++++++++ HTTP/OAI/Repository.pm | 271 +++++++++++++++++++++ HTTP/OAI/Response.pm | 420 ++++++++++++++++++++++++++++++++ HTTP/OAI/ResumptionToken.pm | 93 ++++++++ HTTP/OAI/SAXHandler.pm | 266 +++++++++++++++++++++ HTTP/OAI/Set.pm | 94 ++++++++ HTTP/OAI/UserAgent.pm | 320 +++++++++++++++++++++++++ Makefile.PL | 1 + 28 files changed, 4156 insertions(+) create mode 100644 HTTP/OAI.pm create mode 100644 HTTP/OAI/Debug.pm create mode 100644 HTTP/OAI/Encapsulation.pm create mode 100644 HTTP/OAI/Error.pm create mode 100644 HTTP/OAI/GetRecord.pm create mode 100644 HTTP/OAI/Harvester.pm create mode 100644 HTTP/OAI/Header.pm create mode 100644 HTTP/OAI/Headers.pm create mode 100644 HTTP/OAI/Identify.pm create mode 100644 HTTP/OAI/ListIdentifiers.pm create mode 100644 HTTP/OAI/ListMetadataFormats.pm create mode 100644 HTTP/OAI/ListRecords.pm create mode 100644 HTTP/OAI/ListSets.pm create mode 100644 HTTP/OAI/Metadata.pm create mode 100644 HTTP/OAI/Metadata/METS.pm create mode 100644 HTTP/OAI/Metadata/OAI_DC.pm create mode 100644 HTTP/OAI/Metadata/OAI_Eprints.pm create mode 100644 HTTP/OAI/Metadata/OAI_Identifier.pm create mode 100644 HTTP/OAI/MetadataFormat.pm create mode 100644 HTTP/OAI/PartialList.pm create mode 100644 HTTP/OAI/Record.pm create mode 100644 HTTP/OAI/Repository.pm create mode 100644 HTTP/OAI/Response.pm create mode 100644 HTTP/OAI/ResumptionToken.pm create mode 100644 HTTP/OAI/SAXHandler.pm create mode 100644 HTTP/OAI/Set.pm create mode 100644 HTTP/OAI/UserAgent.pm diff --git a/HTTP/OAI.pm b/HTTP/OAI.pm new file mode 100644 index 0000000000..a8bd20e096 --- /dev/null +++ b/HTTP/OAI.pm @@ -0,0 +1,96 @@ +package HTTP::OAI; + +use strict; + +our $VERSION = '3.27'; + +# perlcore +use Carp; +use Encode; + +# http related stuff +use URI; +use HTTP::Headers; +use HTTP::Request; +use HTTP::Response; + +# xml related stuff +use XML::SAX; +use XML::SAX::ParserFactory; +use XML::LibXML; +use XML::LibXML::SAX; +use XML::LibXML::SAX::Parser; +use XML::LibXML::SAX::Builder; + +# debug +use HTTP::OAI::Debug; + +# oai data objects +use HTTP::OAI::Encapsulation; # Basic XML handling stuff +use HTTP::OAI::Metadata; # Super class of all data objects +use HTTP::OAI::Error; +use HTTP::OAI::Header; +use HTTP::OAI::MetadataFormat; +use HTTP::OAI::Record; +use HTTP::OAI::ResumptionToken; +use HTTP::OAI::Set; + +# parses OAI headers and other utility bits +use HTTP::OAI::Headers; + +# generic superclasses +use HTTP::OAI::Response; +use HTTP::OAI::PartialList; + +# oai verbs +use HTTP::OAI::GetRecord; +use HTTP::OAI::Identify; +use HTTP::OAI::ListIdentifiers; +use HTTP::OAI::ListMetadataFormats; +use HTTP::OAI::ListRecords; +use HTTP::OAI::ListSets; + +# oai agents +use HTTP::OAI::UserAgent; +use HTTP::OAI::Harvester; +use HTTP::OAI::Repository; + +$HTTP::OAI::Harvester::VERSION = $VERSION; + +if( $ENV{HTTP_OAI_TRACE} ) +{ + HTTP::OAI::Debug::level( '+trace' ); +} +if( $ENV{HTTP_OAI_SAX_TRACE} ) +{ + HTTP::OAI::Debug::level( '+sax' ); +} + +1; + +__END__ + +=head1 NAME + +HTTP::OAI - API for the OAI-PMH + +=head1 DESCRIPTION + +This is a stub module, you probably want to look at +L or +L. + +=head1 SEE ALSO + +You can find links to this and other OAI tools (perl, C++, java) at: +http://www.openarchives.org/tools/tools.html. + +Ed Summers L module. + +=head1 AUTHOR + +Copyright 2004-2010 Tim Brody , University of +Southampton. + +This module is free software and is released under the BSD License (see +LICENSE). diff --git a/HTTP/OAI/Debug.pm b/HTTP/OAI/Debug.pm new file mode 100644 index 0000000000..15d36071f4 --- /dev/null +++ b/HTTP/OAI/Debug.pm @@ -0,0 +1,80 @@ +package HTTP::OAI::Debug; + +=pod + +=head1 NAME + +B - debug the HTTP::OAI libraries + +=head1 DESCRIPTION + +This package is a copy of L and exposes the same API. In addition to "trace", "debug" and "conns" this exposes a "sax" level for debugging SAX events. + +=cut + +require Exporter; +@ISA = qw(Exporter); +@EXPORT_OK = qw(level trace debug conns); + +use Carp (); + +my @levels = qw(trace debug conns sax); +%current_level = (); + + +sub import +{ + my $pack = shift; + my $callpkg = caller(0); + my @symbols = (); + my @levels = (); + for (@_) { + if (/^[-+]/) { + push(@levels, $_); + } + else { + push(@symbols, $_); + } + } + Exporter::export($pack, $callpkg, @symbols); + level(@levels); +} + + +sub level +{ + for (@_) { + if ($_ eq '+') { # all on + # switch on all levels + %current_level = map { $_ => 1 } @levels; + } + elsif ($_ eq '-') { # all off + %current_level = (); + } + elsif (/^([-+])(\w+)$/) { + $current_level{$2} = $1 eq '+'; + } + else { + Carp::croak("Illegal level format $_"); + } + } +} + + +sub trace { _log(@_) if $current_level{'trace'}; } +sub debug { _log(@_) if $current_level{'debug'}; } +sub conns { _log(@_) if $current_level{'conns'}; } +sub sax { _log(@_) if $current_level{'sax'}; } + + +sub _log +{ + my $msg = shift; + $msg =~ s/\n$//; + $msg =~ s/\n/\\n/g; + + my($package,$filename,$line,$sub) = caller(2); + print STDERR "$sub: $msg\n"; +} + +1; diff --git a/HTTP/OAI/Encapsulation.pm b/HTTP/OAI/Encapsulation.pm new file mode 100644 index 0000000000..e87a0ad9de --- /dev/null +++ b/HTTP/OAI/Encapsulation.pm @@ -0,0 +1,109 @@ +package HTTP::OAI::Encapsulation; + +use strict; +use warnings; + +use HTTP::OAI::SAXHandler qw( :SAX ); + +use vars qw(@ISA); +@ISA = qw(XML::SAX::Base); + +sub new { + my $class = shift; + my %args = @_ > 1 ? @_ : (dom => shift); + my $self = bless {}, ref($class) || $class; + $self->version($args{version}); + $self->dom($args{dom}); + $self; +} + +sub dom { shift->_elem('dom',@_) } + +# Pseudo HTTP::Response +sub code { 200 } +sub message { 'OK' } + +sub is_info { 0 } +sub is_success { 1 } +sub is_redirect { 0 } +sub is_error { 0 } + +sub version { shift->_elem('version',@_) } + +sub _elem { + my $self = shift; + my $name = shift; + return @_ ? $self->{_elem}->{$name} = shift : $self->{_elem}->{$name}; +} + +sub _attr { + my $self = shift; + my $name = shift or return $self->{_attr}; + return $self->{_attr}->{$name} unless @_; + if( defined(my $value = shift) ) { + return $self->{_attr}->{$name} = $value; + } else { + delete $self->{_attr}->{$name}; + return undef; + } +} + +package HTTP::OAI::Encapsulation::DOM; + +use strict; +use warnings; + +use XML::LibXML qw( :all ); + +use vars qw(@ISA); +@ISA = qw(HTTP::OAI::Encapsulation); + +sub toString { defined($_[0]->dom) ? $_[0]->dom->toString : undef } + +sub generate { + my $self = shift; + unless( $self->dom ) { + Carp::confess("Can't generate() without a dom."); + } + unless( $self->dom->nodeType == XML_DOCUMENT_NODE ) { + Carp::confess( "Can only generate() from a DOM of type XML_DOCUMENT_NODE" ); + } + return unless defined($self->get_handler); + my $driver = XML::LibXML::SAX::Parser->new( + Handler=>HTTP::OAI::FilterDOMFragment->new( + Handler=>$self->get_handler + )); + $driver->generate($self->dom); +} + +sub start_document { + my ($self) = @_; +HTTP::OAI::Debug::sax( ref($self) ); + my $builder = XML::LibXML::SAX::Builder->new() or die "Unable to create XML::LibXML::SAX::Builder: $!"; + $self->{OLDHandler} = $self->get_handler(); + $self->set_handler($builder); + $self->SUPER::start_document(); + $self->SUPER::xml_decl({'Version'=>'1.0','Encoding'=>'UTF-8'}); +} + +sub end_document { + my ($self) = @_; + $self->SUPER::end_document(); + $self->dom($self->get_handler->result()); + $self->set_handler($self->{OLDHandler}); +HTTP::OAI::Debug::sax( ref($self) . " <" . $self->dom->documentElement->nodeName . " />" ); +} + +1; + +__END__ + +=head1 NAME + +HTTP::OAI::Encapsulation - Base class for data objects that contain DOM trees + +=head1 DESCRIPTION + +This class shouldn't be used directly, use L. + +=cut diff --git a/HTTP/OAI/Error.pm b/HTTP/OAI/Error.pm new file mode 100644 index 0000000000..0c81637bf7 --- /dev/null +++ b/HTTP/OAI/Error.pm @@ -0,0 +1,118 @@ +package HTTP::OAI::Error; + +use strict; +use warnings; + +use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAG); + +use vars qw( + $PARSER +); + +$PARSER = 600; + +use Exporter; +use HTTP::OAI::SAXHandler qw( :SAX ); + +@ISA = qw(HTTP::OAI::Encapsulation Exporter); + +@EXPORT = qw(); +@EXPORT_OK = qw(%OAI_ERRORS); +%EXPORT_TAG = (); + +my %OAI_ERRORS = ( + badArgument => 'The request includes illegal arguments, is missing required arguments, includes a repeated argument, or values for arguments have an illegal syntax.', +# badGranularity => 'The values of the from and until arguments are illegal or specify a finer granularity than is supported by the repository.', + badResumptionToken => 'The value of the resumptionToken argument is invalid or expired.', + badVerb => 'Value of the verb argument is not a legal OAI-PMH verb, the verb argument is missing, or the verb argument is repeated.', + cannotDisseminateFormat => 'The metadata format identified by the value given for the metadataPrefix argument is not supported by the item or by the repository', + idDoesNotExist => 'The value of the identifier argument is unknown or illegal in this repository.', + noRecordsMatch => 'The combination of the values of the from, until, set, and metadataPrefix arguments results in an empty list.', + noMetadataFormats => 'There are no metadata formats available for the specified item.', + noSetHierarchy => 'The repository does not support sets.' +); + +sub new { + my ($class,%args) = @_; + my $self = $class->SUPER::new(%args); + + $self->code($args{code}); + $self->message($args{message}); + + $self; +} + +sub code { shift->_elem('code',@_) } +sub message { shift->_elem('message',@_) } + +sub toString { + my $self = shift; + return $self->code . " (\"" . ($self->message || 'No further information available') . "\")"; +} + +sub generate { + my ($self) = @_; + return unless defined(my $handler = $self->get_handler); + Carp::croak ref($self)."::generate Error code undefined" unless defined($self->code); + + g_data_element($handler, + 'http://www.openarchives.org/OAI/2.0/', + 'error', + { + '{}code'=>{ + 'LocalName' => 'code', + 'Prefix' => '', + 'Value' => $self->code, + 'Name' => 'code', + 'NamespaceURI' => '', + }, + }, + ($self->message || $OAI_ERRORS{$self->code} || '') + ); +} + +1; + +__END__ + +=head1 NAME + +HTTP::OAI::Error - Encapsulates OAI error codes + +=head1 METHODS + +=over 4 + +=item $err = new HTTP::OAI::Error(code=>'badArgument',[message=>'An incorrect argument was supplied']) + +This constructor method returns a new HTTP::OAI::Error object. + +If no message is specified, and the code is a valid OAI error code, the appropriate message from the OAI protocol document is the default message. + +=item $code = $err->code([$code]) + +Returns and optionally sets the error name. + +=item $msg = $err->message([$msg]) + +Returns and optionally sets the error message. + +=back + +=head1 NOTE - noRecordsMatch + +noRecordsMatch, without additional errors, is not treated as an error code. If noRecordsMatch was returned by a repository the HTTP::OAI::Response object will have a verb 'error' and will contain the noRecordsMatch error, however is_success will return true. + +e.g. + + my $r = $ha->ListIdentifiers(metadataPrefix='oai_dc',from=>'3000-02-02'); + + if( $r->is_success ) { + print "Successful\n"; + } else { + print "Failed\n"; + } + + print $r->verb, "\n"; + +Will print "Successful" followed by "error". diff --git a/HTTP/OAI/GetRecord.pm b/HTTP/OAI/GetRecord.pm new file mode 100644 index 0000000000..cd0ad13b02 --- /dev/null +++ b/HTTP/OAI/GetRecord.pm @@ -0,0 +1,114 @@ +package HTTP::OAI::GetRecord; + +use strict; +use warnings; + +use HTTP::OAI::SAXHandler qw/ :SAX /; + +use vars qw(@ISA); + +@ISA = qw( HTTP::OAI::Response ); + +sub new { + my ($class,%args) = @_; + + $args{handlers} ||= {}; + $args{handlers}->{header} ||= "HTTP::OAI::Header"; + $args{handlers}->{metadata} ||= "HTTP::OAI::Metadata"; + $args{handlers}->{about} ||= "HTTP::OAI::Metadata"; + + my $self = $class->SUPER::new(%args); + + $self->verb('GetRecord') unless $self->verb; + + $self->{record} ||= []; + $self->record($args{record}) if defined($args{record}); + + return $self; +} + +sub record { + my $self = shift; + $self->{record} = [shift] if @_; + return wantarray ? + @{$self->{record}} : + $self->{record}->[0]; +} +sub next { shift @{shift->{record}} } + +sub generate_body { + my ($self) = @_; + + for( $self->record ) { + $_->set_handler($self->get_handler); + $_->generate; + } +} + +sub start_element { + my ($self,$hash) = @_; + my $elem = $hash->{LocalName}; + if( $elem eq 'record' && !exists($self->{"in_record"}) ) { + $self->{OLDHandler} = $self->get_handler; + my $rec = HTTP::OAI::Record->new( + version=>$self->version, + handlers=>$self->{handlers}, + ); + $self->record($rec); + $self->set_handler($rec); + $self->{"in_record"} = $hash->{Depth}; + } + $self->SUPER::start_element($hash); +} + +sub end_element { + my ($self,$hash) = @_; + $self->SUPER::end_element($hash); + my $elem = lc($hash->{LocalName}); + if( $elem eq 'record' && + exists($self->{"in_record"}) && + $self->{"in_record"} == $hash->{Depth} ) { + $self->set_handler($self->{OLDHandler}); + } +} + +1; + +__END__ + +=head1 NAME + +HTTP::OAI::GetRecord - An OAI GetRecord response + +=head1 DESCRIPTION + +HTTP::OAI::GetRecord is derived from L and provides access to the data contained in an OAI GetRecord response in addition to the header information provided by OAI::Response. + +=head1 SYNOPSIS + + use HTTP::OAI::GetRecord(); + + $res = new HTTP::OAI::GetRecord(); + $res->record($rec); + +=head1 METHODS + +=over 4 + +=item $gr = new HTTP::OAI::GetRecord + +This constructor method returns a new HTTP::OAI::GetRecord object. + +=item $rec = $gr->next + +Returns the next record stored in the response, or undef if no more record are available. The record is returned as an L. + +=item @recs = $gr->record([$rec]) + +Returns the record list, and optionally adds a record to the end of the queue. GetRecord will only store one record at a time, so this method will replace any existing record if called with argument(s). + +=item $dom = $gr->toDOM() + +Returns an XML::DOM object representing the GetRecord response. + +=back diff --git a/HTTP/OAI/Harvester.pm b/HTTP/OAI/Harvester.pm new file mode 100644 index 0000000000..2b0ea489aa --- /dev/null +++ b/HTTP/OAI/Harvester.pm @@ -0,0 +1,464 @@ +package HTTP::OAI::Harvester; + +use strict; +use warnings; + +use vars qw( @ISA ); + +@ISA = qw( HTTP::OAI::UserAgent ); + +sub new { + my ($class,%args) = @_; + my %ARGS = %args; + delete @ARGS{qw(baseURL resume repository handlers onRecord)}; + my $self = $class->SUPER::new(%ARGS); + + $self->{'resume'} = exists($args{resume}) ? $args{resume} : 1; + $self->{'handlers'} = $args{'handlers'}; + $self->{'onRecord'} = $args{'onRecord'}; + $self->agent('OAI-PERL/'.$HTTP::OAI::VERSION); + + # Record the base URL this harvester instance is associated with + $self->{repository} = + $args{repository} || + HTTP::OAI::Identify->new(baseURL=>$args{baseURL}); + Carp::croak "Requires repository or baseURL" unless $self->repository and $self->repository->baseURL; + # Canonicalise + $self->baseURL($self->baseURL); + + return $self; +} + +sub resume { + my $self = shift; + return @_ ? $self->{resume} = shift : $self->{resume}; +} + +sub repository { + my $self = shift; + return $self->{repository} unless @_; + my $id = shift; + # Don't clobber a good existing base URL with a bad one + if( $self->{repository} && $self->{repository}->baseURL ) { + if( !$id->baseURL ) { + Carp::carp "Attempt to set a non-existant baseURL"; + $id->baseURL($self->baseURL); + } else { + my $uri = URI->new($id->baseURL); + if( $uri && $uri->scheme ) { + $id->baseURL($uri->canonical); + } else { + Carp::carp "Ignoring attempt to use an invalid base URL: " . $id->baseURL; + $id->baseURL($self->baseURL); + } + } + } + return $self->{repository} = $id; +} + +sub baseURL { + my $self = shift; + return @_ ? + $self->repository->baseURL(URI->new(shift)->canonical) : + $self->repository->baseURL(); +} + +sub version { shift->repository->version(@_); } + +# build the methods for each OAI verb +foreach my $verb (qw( GetRecord Identify ListIdentifiers ListMetadataFormats ListRecords ListSets )) +{ + no strict "refs"; + *$verb = sub { shift->_oai( verb => $verb, @_ )}; +} + +sub _oai { + my( $self, %args ) = @_; + + my $verb = $args{verb} or Carp::croak "Requires verb argument"; + + my $handlers = delete($args{handlers}) || $self->{'handlers'}; + my $onRecord = delete($args{onRecord}) || $self->{'onRecord'}; + + if( !$args{force} && + defined($self->repository->version) && + '2.0' eq $self->repository->version && + (my @errors = HTTP::OAI::Repository::validate_request(%args)) ) { + return new HTTP::OAI::Response( + code=>503, + message=>'Invalid Request (use \'force\' to force a non-conformant request): ' . $errors[0]->toString, + errors=>\@errors + ); + } + + delete $args{force}; + # Get rid of any empty arguments + for( keys %args ) { + delete $args{$_} if !defined($args{$_}) || !length($args{$_}); + } + + # Check for a static repository (sets _static) + if( !$self->{_interogated} ) { + $self->interogate(); + $self->{_interogated} = 1; + } + + if( 'ListIdentifiers' eq $verb && + defined($self->repository->version) && + '1.1' eq $self->repository->version ) { + delete $args{metadataPrefix}; + } + + my $r = "HTTP::OAI::$verb"->new( + harvestAgent => $self, + resume => $self->resume, + handlers => $handlers, + onRecord => $onRecord, + ); + $r->headers->{_args} = \%args; + + # Parse all the records if _static set + if( defined($self->{_static}) && !defined($self->{_records}) ) { + my $lmdf = HTTP::OAI::ListMetadataFormats->new( + handlers => $handlers, + ); + $lmdf->headers->{_args} = { + %args, + verb=>'ListMetadataFormats', + }; + # Find the metadata formats + $lmdf = $lmdf->parse_string($self->{_static}); + return $lmdf unless $lmdf->is_success; + @{$self->{_formats}} = $lmdf->metadataFormat; + # Extract all records + $self->{_records} = {}; + for($lmdf->metadataFormat) { + my $lr = HTTP::OAI::ListRecords->new( + handlers => $handlers, + ); + $lr->headers->{_args} = { + %args, + verb=>'ListRecords', + metadataPrefix=>$_->metadataPrefix, + }; + $lr->parse_string($self->{_static}); + return $lr if !$lr->is_success; + @{$self->{_records}->{$_->metadataPrefix}} = $lr->record; + } + undef($self->{_static}); + } + + # Make the remote request and return the result + if( !defined($self->{_records}) ) { + $r = $self->request({baseURL=>$self->baseURL,%args},undef,undef,undef,$r); + # Lets call next() for the user if she's using the callback interface + if( $onRecord and $r->is_success and $r->isa("HTTP::OAI::PartialList") ) { + $r->next; + } + return $r; + # Parse our memory copy of the static repository + } else { + $r->code(200); + # Format doesn't exist + if( $verb =~ /^GetRecord|ListIdentifiers|ListRecords$/ && + !exists($self->{_records}->{$args{metadataPrefix}}) ) { + $r->code(600); + $r->errors(HTTP::OAI::Error->new( + code=>'cannotDisseminateFormat', + )); + # GetRecord + } elsif( $verb eq 'GetRecord' ) { + for(@{$self->{_records}->{$args{metadataPrefix}}}) { + if( $_->identifier eq $args{identifier} ) { + $r->record($_); + return $r; + } + } + $r->code(600); + $r->errors(HTTP::OAI::Error->new( + code=>'idDoesNotExist' + )); + # Identify + } elsif( $verb eq 'Identify' ) { + $r = $self->repository(); + # ListIdentifiers + } elsif( $verb eq 'ListIdentifiers' ) { + $r->identifier(map { $_->header } @{$self->{_records}->{$args{metadataPrefix}}}) + # ListMetadataFormats + } elsif( $verb eq 'ListMetadataFormats' ) { + $r->metadataFormat(@{$self->{_formats}}); + # ListRecords + } elsif( $verb eq 'ListRecords' ) { + $r->record(@{$self->{_records}->{$args{metadataPrefix}}}); + # ListSets + } elsif( $verb eq 'ListSets' ) { + $r->errors(HTTP::OAI::Error->new( + code=>'noSetHierarchy', + message=>'Static Repositories do not support sets', + )); + } + return $r; + } +} + +sub interogate { + my $self = shift; + Carp::croak "Requires baseURL" unless $self->baseURL; + +HTTP::OAI::Debug::trace($self->baseURL); + my $r = $self->request(HTTP::Request->new(GET => $self->baseURL)); + return unless length($r->content); + my $id = HTTP::OAI::Identify->new( + handlers=>$self->{handlers}, + ); + $id->headers->{_args} = {verb=>'Identify'}; + $id->parse_string($r->content); + if( $id->is_success && $id->version eq '2.0s' ) { + $self->{_static} = $r->content; + $self->repository($id); + } +HTTP::OAI::Debug::trace("version = ".$id->version) if $id->is_success; +} + +1; + +__END__ + +=head1 NAME + +HTTP::OAI::Harvester - Agent for harvesting from Open Archives version 1.0, 1.1, 2.0 and static ('2.0s') compatible repositories + +=head1 DESCRIPTION + +C is the harvesting front-end in the OAI-PERL library. + +To harvest from an OAI-PMH compliant repository create an C object using the baseURL option and then call OAI-PMH methods to request data from the repository. To handle version 1.0/1.1 repositories automatically you B request C first. + +It is recommended that you request an Identify from the Repository and use the C method to update the Identify object used by the harvester. + +When making OAI requests the underlying L module will take care of automatic redirection (http code 302) and retry-after (http code 503). OAI-PMH flow control (i.e. resumption tokens) is handled transparently by C. + +=head2 Static Repository Support + +Static repositories are automatically and transparently supported within the existing API. To harvest a static repository specify the repository XML file using the baseURL argument to HTTP::OAI::Harvester. An initial request is made that determines whether the base URL specifies a static repository or a normal OAI 1.x/2.0 CGI repository. To prevent this initial request state the OAI version using an HTTP::OAI::Identify object e.g. + + $h = HTTP::OAI::Harvester->new( + repository=>HTTP::OAI::Identify->new( + baseURL => 'http://arXiv.org/oai2', + version => '2.0', + )); + +If a static repository is found the response is cached, and further requests are served by that cache. Static repositories do not support sets, and will result in a noSetHierarchy error if you try to use sets. You can determine whether the repository is static by checking the version ($ha->repository->version), which will be "2.0s" for static repositories. + +=head1 FURTHER READING + +You should refer to the Open Archives Protocol version 2.0 and other OAI documentation, available from http://www.openarchives.org/. + +Note OAI-PMH 1.0 and 1.1 are deprecated. + +=head1 BEFORE USING EXAMPLES + +In the examples I use arXiv.org's and cogprints OAI interfaces. To avoid causing annoyance to their server administrators please contact them before performing testing or large downloads (or use other, less loaded, servers for testing). + +=head1 SYNOPSIS + + use HTTP::OAI; + + my $h = new HTTP::OAI::Harvester(baseURL=>'http://arXiv.org/oai2'); + my $response = $h->repository($h->Identify) + if( $response->is_error ) { + print "Error requesting Identify:\n", + $response->code . " " . $response->message, "\n"; + exit; + } + + # Note: repositoryVersion will always be 2.0, $r->version returns + # the actual version the repository is running + print "Repository supports protocol version ", $response->version, "\n"; + + # Version 1.x repositories don't support metadataPrefix, + # but OAI-PERL will drop the prefix automatically + # if an Identify was requested first (as above) + $response = $h->ListIdentifiers( + metadataPrefix=>'oai_dc', + from=>'2001-02-03', + until=>'2001-04-10' + ); + + if( $response->is_error ) { + die("Error harvesting: " . $response->message . "\n"); + } + + print "responseDate => ", $response->responseDate, "\n", + "requestURL => ", $response->requestURL, "\n"; + + while( my $id = $response->next ) { + print "identifier => ", $id->identifier; + # Only available from OAI 2.0 repositories + print " (", $id->datestamp, ")" if $id->datestamp; + print " (", $id->status, ")" if $id->status; + print "\n"; + # Only available from OAI 2.0 repositories + for( $id->setSpec ) { + print "\t", $_, "\n"; + } + } + + # Using a handler + $response = $h->ListRecords( + metadataPrefix=>'oai_dc', + handlers=>{metadata=>'HTTP::OAI::Metadata::OAI_DC'}, + ); + while( my $rec = $response->next ) { + print $rec->identifier, "\t", + $rec->datestamp, "\n", + $rec->metadata, "\n"; + print join(',', @{$rec->metadata->dc->{'title'}}), "\n"; + } + if( $rec->is_error ) { + die $response->message; + } + + # Offline parsing + $I = HTTP::OAI::Identify->new(); + $I->parse_string($content); + $I->parse_file($fh); + +=head1 METHODS + +=over 4 + +=item HTTP::OAI::Harvester->new( %params ) + +This constructor method returns a new instance of C. Requires either an L object, which in turn must contain a baseURL, or a baseURL from which to construct an Identify object. + +Any other parameters are passed to the L module, and from there to the L module. + + $h = HTTP::OAI::Harvester->new( + baseURL => 'http://arXiv.org/oai2', + resume=>0, # Suppress automatic resumption + ) + $id = $h->repository(); + $h->repository($h->Identify); + + $h = HTTP::OAI::Harvester->new( + HTTP::OAI::Identify->new( + baseURL => 'http://arXiv.org/oai2', + )); + +=item $h->repository() + +Returns and optionally sets the L object used by the Harvester agent. + +=item $h->resume( [1] ) + +If set to true (default) resumption tokens will automatically be handled by requesting the next partial list during C calls. + +=back + +=head1 OAI-PMH Verbs + +The 6 OAI-PMH Verbs are the requests supported by an OAI-PMH interface. + +=head2 Error Messages + +Use C or C on the returned object to determine whether an error occurred (see L). + +C and C return the error code (200 is success) and a human-readable message respectively. L returned by the repository can be retrieved using the C method: + + foreach my $error ($r->errors) { + print $error->code, "\t", $error->message, "\n"; + } + +Note: C is true for the OAI Error Code C (i.e. empty set), although C will still contain the OAI error. + +=head2 Flow Control + +If the response contained a L this can be retrieved using the $r->resumptionToken method. + +=head2 Methods + +These methods return an object subclassed from L (where the class corresponds to the verb requested, e.g. C requests return an C object). + +=over 4 + +=item $r = $h->GetRecord( %params ) + +Get a single record from the repository identified by identifier, in format metadataPrefix. + + $gr = $h->GetRecord( + identifier => 'oai:arXiv:hep-th/0001001', # Required + metadataPrefix => 'oai_dc' # Required + ); + $rec = $gr->next; + die $rec->message if $rec->is_error; + printf("%s (%s)\n", $rec->identifier, $rec->datestamp); + $dom = $rec->metadata->dom; + +=item $r = $h->Identify() + +Get information about the repository. + + $id = $h->Identify(); + print join ',', $id->adminEmail; + +=item $r = $h->ListIdentifiers( %params ) + +Retrieve the identifiers, datestamps, sets and deleted status for all records within the specified date range (from/until) and set spec (set). 1.x repositories will only return the identifier. Or, resume an existing harvest by specifying resumptionToken. + + $lr = $h->ListIdentifiers( + metadataPrefix => 'oai_dc', # Required + from => '2001-10-01', + until => '2001-10-31', + set=>'physics:hep-th', + ); + while($rec = $lr->next) + { + { ... do something with $rec ... } + } + die $lr->message if $lr->is_error; + +=item $r = $h->ListMetadataFormats( %params ) + +List available metadata formats. Given an identifier the repository should only return those metadata formats for which that item can be disseminated. + + $lmdf = $h->ListMetadataFormats( + identifier => 'oai:arXiv.org:hep-th/0001001' + ); + for($lmdf->metadataFormat) { + print $_->metadataPrefix, "\n"; + } + die $lmdf->message if $lmdf->is_error; + +=item $r = $h->ListRecords( %params ) + +Return full records within the specified date range (from/until), set and metadata format. Or, specify a resumption token to resume a previous partial harvest. + + $lr = $h->ListRecords( + metadataPrefix=>'oai_dc', # Required + from => '2001-10-01', + until => '2001-10-01', + set => 'physics:hep-th', + ); + while($rec = $lr->next) + { + { ... do something with $rec ... } + } + die $lr->message if $lr->is_error; + +=item $r = $h->ListSets( %params ) + +Return a list of sets provided by the repository. The scope of sets is undefined by OAI-PMH, so therefore may represent any subset of a collection. Optionally provide a resumption token to resume a previous partial request. + + $ls = $h->ListSets(); + while($set = $ls->next) + { + print $set->setSpec, "\n"; + } + die $ls->message if $ls->is_error; + +=back + +=head1 AUTHOR + +These modules have been written by Tim Brody Etdb01r@ecs.soton.ac.ukE. diff --git a/HTTP/OAI/Header.pm b/HTTP/OAI/Header.pm new file mode 100644 index 0000000000..8eca717c3d --- /dev/null +++ b/HTTP/OAI/Header.pm @@ -0,0 +1,166 @@ +package HTTP::OAI::Header; + +use strict; +use warnings; + +use POSIX qw/strftime/; + +use vars qw(@ISA); + +use HTTP::OAI::SAXHandler qw( :SAX ); + +@ISA = qw(HTTP::OAI::Encapsulation); + +sub new { + my ($class,%args) = @_; + my $self = $class->SUPER::new(%args); + + $self->identifier($args{identifier}) unless $self->identifier; + $self->datestamp($args{datestamp}) unless $self->datestamp; + $self->status($args{status}) unless $self->status; + $self->{setSpec} ||= $args{setSpec} || []; + + $self; +} + +sub identifier { shift->_elem('identifier',@_) } +sub now { return strftime("%Y-%m-%dT%H:%M:%SZ",gmtime()) } +sub datestamp { + my $self = shift; + return $self->_elem('datestamp') unless @_; + my $ds = shift or return $self->_elem('datestamp',undef); + if( $ds =~ /^(\d{4})(\d{2})(\d{2})$/ ) { + $ds = "$1-$2-$3"; + } elsif( $ds =~ /^(\d{4})(\d{2})(\d{2})(\d{2})(\d{2})(\d{2})$/ ) { + $ds = "$1-$2-$3T$4:$5:$6Z"; + } + return $self->_elem('datestamp',$ds); +} +sub status { shift->_attr('status',@_) } +sub is_deleted { my $s = shift->status(); return defined($s) && $s eq 'deleted'; } + +sub setSpec { + my $self = shift; + push(@{$self->{setSpec}},@_); + @{$self->{setSpec}}; +} + +sub dom { + my $self = shift; + if( my $dom = shift ) { + my $driver = XML::LibXML::SAX::Parser->new( + Handler=>HTTP::OAI::SAXHandler->new( + Handler=>$self + )); + $driver->generate($dom->ownerDocument); + } else { + $self->set_handler(my $builder = XML::LibXML::SAX::Builder->new()); + g_start_document($self); + $self->xml_decl({'Version'=>'1.0','Encoding'=>'UTF-8'}); + $self->characters({'Data'=>"\n"}); + $self->generate(); + $self->end_document(); + return $builder->result; + } +} + +sub generate { + my ($self) = @_; + return unless defined(my $handler = $self->get_handler); + + if( defined($self->status) ) { + g_start_element($handler,'http://www.openarchives.org/OAI/2.0/','header', + { + "{}status"=>{ + 'Name'=>'status', + 'LocalName'=>'status', + 'Value'=>$self->status, + 'Prefix'=>'', + 'NamespaceURI'=>'' + } + }); + } else { + g_start_element($handler,'http://www.openarchives.org/OAI/2.0/','header',{}); + } + g_data_element($handler,'http://www.openarchives.org/OAI/2.0/','identifier',{},$self->identifier); + g_data_element($handler,'http://www.openarchives.org/OAI/2.0/','datestamp',{},($self->datestamp || $self->now)); + for($self->setSpec) { + g_data_element($handler,'http://www.openarchives.org/OAI/2.0/','setSpec',{},$_); + } + g_end_element($handler,'http://www.openarchives.org/OAI/2.0/','header'); +} + +sub end_element { + my ($self,$hash) = @_; + my $elem = lc($hash->{LocalName}); + my $text = $hash->{Text}; + if( defined $text ) + { + $text =~ s/^\s+//; + $text =~ s/\s+$//; + } + if( $elem eq 'identifier' ) { + die "HTTP::OAI::Header parse error: Empty identifier\n" unless $text; + $self->identifier($text); + } elsif( $elem eq 'datestamp' ) { + warn "HTTP::OAI::Header parse warning: Empty datestamp for ".$self->identifier."\n" unless $text; + $self->datestamp($text); + } elsif( $elem eq 'setspec' ) { + $self->setSpec($text); + } elsif( $elem eq 'header' ) { + $self->status($hash->{Attributes}->{'{}status'}->{Value}); + } +} + +1; + +__END__ + +=head1 NAME + +HTTP::OAI::Header - Encapsulates an OAI header structure + +=head1 SYNOPSIS + + use HTTP::OAI::Header; + + my $h = new HTTP::OAI::Header( + identifier=>'oai:myarchive.org:2233-add', + datestamp=>'2002-04-12T20:31:00Z', + ); + + $h->setSpec('all:novels'); + +=head1 METHODS + +=over 4 + +=item $h = new HTTP::OAI::Header + +This constructor method returns a new C. + +=item $h->identifier([$identifier]) + +Get and optionally set the record OAI identifier. + +=item $h->datestamp([$datestamp]) + +Get and optionally set the record datestamp (OAI 2.0+). + +=item $h->status([$status]) + +Get and optionally set the record status (valid values are 'deleted' or undef). + +=item $h->is_deleted() + +Returns whether this record's status is deleted. + +=item @sets = $h->setSpec([$setSpec]) + +Returns the list of setSpecs and optionally appends a new setSpec C<$setSpec> (OAI 2.0+). + +=item $dom_fragment = $id->generate() + +Act as a SAX driver (use C<< $h->set_handler() >> to specify the filter to pass events to). + +=back diff --git a/HTTP/OAI/Headers.pm b/HTTP/OAI/Headers.pm new file mode 100644 index 0000000000..b3f4c84f45 --- /dev/null +++ b/HTTP/OAI/Headers.pm @@ -0,0 +1,249 @@ +package HTTP::OAI::Headers; + +use strict; +use warnings; + +use HTTP::OAI::SAXHandler qw( :SAX ); + +use vars qw( @ISA ); + +@ISA = qw( XML::SAX::Base ); + +my %VERSIONS = ( + 'http://www.openarchives.org/oai/1.0/oai_getrecord' => '1.0', + 'http://www.openarchives.org/oai/1.0/oai_identify' => '1.0', + 'http://www.openarchives.org/oai/1.0/oai_listidentifiers' => '1.0', + 'http://www.openarchives.org/oai/1.0/oai_listmetadataformats' => '1.0', + 'http://www.openarchives.org/oai/1.0/oai_listrecords' => '1.0', + 'http://www.openarchives.org/oai/1.0/oai_listsets' => '1.0', + 'http://www.openarchives.org/oai/1.1/oai_getrecord' => '1.1', + 'http://www.openarchives.org/oai/1.1/oai_identify' => '1.1', + 'http://www.openarchives.org/oai/1.1/oai_listidentifiers' => '1.1', + 'http://www.openarchives.org/oai/1.1/oai_listmetadataformats' => '1.1', + 'http://www.openarchives.org/oai/1.1/oai_listrecords' => '1.1', + 'http://www.openarchives.org/oai/1.1/oai_listsets' => '1.1', + 'http://www.openarchives.org/oai/2.0/' => '2.0', + 'http://www.openarchives.org/oai/2.0/static-repository' => '2.0s', +); + +sub new { + my ($class,%args) = @_; + my $self = bless { + 'field'=>{ + 'xmlns'=>'http://www.openarchives.org/OAI/2.0/', + 'xmlns:xsi'=>'http://www.w3.org/2001/XMLSchema-instance', + 'xsi:schemaLocation'=>'http://www.openarchives.org/OAI/2.0/ http://www.openarchives.org/OAI/2.0/OAI-PMH.xsd' + }, + %args, + }, ref($class) || $class; + return $self; +} + +sub set_error +{ + my ($self,$error,$code) = @_; + $code ||= 600; + + if( $self->get_handler ) { + $self->get_handler->errors($error); + $self->get_handler->code($code); + } else { + Carp::carp ref($self)." tried to set_error without having a handler to set it on!"; + } +} +sub generate_start { + my ($self) = @_; + return unless defined(my $handler = $self->get_handler); + + $handler->start_prefix_mapping({ + 'Prefix'=>'xsi', + 'NamespaceURI'=>'http://www.w3.org/2001/XMLSchema-instance' + }); + $handler->start_prefix_mapping({ + 'Prefix'=>'', + 'NamespaceURI'=>'http://www.openarchives.org/OAI/2.0/' + }); + g_start_element($handler, + 'http://www.openarchives.org/OAI/2.0/', + 'OAI-PMH', + { + '{http://www.w3.org/2001/XMLSchema-instance}schemaLocation'=>{ + 'LocalName' => 'schemaLocation', + 'Prefix' => 'xsi', + 'Value' => 'http://www.openarchives.org/OAI/2.0/ http://www.openarchives.org/OAI/2.0/OAI-PMH.xsd', + 'Name' => 'xsi:schemaLocation', + 'NamespaceURI' => 'http://www.w3.org/2001/XMLSchema-instance', + }, + '{}xmlns' => { + 'Prefix' => '', + 'LocalName' => 'xmlns', + 'Value' => 'http://www.openarchives.org/OAI/2.0/', + 'Name' => 'xmlns', + 'NamespaceURI' => '', + }, + '{http://www.w3.org/2000/xmlns/}xsi'=>{ + 'LocalName' => 'xsi', + 'Prefix' => 'xmlns', + 'Value' => 'http://www.w3.org/2001/XMLSchema-instance', + 'Name' => 'xmlns:xsi', + 'NamespaceURI' => 'http://www.w3.org/2000/xmlns/', + }, + }); + + g_data_element($handler, + 'http://www.openarchives.org/OAI/2.0/', + 'responseDate', + {}, + $self->header('responseDate') + ); + + my $uri = URI->new($self->header('requestURL')); + my $attr; + my %QUERY = $uri->query_form; + while(my ($key,$value) = each %QUERY) { + $attr->{"{}$key"} = { + 'Name'=>$key, + 'LocalName'=>$key, + 'Value'=>$value, + 'Prefix'=>'', + 'NamespaceURI'=>'', + }; + } + $uri->query( undef ); + g_data_element($handler, + 'http://www.openarchives.org/OAI/2.0/', + 'request', + $attr, + $uri->as_string + ); +} + +sub generate_end { + my ($self) = @_; + return unless defined(my $handler = $self->get_handler); + + g_end_element($handler, + 'http://www.openarchives.org/OAI/2.0/', + 'OAI-PMH' + ); + + $handler->end_prefix_mapping({ + 'Prefix'=>'xsi', + 'NamespaceURI'=>'http://www.w3.org/2001/XMLSchema-instance' + }); + $handler->end_prefix_mapping({ + 'Prefix'=>'', + 'NamespaceURI'=>'http://www.openarchives.org/OAI/2.0/' + }); +} + +sub header { + my $self = shift; + return @_ > 1 ? $self->{field}->{$_[0]} = $_[1] : $self->{field}->{$_[0]}; +} + +sub end_document { + my $self = shift; + $self->set_handler(undef); + unless( defined($self->header('version')) ) { + die "Not an OAI-PMH response: No recognised OAI-PMH namespace found before end of document\n"; + } +} + +sub start_element { + my ($self,$hash) = @_; + return $self->SUPER::start_element($hash) if $self->{State}; + my $elem = $hash->{LocalName}; + my $attr = $hash->{Attributes}; + + # Root element + unless( defined($self->header('version')) ) { + my $xmlns = $hash->{NamespaceURI}; + if( !defined($xmlns) || !length($xmlns) ) + { + die "Error parsing response: no namespace on root element"; + } + elsif( !exists $VERSIONS{lc($xmlns)} ) + { + die "Error parsing response: unrecognised OAI namespace '$xmlns'"; + } + else + { + $self->header('version',$VERSIONS{lc($xmlns)}) + } + } + # With a static repository, don't process any headers + if( $self->header('version') && $self->header('version') eq '2.0s' ) { + my %args = %{$self->{_args}}; + # ListRecords and the correct prefix + if( $elem eq 'ListRecords' && + $elem eq $args{'verb'} && + $attr->{'{}metadataPrefix'}->{'Value'} eq $args{'metadataPrefix'} ) { + $self->{State} = 1; + # Start of the verb we're looking for + } elsif( + $elem ne 'ListRecords' && + $elem eq $args{'verb'} + ) { + $self->{State} = 1; + } + } else { + $self->{State} = 1; + } +} + +sub end_element { + my ($self,$hash) = @_; + my $elem = $hash->{LocalName}; + my $attr = $hash->{Attributes}; + my $text = $hash->{Text}; + # Static repository, don't process any headers + if( $self->header('version') && $self->header('version') eq '2.0s' ) { + # Stop parsing when we get to the closing verb + if( $self->{State} && + $elem eq $self->{_args}->{'verb'} && + $hash->{NamespaceURI} eq 'http://www.openarchives.org/OAI/2.0/static-repository' + ) { + $self->{State} = 0; + die "done\n\n"; + } + return $self->{State} ? + $self->SUPER::end_element($hash) : + undef; + } + $self->SUPER::end_element($hash); + if( $elem eq 'responseDate' || $elem eq 'requestURL' ) { + $self->header($elem,$text); + } elsif( $elem eq 'request' ) { + $self->header("request",$text); + my $uri = new URI($text); + $uri->query_form(map { ($_->{LocalName},$_->{Value}) } values %$attr); + $self->header("requestURL",$uri); + } else { + die "Still in headers, but came across an unrecognised element: $elem"; + } + if( $elem eq 'requestURL' || $elem eq 'request' ) { + die "Oops! Root handler isn't \$self - $self != $hash->{State}" + unless ref($self) eq ref($hash->{State}->get_handler); + $hash->{State}->set_handler($self->get_handler); + } + return 1; +} + +1; + +__END__ + +=head1 NAME + +HTTP::OAI::Headers - Encapsulation of 'header' values + +=head1 METHODS + +=over 4 + +=item $value = $hdrs->header($name,[$value]) + +Return and optionally set the header field $name to $value. + +=back diff --git a/HTTP/OAI/Identify.pm b/HTTP/OAI/Identify.pm new file mode 100644 index 0000000000..bf3cc3c7ce --- /dev/null +++ b/HTTP/OAI/Identify.pm @@ -0,0 +1,194 @@ +package HTTP::OAI::Identify; + +use strict; +use warnings; + +use HTTP::OAI::SAXHandler qw( :SAX ); + +use vars qw( @ISA ); +@ISA = qw( HTTP::OAI::Response ); + +sub new { + my ($class,%args) = @_; + delete $args{'harvestAgent'}; # Otherwise we get a memory cycle with $h->repository($id)! + for(qw( adminEmail compression description )) { + $args{$_} ||= []; + } + $args{handlers}->{description} ||= "HTTP::OAI::Metadata"; + my $self = $class->SUPER::new(%args); + + $self->verb('Identify') unless $self->verb; + $self->baseURL($args{baseURL}) unless $self->baseURL; + $self->adminEmail($args{adminEmail}) if !ref($args{adminEmail}) && !$self->adminEmail; + $self->protocolVersion($args{protocolVersion} || '2.0') unless $self->protocolVersion; + $self->repositoryName($args{repositoryName}) unless $self->repositoryName; + $self->earliestDatestamp($args{earliestDatestamp}) unless $self->earliestDatestamp; + $self->deletedRecord($args{deletedRecord}) unless $self->deletedRecord; + $self->granularity($args{granularity}) unless $self->granularity; + + $self; +} + +sub adminEmail { + my $self = shift; + push @{$self->{adminEmail}}, @_; + return wantarray ? + @{$self->{adminEmail}} : + $self->{adminEmail}->[0] +} +sub baseURL { shift->headers->header('baseURL',@_) } +sub compression { + my $self = shift; + push @{$self->{compression}}, @_; + return wantarray ? + @{$self->{compression}} : + $self->{compression}->[0]; +} +sub deletedRecord { return shift->headers->header('deletedRecord',@_) } +sub description { + my $self = shift; + push(@{$self->{description}}, @_); + return wantarray ? + @{$self->{description}} : + $self->{description}->[0]; +}; +sub earliestDatestamp { return shift->headers->header('earliestDatestamp',@_) } +sub granularity { return shift->headers->header('granularity',@_) } +sub protocolVersion { return shift->headers->header('protocolVersion',@_) }; +sub repositoryName { return shift->headers->header('repositoryName',@_) }; + +sub next { + my $self = shift; + return shift @{$self->{description}}; +} + +sub generate_body { + my ($self) = @_; + return unless defined(my $handler = $self->get_handler); + + g_data_element($handler,'http://www.openarchives.org/OAI/2.0/','repositoryName',{},$self->repositoryName); + g_data_element($handler,'http://www.openarchives.org/OAI/2.0/','baseURL',{},"".$self->baseURL); + g_data_element($handler,'http://www.openarchives.org/OAI/2.0/','protocolVersion',{},$self->protocolVersion); + g_data_element($handler,'http://www.openarchives.org/OAI/2.0/','adminEmail',{},$_) for $self->adminEmail; + g_data_element($handler,'http://www.openarchives.org/OAI/2.0/','earliestDatestamp',{},$self->earliestDatestamp||'0001-01-01'); + g_data_element($handler,'http://www.openarchives.org/OAI/2.0/','deletedRecord',{},$self->deletedRecord||'no'); + g_data_element($handler,'http://www.openarchives.org/OAI/2.0/','granularity',{},$self->granularity) if defined($self->granularity); + g_data_element($handler,'http://www.openarchives.org/OAI/2.0/','compression',{},$_) for $self->compression; + + for($self->description) { + g_data_element($handler,'http://www.openarchives.org/OAI/2.0/','description',{},$_); + } +} + +sub start_element { + my ($self,$hash) = @_; + my $elem = lc($hash->{LocalName}); + $self->SUPER::start_element($hash); + if( $elem eq 'description' && !$self->{"in_$elem"} ) { + $self->{OLDHandler} = $self->get_handler(); + $self->set_handler(my $handler = $self->{handlers}->{$elem}->new()); + $self->description($handler); + $self->{"in_$elem"} = $hash->{Depth}; + g_start_document($handler); + } +} + +sub end_element { + my ($self,$hash) = @_; + my $elem = $hash->{LocalName}; + my $text = $hash->{Text}; + if( defined $text ) + { + $text =~ s/^\s+//; + $text =~ s/\s+$//; + } + if( defined($self->get_handler) ) { + if( $elem eq 'description' && $self->{"in_$elem"} == $hash->{Depth} ) { + $self->SUPER::end_document(); + $self->set_handler($self->{OLDHandler}); + $self->{"in_$elem"} = undef; + } + } elsif( $elem eq 'adminEmail' ) { + $self->adminEmail($text); + } elsif( $elem eq 'compression' ) { + $self->compression($text); + } elsif( $elem eq 'baseURL' ) { + $self->baseURL($text); + } elsif( $elem eq 'protocolVersion' ) { + $text = '2.0' if $text =~ /\D/ or $text < 2.0; + $self->protocolVersion($text); + } elsif( defined($text) && length($text) ) { + $self->headers->header($elem,$text); + } + $self->SUPER::end_element($hash); +} + +1; + +__END__ + +=head1 NAME + +HTTP::OAI::Identify - Provide access to an OAI Identify response + +=head1 SYNOPSIS + + use HTTP::OAI::Identify; + + my $i = new HTTP::OAI::Identify( + adminEmail=>'billg@microsoft.com', + baseURL=>'http://www.myarchives.org/oai', + repositoryName=>'www.myarchives.org' + ); + + for( $i->adminEmail ) { + print $_, "\n"; + } + +=head1 METHODS + +=over 4 + +=item $i = new HTTP::OAI::Identify(-baseURL=>'http://arXiv.org/oai1'[, adminEmail=>$email, protocolVersion=>'2.0', repositoryName=>'myarchive']) + +This constructor method returns a new instance of the OAI::Identify module. + +=item $i->version + +Return the original version of the OAI response, according to the given XML namespace. + +=item $i->headers + +Returns an HTTP::OAI::Headers object. Use $headers->header('headername') to retrive field values. + +=item $burl = $i->baseURL([$burl]) + +=item $eds = $i->earliestDatestamp([$eds]) + +=item $gran = $i->granularity([$gran]) + +=item $version = $i->protocolVersion($version) + +=item $name = $i->repositoryName($name) + +Returns and optionally sets the relevent header. NOTE: protocolVersion will always be '2.0'. Use $i->version to find out the protocol version used by the repository. + +=item @addys = $i->adminEmail([$email]) + +=item @cmps = $i->compression([$cmp]) + +Returns and optionally adds to the multi-value headers. + +=item @dl = $i->description([$d]) + +Returns the description list and optionally appends a new description $d. Returns an array ref of Ls, or an empty ref if there are no description. + +=item $d = $i->next + +Returns the next description or undef if no more description left. + +=item $dom = $i->toDOM + +Returns a XML::DOM object representing the Identify response. + +=back diff --git a/HTTP/OAI/ListIdentifiers.pm b/HTTP/OAI/ListIdentifiers.pm new file mode 100644 index 0000000000..d4d9322ba0 --- /dev/null +++ b/HTTP/OAI/ListIdentifiers.pm @@ -0,0 +1,118 @@ +package HTTP::OAI::ListIdentifiers; + +use strict; +use warnings; + +use vars qw( @ISA ); +@ISA = qw( HTTP::OAI::PartialList ); + +sub new { + my $class = shift; + my %args = @_; + + my $self = $class->SUPER::new(@_); + + $self->{in_record} = 0; + + $self; +} + +sub identifier { shift->item(@_) } + +sub generate_body { + my ($self) = @_; + return unless defined(my $handler = $self->get_handler); + + for($self->identifier) { + $_->set_handler($handler); + $_->generate; + } + if( defined($self->resumptionToken) ) { + $self->resumptionToken->set_handler($handler); + $self->resumptionToken->generate; + } +} + +sub start_element { + my ($self,$hash) = @_; + my $elem = lc($hash->{LocalName}); + if( $elem eq 'header' ) { + $self->set_handler(new HTTP::OAI::Header( + version=>$self->version + )); + } elsif( $elem eq 'resumptiontoken' ) { + $self->set_handler(new HTTP::OAI::ResumptionToken( + version=>$self->version + )); + } + $self->SUPER::start_element($hash); +} + +sub end_element { + my ($self,$hash) = @_; + my $elem = lc($hash->{LocalName}); + $self->SUPER::end_element($hash); + if( $elem eq 'header' ) { + $self->identifier( $self->get_handler ); + $self->set_handler( undef ); + } elsif( $elem eq 'resumptiontoken' ) { + $self->resumptionToken( $self->get_handler ); + $self->set_handler( undef ); + } + # OAI 1.x + if( $self->version eq '1.1' && $elem eq 'identifier' ) { + $self->identifier(new HTTP::OAI::Header( + version=>$self->version, + identifier=>$hash->{Text}, + datestamp=>'0000-00-00', + )); + } +} + +1; + +__END__ + +=head1 NAME + +HTTP::OAI::ListIdentifiers - Provide access to an OAI ListIdentifiers response + +=head1 SYNOPSIS + + my $r = $h->ListIdentifiers; + + while(my $rec = $r->next) { + print "identifier => ", $rec->identifier, "\n", + print "datestamp => ", $rec->datestamp, "\n" if $rec->datestamp; + print "status => ", ($rec->status || 'undef'), "\n"; + } + + die $r->message if $r->is_error; + +=head1 METHODS + +=over 4 + +=item $li = new OAI::ListIdentifiers + +This constructor method returns a new OAI::ListIdentifiers object. + +=item $rec = $li->next + +Returns either an L object, or undef, if there are no more records. Use $rec->is_error to test whether there was an error getting the next record (otherwise things will break). + +If -resume was set to false in the Harvest Agent, next may return a string (the resumptionToken). + +=item @il = $li->identifier([$idobj]) + +Returns the identifier list and optionally adds an identifier or resumptionToken, $idobj. Returns an array ref of Ls. + +=item $dom = $li->toDOM + +Returns a XML::DOM object representing the ListIdentifiers response. + +=item $token = $li->resumptionToken([$token]) + +Returns and optionally sets the L. + +=back diff --git a/HTTP/OAI/ListMetadataFormats.pm b/HTTP/OAI/ListMetadataFormats.pm new file mode 100644 index 0000000000..7e5ad3a1ac --- /dev/null +++ b/HTTP/OAI/ListMetadataFormats.pm @@ -0,0 +1,103 @@ +package HTTP::OAI::ListMetadataFormats; + +use strict; +use warnings; + +use vars qw( @ISA ); + +@ISA = qw( HTTP::OAI::Response ); + +sub new { + my $class = shift; + my $self = $class->SUPER::new(@_); + $self->{'metadataFormat'} ||= []; + $self->{in_mdf} = 0; + $self->verb('ListMetadataFormats') unless $self->verb; + + $self; +} + +sub metadataFormat { + my $self = shift; + push(@{$self->{metadataformat}}, @_); + return wantarray ? + @{$self->{metadataformat}} : + $self->{metadataformat}->[0]; +} + +sub next { shift @{shift->{metadataformat}} } + +sub generate_body { + my ($self) = @_; + return unless defined(my $handler = $self->get_handler); + + for( $self->metadataFormat ) { + $_->set_handler($handler); + $_->generate; + } +} + +sub start_element { + my ($self,$hash) = @_; + if( !$self->{'in_mdf'} ) { + if( lc($hash->{LocalName}) eq 'metadataformat' ) { + $self->set_handler(new HTTP::OAI::MetadataFormat()); + $self->{'in_mdf'} = $hash->{Depth}; + } + } + $self->SUPER::start_element($hash); +} + +sub end_element { + my ($self,$hash) = @_; + $self->SUPER::end_element($hash); + if( $self->{'in_mdf'} == $hash->{Depth} ) { + if( lc($hash->{LocalName}) eq 'metadataformat' ) { +HTTP::OAI::Debug::trace( "metadataFormat: " . $self->get_handler->metadataPrefix ); + $self->metadataFormat( $self->get_handler ); + $self->set_handler( undef ); + $self->{'in_mdf'} = 0; + } + } +} + +1; + +__END__ + +=head1 NAME + +HTTP::OAI::ListMetadataFormats - Provide access to an OAI ListMetadataFormats response + +=head1 SYNOPSIS + + my $r = $h->ListMetadataFormats; + + # ListMetadataFormats doesn't use flow control + while( my $rec = $r->next ) { + print $rec->metadataPrefix, "\n"; + } + + die $r->message if $r->is_error; + +=head1 METHODS + +=over 4 + +=item $lmdf = new HTTP::OAI::ListMetadataFormats + +This constructor method returns a new HTTP::OAI::ListMetadataFormats object. + +=item $mdf = $lmdf->next + +Returns either an L object, or undef, if no more records are available. + +=item @mdfl = $lmdf->metadataFormat([$mdf]) + +Returns the metadataFormat list and optionally adds a new metadataFormat, $mdf. Returns an array ref of Ls. + +=item $dom = $lmdf->toDOM + +Returns a XML::DOM object representing the ListMetadataFormats response. + +=back diff --git a/HTTP/OAI/ListRecords.pm b/HTTP/OAI/ListRecords.pm new file mode 100644 index 0000000000..256b82fe0c --- /dev/null +++ b/HTTP/OAI/ListRecords.pm @@ -0,0 +1,133 @@ +package HTTP::OAI::ListRecords; + +use strict; +use warnings; + +use vars qw( @ISA ); +@ISA = qw( HTTP::OAI::PartialList ); + +sub new { + my ($class,%args) = @_; + + $args{handlers} ||= {}; + $args{handlers}->{header} ||= "HTTP::OAI::Header"; + $args{handlers}->{metadata} ||= "HTTP::OAI::Metadata"; + $args{handlers}->{about} ||= "HTTP::OAI::Metadata"; + + my $self = $class->SUPER::new(%args); + + $self->{in_record} = 0; + + $self; +} + +sub record { shift->item(@_) } + +sub generate_body { + my ($self) = @_; + return unless defined(my $handler = $self->get_handler); + + for( $self->record ) { + $_->set_handler($self->get_handler); + $_->generate; + } + if( defined($self->resumptionToken) ) { + $self->resumptionToken->set_handler($handler); + $self->resumptionToken->generate; + } +} + +sub start_element { + my ($self,$hash) = @_; + if( !$self->{'in_record'} ) { + my $elem = lc($hash->{LocalName}); + if( $elem eq 'record' ) { + $self->set_handler(new HTTP::OAI::Record( + version=>$self->version, + handlers=>$self->{handlers}, + )); + $self->{'in_record'} = $hash->{Depth}; + } elsif( $elem eq 'resumptiontoken' ) { + $self->set_handler(new HTTP::OAI::ResumptionToken( + version=>$self->version + )); + $self->{'in_record'} = $hash->{Depth}; + } + } + $self->SUPER::start_element($hash); +} + +sub end_element { + my ($self,$hash) = @_; + $self->SUPER::end_element($hash); + if( $self->{'in_record'} == $hash->{Depth} ) { + my $elem = lc($hash->{LocalName}); + if( $elem eq 'record' ) { +HTTP::OAI::Debug::trace( "record: " . $self->get_handler->identifier ); + $self->record( $self->get_handler ); + $self->set_handler( undef ); + $self->{'in_record'} = 0; + } elsif( $elem eq 'resumptiontoken' ) { + $self->resumptionToken( $self->get_handler ); + $self->set_handler( undef ); + $self->{'in_record'} = 0; + } + } +} + +1; + +__END__ + +=head1 NAME + +HTTP::OAI::ListRecords - Provide access to an OAI ListRecords response + +=head1 SYNOPSIS + + my $r = $h->ListRecords( + metadataPrefix=>'oai_dc', + ); + + while( my $rec = $r->next ) { + print "Identifier => ", $rec->identifier, "\n"; + } + + die $r->message if $r->is_error; + + # Using callback method + sub callback { + my $rec = shift; + print "Identifier => ", $rec->identifier, "\n"; + }; + my $r = $h->ListRecords( + metadataPrefix=>'oai_dc', + onRecord=>\&callback + ); + die $r->message if $r->is_error; + +=head1 METHODS + +=over 4 + +=item $lr = new HTTP::OAI::ListRecords + +This constructor method returns a new HTTP::OAI::ListRecords object. + +=item $rec = $lr->next + +Returns either an L object, or undef, if no more record are available. Use $rec->is_error to test whether there was an error getting the next record. + +=item @recl = $lr->record([$rec]) + +Returns the record list and optionally adds a new record or resumptionToken, $rec. Returns an array ref of Ls, including an optional resumptionToken string. + +=item $token = $lr->resumptionToken([$token]) + +Returns and optionally sets the L. + +=item $dom = $lr->toDOM + +Returns a XML::DOM object representing the ListRecords response. + +=back diff --git a/HTTP/OAI/ListSets.pm b/HTTP/OAI/ListSets.pm new file mode 100644 index 0000000000..88312734f3 --- /dev/null +++ b/HTTP/OAI/ListSets.pm @@ -0,0 +1,120 @@ +package HTTP::OAI::ListSets; + +use strict; +use warnings; + +use vars qw( @ISA ); +@ISA = qw( HTTP::OAI::PartialList ); + +sub new { + my ($class,%args) = @_; + + $args{handlers} ||= {}; + $args{handlers}->{description} ||= 'HTTP::OAI::Metadata'; + + my $self = $class->SUPER::new(%args); + + $self->{in_set} = 0; + + $self; +} + +sub set { shift->item(@_) } + +sub generate_body { + my ($self) = @_; + return unless defined(my $handler = $self->get_handler); + + for( $self->set ) { + $_->set_handler($handler); + $_->generate; + } + if( defined($self->resumptionToken) ) { + $self->resumptionToken->set_handler($handler); + $self->resumptionToken->generate; + } +} + +sub start_element { + my ($self,$hash) = @_; + my $elem = lc($hash->{Name}); + if( !$self->{in_set} ) { + if( $elem eq 'set' ) { + $self->set_handler(new HTTP::OAI::Set( + version=>$self->version, + handlers=>$self->{handlers} + )); + $self->{'in_set'} = $hash->{Depth}; + } elsif( $elem eq 'resumptiontoken' ) { + $self->set_handler(new HTTP::OAI::ResumptionToken( + version=>$self->version + )); + $self->{'in_set'} = $hash->{Depth}; + } + } + $self->SUPER::start_element($hash); +} + +sub end_element { + my ($self,$hash) = @_; + my $elem = lc($hash->{LocalName}); + $self->SUPER::end_element($hash); + if( $self->{'in_set'} == $hash->{Depth} ) + { + if( $elem eq 'set' ) { + $self->set( $self->get_handler ); + $self->set_handler( undef ); + $self->{in_set} = 0; + } elsif( $elem eq 'resumptionToken' ) { + $self->resumptionToken( $self->get_handler ); + $self->set_handler( undef ); + $self->{in_set} = 0; + } + } +} + +1; + +__END__ + +=head1 NAME + +HTTP::OAI::ListSets - Provide access to an OAI ListSets response + +=head1 SYNOPSIS + + my $r = $h->ListSets(); + + while( my $rec = $r->next ) { + print $rec->setSpec, "\n"; + } + + die $r->message if $r->is_error; + +=head1 METHODS + +=over 4 + +=item $ls = new HTTP::OAI::ListSets + +This constructor method returns a new OAI::ListSets object. + +=item $set = $ls->next + +Returns either an L object, or undef, if no more records are available. Use $set->is_error to test whether there was an error getting the next record. + +If -resume was set to false in the Harvest Agent, next may return a string (the resumptionToken). + +=item @setl = $ls->set([$set]) + +Returns the set list and optionally adds a new set or resumptionToken, $set. Returns an array ref of Ls, with an optional resumptionToken string. + +=item $token = $ls->resumptionToken([$token]) + +Returns and optionally sets the L. + +=item $dom = $ls->toDOM + +Returns a XML::DOM object representing the ListSets response. + +=back diff --git a/HTTP/OAI/Metadata.pm b/HTTP/OAI/Metadata.pm new file mode 100644 index 0000000000..5fee25bbd4 --- /dev/null +++ b/HTTP/OAI/Metadata.pm @@ -0,0 +1,35 @@ +package HTTP::OAI::Metadata; + +use vars qw(@ISA); +@ISA = qw(HTTP::OAI::Encapsulation::DOM); + +1; + +__END__ + +=head1 NAME + +HTTP::OAI::Metadata - Base class for data objects that contain DOM trees + +=head1 SYNOPSIS + + use HTTP::OAI::Metadata; + + $xml = XML::LibXML::Document->new(); + $xml = XML::LibXML->new->parse( ... ); + + $md = new HTTP::OAI::Metadata(dom=>$xml); + + print $md->dom->toString; + + my $dom = $md->dom(); # Return internal DOM tree + +=head1 METHODS + +=over 4 + +=item $md->dom( [$dom] ) + +Return and optionally set the XML DOM object that contains the actual metadata. If you intend to use the generate() method $dom must be a XML_DOCUMENT_NODE. + +=back diff --git a/HTTP/OAI/Metadata/METS.pm b/HTTP/OAI/Metadata/METS.pm new file mode 100644 index 0000000000..e2a0f61e0a --- /dev/null +++ b/HTTP/OAI/Metadata/METS.pm @@ -0,0 +1,66 @@ +package HTTP::OAI::Metadata::METS; + +use strict; +use warnings; + +use HTTP::OAI::Metadata; +use vars qw(@ISA); +@ISA = qw(HTTP::OAI::Metadata); + +use XML::LibXML; +use XML::LibXML::XPathContext; + +sub new { + my $class = shift; + my $self = $class->SUPER::new(@_); + my %args = @_; + $self; +} + +sub _xc +{ + my $xc = XML::LibXML::XPathContext->new( @_ ); + $xc->registerNs( 'mets', 'http://www.loc.gov/METS/' ); + $xc->registerNs( 'xlink', 'http://www.w3.org/1999/xlink' ); + return $xc; +} + +sub files +{ + my $self = shift; + my $dom = $self->dom; + + my $xc = _xc($dom); + + my @files; + foreach my $file ($xc->findnodes( '//mets:file' )) + { + my $f = {}; + foreach my $attr ($file->attributes) + { + $f->{ $attr->nodeName } = $attr->nodeValue; + } + $file = _xc($file); + foreach my $locat ($file->findnodes( 'mets:FLocat' )) + { + $f->{ url } = $locat->getAttribute( 'xlink:href' ); + } + push @files, $f; + } + + return @files; +} + +1; + +__END__ + +=head1 NAME + +HTTP::OAI::Metadata::METS - METS accessor utility + +=head1 DESCRIPTION + +=head1 SYNOPSIS + +=head1 NOTE diff --git a/HTTP/OAI/Metadata/OAI_DC.pm b/HTTP/OAI/Metadata/OAI_DC.pm new file mode 100644 index 0000000000..f38ad7c34b --- /dev/null +++ b/HTTP/OAI/Metadata/OAI_DC.pm @@ -0,0 +1,161 @@ +package HTTP::OAI::Metadata::OAI_DC; + +use XML::LibXML; +use HTTP::OAI::Metadata; +@ISA = qw(HTTP::OAI::Metadata); + +use strict; + +our $OAI_DC_SCHEMA = 'http://www.openarchives.org/OAI/2.0/oai_dc/'; +our $DC_SCHEMA = 'http://purl.org/dc/elements/1.1/'; +our @DC_TERMS = qw( contributor coverage creator date description format identifier language publisher relation rights source subject title type ); + +sub new { + my( $class, %self ) = @_; + + my $self = $class->SUPER::new( %self ); + + if( exists $self{dc} && ref($self{dc}) eq 'HASH' ) + { + my ($dom,$dc) =_oai_dc_dom(); + foreach my $term (@DC_TERMS) + { + foreach my $value (@{$self{dc}->{$term}||[]}) + { + $dc->appendChild($dom->createElementNS($DC_SCHEMA, $term))->appendText( $value ); + } + } + $self->dom($dom); + } + + $self; +} + +sub dc +{ + my( $self ) = @_; + + my $dom = $self->dom; + my $metadata = $dom->documentElement; + + return $self->{dc} if defined $self->{dc}; + + my %dc = map { $_ => [] } @DC_TERMS; + + $self->_dc( $metadata, \%dc ); + + return \%dc; +} + +sub _dc +{ + my( $self, $node, $dc ) = @_; + + my $ns = $node->getNamespaceURI; + $ns =~ s/\/?$/\//; + + if( $ns eq $DC_SCHEMA ) + { + push @{$dc->{lc($node->localName)}}, $node->textContent; + } + elsif( $node->hasChildNodes ) + { + for($node->childNodes) + { + next if $_->nodeType != XML_ELEMENT_NODE; + $self->_dc( $_, $dc ); + } + } +} + +sub _oai_dc_dom { + my $dom = XML::LibXML->createDocument(); + $dom->setDocumentElement(my $dc = $dom->createElement('oai_dc:dc')); + $dc->setAttribute('xmlns:oai_dc','http://www.openarchives.org/OAI/2.0/oai_dc/'); + $dc->setAttribute('xmlns:dc','http://purl.org/dc/elements/1.1/'); + $dc->setAttribute('xmlns:xsi','http://www.w3.org/2001/XMLSchema-instance'); + $dc->setAttribute('xsi:schemaLocation','http://www.openarchives.org/OAI/2.0/oai_dc/ http://www.openarchives.org/OAI/2.0/oai_dc.xsd'); + return ($dom,$dc); +} + +sub metadata { + my( $self, $md ) = @_; + + return $self->dom if @_ == 1; + + delete $self->{dc}; + $self->dom( $md ); + + return if !defined $md; + + my $dc = $self->dc; + + my ($dom,$metadata) = _oai_dc_dom(); + + foreach my $term (@DC_TERMS) + { + foreach my $value (@{$dc->{$term}}) + { + $metadata->appendChild( $dom->createElementNS( $DC_SCHEMA, $term ) )->appendText( $value ); + } + } + + $self->dom($dom) +} + +sub toString { + my $self = shift; + my $str = "Open Archives Initiative Dublin Core (".ref($self).")\n"; + foreach my $term ( @DC_TERMS ) { + for(@{$self->{dc}->{$term}}) { + $str .= sprintf("%s:\t%s\n", $term, $_||''); + } + } + $str; +} + +sub end_element { + my ($self,$hash) = @_; + my $elem = lc($hash->{LocalName}); + if( exists($self->{dc}->{$elem}) ) { + push @{$self->{dc}->{$elem}}, $hash->{Text}; + } + $self->SUPER::end_element($hash); +} + +sub end_document { + my $self = shift; + $self->SUPER::end_document(); + $self->metadata($self->dom); +} + +1; + +__END__ + +=head1 NAME + +HTTP::OAI::Metadata::OAI_DC - Easy access to OAI Dublin Core + +=head1 DESCRIPTION + +HTTP::OAI::Metadata::OAI_DC provides a simple interface to parsing and generating OAI Dublin Core ("oai_dc"). + +=head1 SYNOPSIS + + use HTTP::OAI::Metadata::OAI_DC; + + my $md = new HTTP::OAI::Metadata( + dc=>{title=>['Hello, World!','Hi, World!']}, + ); + + # Prints "Hello, World!" + print $md->dc->{title}->[0], "\n"; + + my $xml = $md->metadata(); + + $md->metadata($xml); + +=head1 NOTE + +HTTP::OAI::Metadata::OAI_DC will automatically (and silently) convert OAI version 1.x oai_dc records into OAI version 2.0 oai_dc records. diff --git a/HTTP/OAI/Metadata/OAI_Eprints.pm b/HTTP/OAI/Metadata/OAI_Eprints.pm new file mode 100644 index 0000000000..611cbc644a --- /dev/null +++ b/HTTP/OAI/Metadata/OAI_Eprints.pm @@ -0,0 +1,42 @@ +package HTTP::OAI::Metadata::OAI_Eprints; + +use strict; +use warnings; + +use Carp; +use XML::LibXML; +use HTTP::OAI::Metadata; + +use vars qw( @ISA ); +@ISA = qw( HTTP::OAI::Metadata ); + +sub new { + my $self = shift->SUPER::new(@_); + my %args = @_; + my $dom = XML::LibXML->createDocument(); + $dom->setDocumentElement(my $root = $dom->createElementNS('http://www.openarchives.org/OAI/1.1/eprints','eprints')); +# $root->setAttribute('xmlns','http://www.openarchives.org/OAI/2.0/oai-identifier'); + $root->setAttribute('xmlns:xsi','http://www.w3.org/2001/XMLSchema-instance'); + $root->setAttribute('xsi:schemaLocation','http://www.openarchives.org/OAI/1.1/eprints http://www.openarchives.org/OAI/1.1/eprints.xsd'); + for(qw( content metadataPolicy dataPolicy submissionPolicy )) { + Carp::croak "Required argument $_ undefined" if !defined($args{$_}) && $_ =~ /metadataPolicy|dataPolicy/; + next unless defined($args{$_}); + my $node = $root->appendChild($dom->createElement($_)); + $args{$_}->{'URL'} ||= []; + $args{$_}->{'text'} ||= []; + foreach my $value (@{$args{$_}->{'URL'}}) { + $node->appendChild($dom->createElement('URL'))->appendChild($dom->createTextNode($value)); + } + foreach my $value (@{$args{$_}->{'text'}}) { + $node->appendChild($dom->createElement('text'))->appendChild($dom->createTextNode($value)); + } + } + $args{'comment'} ||= []; + for(@{$args{'comment'}}) { + $root->appendChild($dom->createElement('comment'))->appendChild($dom->createTextNode($_)); + } + $self->dom($dom); + $self; +} + +1; diff --git a/HTTP/OAI/Metadata/OAI_Identifier.pm b/HTTP/OAI/Metadata/OAI_Identifier.pm new file mode 100644 index 0000000000..6266f9dfe1 --- /dev/null +++ b/HTTP/OAI/Metadata/OAI_Identifier.pm @@ -0,0 +1,29 @@ +package HTTP::OAI::Metadata::OAI_Identifier; + +use strict; +use warnings; + +use Carp; +use XML::LibXML; +use HTTP::OAI::Metadata; + +use vars qw( @ISA ); +@ISA = qw( HTTP::OAI::Metadata ); + +sub new { + my $self = shift->SUPER::new(@_); + my %args = @_; + my $dom = XML::LibXML->createDocument(); + $dom->setDocumentElement(my $root = $dom->createElementNS('http://www.openarchives.org/OAI/2.0/oai-identifier','oai-identifier')); +# $root->setAttribute('xmlns','http://www.openarchives.org/OAI/2.0/oai-identifier'); + $root->setAttribute('xmlns:xsi','http://www.w3.org/2001/XMLSchema-instance'); + $root->setAttribute('xsi:schemaLocation','http://www.openarchives.org/OAI/2.0/oai-identifier http://www.openarchives.org/OAI/2.0/oai-identifier.xsd'); + for(qw( scheme repositoryIdentifier delimiter sampleIdentifier )) { + Carp::croak "Required argument $_ is undefined" unless defined($args{$_}); + $root->appendChild($dom->createElement($_))->appendChild($dom->createTextNode($args{$_})); + } + $self->dom($dom); + $self; +} + +1; diff --git a/HTTP/OAI/MetadataFormat.pm b/HTTP/OAI/MetadataFormat.pm new file mode 100644 index 0000000000..c00c842754 --- /dev/null +++ b/HTTP/OAI/MetadataFormat.pm @@ -0,0 +1,94 @@ +package HTTP::OAI::MetadataFormat; + +use strict; +use warnings; + +use HTTP::OAI::SAXHandler qw/ :SAX /; + +use vars qw( @ISA ); +@ISA = qw( HTTP::OAI::Encapsulation ); + +sub new { + my ($class,%args) = @_; + + my $self = $class->SUPER::new(%args); + + $self->metadataPrefix($args{metadataPrefix}) if $args{metadataPrefix}; + $self->schema($args{schema}) if $args{schema}; + $self->metadataNamespace($args{metadataNamespace}) if $args{metadataNamespace}; + + $self; +} + +sub metadataPrefix { + my $self = shift; + return @_ ? $self->{metadataPrefix} = shift : $self->{metadataPrefix} +} +sub schema { + my $self = shift; + return @_ ? $self->{schema} = shift : $self->{schema} } +sub metadataNamespace { + my $self = shift; + return @_ ? $self->{metadataNamespace} = shift : $self->{metadataNamespace} +} + +sub generate { + my ($self) = @_; + return unless defined(my $handler = $self->get_handler); + + g_start_element($handler,'http://www.openarchives.org/OAI/2.0/','metadataFormat',{}); + + g_data_element($handler,'http://www.openarchives.org/OAI/2.0/','metadataPrefix',{},$self->metadataPrefix); + g_data_element($handler,'http://www.openarchives.org/OAI/2.0/','schema',{},$self->schema); + if( defined($self->metadataNamespace) ) { + g_data_element($handler,'http://www.openarchives.org/OAI/2.0/','metadataNamespace',{},$self->metadataNamespace); + } + + g_end_element($handler,'http://www.openarchives.org/OAI/2.0/','metadataFormat'); +} + +sub end_element { + my ($self,$hash) = @_; + $self->SUPER::end_element($hash); + my $elem = lc($hash->{LocalName}); + if( defined $hash->{Text} ) + { + $hash->{Text} =~ s/^\s+//; + $hash->{Text} =~ s/\s+$//; + } + if( $elem eq 'metadataprefix' ) { + $self->metadataPrefix($hash->{Text}); + } elsif( $elem eq 'schema' ) { + $self->schema($hash->{Text}); + } elsif( $elem eq 'metadatanamespace' ) { + $self->metadataNamespace($hash->{Text}); + } +} + +1; + +__END__ + +=head1 NAME + +HTTP::OAI::MetadataFormat - Encapsulates OAI metadataFormat XML data + +=head1 METHODS + +=over 4 + +=item $mdf = new HTTP::OAI::MetadataFormat + +This constructor method returns a new HTTP::OAI::MetadataFormat object. + +=item $mdp = $mdf->metadataPrefix([$mdp]) + +=item $schema = $mdf->schema([$schema]) + +=item $ns = $mdf->metadataNamespace([$ns]) + +These methods respectively return and optionally set the metadataPrefix, schema and, metadataNamespace, for the metadataFormat record. + +metadataNamespace is optional in OAI 1.x and therefore may be undef when harvesting pre OAI 2 repositories. + +=back diff --git a/HTTP/OAI/PartialList.pm b/HTTP/OAI/PartialList.pm new file mode 100644 index 0000000000..875c79cd52 --- /dev/null +++ b/HTTP/OAI/PartialList.pm @@ -0,0 +1,43 @@ +package HTTP::OAI::PartialList; + +use strict; +use warnings; + +use vars qw( @ISA ); +@ISA = qw( HTTP::OAI::Response ); + +sub new { + my( $class, %args ) = @_; + my $self = $class->SUPER::new(%args); + $self->{onRecord} = delete $args{onRecord}; + $self->{item} ||= []; + return $self; +} + +sub resumptionToken { shift->headers->header('resumptionToken',@_) } + +sub item { + my $self = shift; + if( defined($self->{onRecord}) ) { + $self->{onRecord}->($_, $self) for @_; + } else { + push(@{$self->{item}}, @_); + } + return wantarray ? + @{$self->{item}} : + $self->{item}->[0]; +} + +sub next { + my $self = shift; + return shift @{$self->{item}} if @{$self->{item}}; + return undef unless $self->{'resume'} and $self->resumptionToken; + + do { + $self->resume(resumptionToken=>$self->resumptionToken); + } while( $self->{onRecord} and $self->is_success and $self->resumptionToken ); + + return $self->is_success ? $self->next : undef; +} + +1; diff --git a/HTTP/OAI/Record.pm b/HTTP/OAI/Record.pm new file mode 100644 index 0000000000..31f633f9b7 --- /dev/null +++ b/HTTP/OAI/Record.pm @@ -0,0 +1,157 @@ +package HTTP::OAI::Record; + +use strict; +use warnings; + +use vars qw(@ISA); + +use HTTP::OAI::SAXHandler qw/ :SAX /; + +@ISA = qw(HTTP::OAI::Encapsulation); + +sub new { + my ($class,%args) = @_; + my $self = $class->SUPER::new(%args); + + $self->{handlers} = $args{handlers}; + + $self->header($args{header}) unless defined($self->header); + $self->metadata($args{metadata}) unless defined($self->metadata); + $self->{about} = $args{about} || [] unless defined($self->{about}); + + $self->{in_record} = 0; + + $self->header(new HTTP::OAI::Header(%args)) unless defined $self->header; + + $self; +} + +sub header { shift->_elem('header',@_) } +sub metadata { shift->_elem('metadata',@_) } +sub about { + my $self = shift; + push @{$self->{about}}, @_ if @_; + return @{$self->{about}}; +} + +sub identifier { shift->header->identifier(@_) } +sub datestamp { shift->header->datestamp(@_) } +sub status { shift->header->status(@_) } +sub is_deleted { shift->header->is_deleted(@_) } + +sub generate { + my ($self) = @_; + return unless defined(my $handler = $self->get_handler); + + g_start_element($handler,'http://www.openarchives.org/OAI/2.0/','record',{}); + $self->header->set_handler($handler); + $self->header->generate; + g_data_element($handler,'http://www.openarchives.org/OAI/2.0/','metadata',{},$self->metadata) if defined($self->metadata); + g_data_element($handler,'http://www.openarchives.org/OAI/2.0/','about',{},$_) for $self->about; + g_end_element($handler,'http://www.openarchives.org/OAI/2.0/','record'); +} + +sub start_element { + my ($self,$hash) = @_; + return $self->SUPER::start_element( $hash ) if $self->{in_record}; + my $elem = lc($hash->{LocalName}); + if( $elem eq 'record' && $self->version eq '1.1' ) { + $self->status($hash->{Attributes}->{'{}status'}->{Value}); + } + elsif( $elem =~ /^header|metadata|about$/ ) { + my $handler = $self->{handlers}->{$elem}->new() + or die "Error getting handler for <$elem> (failed to create new $self->{handlers}->{$elem})"; + $self->set_handler($handler); + $self->{in_record} = $hash->{Depth}; + g_start_document( $handler ); + $self->SUPER::start_element( $hash ); + } +} + +sub end_element { + my ($self,$hash) = @_; + $self->SUPER::end_element($hash); + if( $self->{in_record} == $hash->{Depth} ) { + $self->SUPER::end_document(); + + my $elem = lc ($hash->{LocalName}); + $self->$elem ($self->get_handler); + $self->set_handler ( undef ); + $self->{in_record} = 0; + } +} + +1; + +__END__ + +=head1 NAME + +HTTP::OAI::Record - Encapsulates an OAI record + +=head1 SYNOPSIS + + use HTTP::OAI::Record; + + # Create a new HTTP::OAI Record + my $r = new HTTP::OAI::Record(); + + $r->header->identifier('oai:myarchive.org:oid-233'); + $r->header->datestamp('2002-04-01'); + $r->header->setSpec('all:novels'); + $r->header->setSpec('all:books'); + + $r->metadata(new HTTP::OAI::Metadata(dom=>$md)); + $r->about(new HTTP::OAI::Metadata(dom=>$ab)); + +=head1 METHODS + +=over 4 + +=item $r = new HTTP::OAI::Record( %opts ) + +This constructor method returns a new L object. + +Options (see methods below): + + header => $header + metadata => $metadata + about => [$about] + +=item $r->header([HTTP::OAI::Header]) + +Returns and optionally sets the record header (an L object). + +=item $r->metadata([HTTP::OAI::Metadata]) + +Returns and optionally sets the record metadata (an L object). + +=item $r->about([HTTP::OAI::Metadata]) + +Optionally adds a new About record (an L object) and returns an array of objects (may be empty). + +=back + +=head2 Header Accessor Methods + +These methods are equivalent to C<< $rec->header->$method([$value]) >>. + +=over 4 + +=item $r->identifier([$identifier]) + +Get and optionally set the record OAI identifier. + +=item $r->datestamp([$datestamp]) + +Get and optionally set the record datestamp. + +=item $r->status([$status]) + +Get and optionally set the record status (valid values are 'deleted' or undef). + +=item $r->is_deleted() + +Returns whether this record's status is deleted. + +=back diff --git a/HTTP/OAI/Repository.pm b/HTTP/OAI/Repository.pm new file mode 100644 index 0000000000..420dc7a011 --- /dev/null +++ b/HTTP/OAI/Repository.pm @@ -0,0 +1,271 @@ +package HTTP::OAI::Repository; + +use strict; +use warnings; + +use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS); +require Exporter; + +@ISA = qw(Exporter); + +@EXPORT = qw(); +@EXPORT_OK = qw( &validate_request &validate_request_1_1 &validate_date &validate_metadataPrefix &validate_responseDate &validate_setSpec ); +%EXPORT_TAGS = (validate=>[qw(&validate_request &validate_date &validate_metadataPrefix &validate_responseDate &validate_setSpec)]); + +use HTTP::OAI::Error qw(%OAI_ERRORS); + +# Copied from Simeon Warner's tutorial at +# http://library.cern.ch/HEPLW/4/papers/3/OAIServer.pm +# (note: corrected grammer for ListSets) +# 0 = optional, 1 = required, 2 = exclusive +my %grammer = ( + 'GetRecord' => + { + 'identifier' => [1, \&validate_identifier], + 'metadataPrefix' => [1, \&validate_metadataPrefix] + }, + 'Identify' => {}, + 'ListIdentifiers' => + { + 'from' => [0, \&validate_date], + 'until' => [0, \&validate_date], + 'set' => [0, \&validate_setSpec_2_0], + 'metadataPrefix' => [1, \&validate_metadataPrefix], + 'resumptionToken' => [2, sub { 0 }] + }, + 'ListMetadataFormats' => + { + 'identifier' => [0, \&validate_identifier] + }, + 'ListRecords' => + { + 'from' => [0, \&validate_date], + 'until' => [0, \&validate_date], + 'set' => [0, \&validate_setSpec_2_0], + 'metadataPrefix' => [1, \&validate_metadataPrefix], + 'resumptionToken' => [2, sub { 0 }] + }, + 'ListSets' => + { + 'resumptionToken' => [2, sub { 0 }] + } +); + +sub new { + my ($class,%args) = @_; + my $self = bless {}, $class; + $self; +} + +sub validate_request { validate_request_2_0(@_); } + +sub validate_request_2_0 { + my %params = @_; + my $verb = $params{'verb'}; + delete $params{'verb'}; + + my @errors; + + return (new HTTP::OAI::Error(code=>'badVerb',message=>'No verb supplied')) unless defined $verb; + + my $grm = $grammer{$verb} or return (new HTTP::OAI::Error(code=>'badVerb',message=>"Unknown verb '$verb'")); + + if( defined $params{'from'} && defined $params{'until'} ) { + if( granularity($params{'from'}) ne granularity($params{'until'}) ) { + return (new HTTP::OAI::Error( + code=>'badArgument', + message=>'Granularity used in from and until must be the same' + )); + } + } + + # Check exclusivity + foreach my $arg (keys %$grm) { + my ($type, $valid_func) = @{$grm->{$arg}}; + next unless ($type == 2 && defined($params{$arg})); + + if( my $err = &$valid_func($params{$arg}) ) { + return (new HTTP::OAI::Error( + code=>'badArgument', + message=>("Bad argument ($arg): " . $err) + )); + } + + delete $params{$arg}; + if( %params ) { + for(keys %params) { + push @errors, new HTTP::OAI::Error( + code=>'badArgument', + message=>"'$_' can not be used in conjunction with $arg" + ); + } + return @errors; + } else { + return (); + } + } + + # Check required/optional + foreach my $arg (keys %$grm) { + my ($type, $valid_func) = @{$grm->{$arg}}; + + if( $params{$arg} ) { + if( my $err = &$valid_func($params{$arg}) ) { + return (new HTTP::OAI::Error(code=>'badArgument',message=>"Bad argument ($arg): " . $err)) + } + } + if( $type == 1 && (!defined($params{$arg}) || $params{$arg} eq '') ) { + return (new HTTP::OAI::Error(code=>'badArgument',message=>"Required argument '$arg' was undefined")); + } + delete $params{$arg}; + } + + if( %params ) { + for(keys %params) { + push @errors, new HTTP::OAI::Error( + code=>'badArgument', + message=>"'$_' is not a recognised argument for $verb" + ); + } + return @errors; + } else { + return (); + } +} + +sub granularity { + my $date = shift; + return 'year' if $date =~ /^\d{4}-\d{2}-\d{2}$/; + return 'seconds' if $date =~ /^\d{4}-\d{2}-\d{2}T\d{2}:\d{2}:\d{2}Z$/; +} + +sub validate_date { + my $date = shift; + return "Date not in OAI format (yyyy-mm-dd or yyyy-mm-ddThh:mm:ssZ)" unless $date =~ /^(\d{4})-(\d{2})-(\d{2})(T\d{2}:\d{2}:\d{2}Z)?$/; + my( $y, $m, $d ) = ($1,($2||1),($3||1)); + return "Month in date is not in range 1-12" if ($m < 1 || $m > 12); + return "Day in date is not in range 1-31" if ($d < 1 || $d > 31); + 0; +} + +sub validate_responseDate { + return + shift =~ /^(\d{4})\-([01][0-9])\-([0-3][0-9])T([0-2][0-9]):([0-5][0-9]):([0-5][0-9])[\+\-]([0-2][0-9]):([0-5][0-9])$/ ? + 0 : + "responseDate not in OAI format (yyyy-mm-ddThh:mm:dd:ss[+-]hh:mm)"; +} + +sub validate_setSpec { + return + shift =~ /^([A-Za-z0-9])+(:[A-Za-z0-9]+)*$/ ? + 0 : + "Set spec not in OAI format, must match ^([A-Za-z0-9])+(:[A-Za-z0-9]+)*\$"; +} + +sub validate_setSpec_2_0 { + return + shift =~ /^([A-Za-z0-9_!'\$\(\)\+\-\.\*])+(:[A-Za-z0-9_!'\$\(\)\+\-\.\*]+)*$/ ? + 0 : + "Set spec not in OAI format, must match ([A-Za-z0-9_!'\\\$\(\\)\\+\\-\\.\\*])+(:[A-Za-z0-9_!'\\$\\(\\)\\+\\-\\.\\*]+)*"; +} + +sub validate_metadataPrefix { + return + shift =~ /^[\w]+$/ ? + 0 : + "Metadata prefix not in OAI format, must match regexp ^[\\w]+\$"; +} + +# OAI 2 requires identifiers by valid URIs +# This doesn't check for invalid chars, merely : +sub validate_identifier { + return + shift =~ /^[[:alpha:]][[:alnum:]\+\-\.]*:.+/ ? + 0 : + "Identifier not in OAI format, must match regexp ^[[:alpha:]][[:alnum:]\\+\\-\\.]*:.+"; +} + +1; + +__END__ + +=head1 NAME + +HTTP::OAI::Repository - Documentation for building an OAI compliant repository using OAI-PERL + +=head1 DESCRIPTION + +Using the OAI-PERL library in a repository context requires the user to build the OAI responses to be sent to OAI harvesters. + +=head1 SYNOPSIS 1 + + use HTTP::OAI::Harvester; + use HTTP::OAI::Metadata::OAI_DC; + use XML::SAX::Writer; + use XML::LibXML; + + # (all of these options _must_ be supplied to comply with the OAI protocol) + # (protocolVersion and responseDate both have sensible defaults) + my $r = new HTTP::OAI::Identify( + baseURL=>'http://yourhost/cgi/oai', + adminEmail=>'youremail@yourhost', + repositoryName=>'agoodname', + requestURL=>self_url() + ); + + # Include a description (an XML::LibXML Dom object) + $r->description(new HTTP::OAI::Metadata(dom=>$dom)); + + my $r = HTTP::OAI::Record->new( + header=>HTTP::OAI::Header->new( + identifier=>'oai:myrepo:10', + datestamp=>'2004-10-01' + ), + metadata=>HTTP::OAI::Metadata::OAI_DC->new( + dc=>{title=>['Hello, World!'],description=>['My Record']} + ) + ); + $r->about(HTTP::OAI::Metadata->new(dom=>$dom)); + + my $writer = XML::SAX::Writer->new(); + $r->set_handler($writer); + $r->generate; + +=head1 Building an OAI compliant repository + +The validation scripts included in this module provide the repository admin with a number of tools for helping with being OAI compliant, however they can not be exhaustive in themselves. + +=head1 METHODS + +=over 4 + +=item $r = HTTP::OAI::Repository::validate_request(%paramlist) + +=item $r = HTTP::OAI::Repository::validate_request_2_0(%paramlist) + +These functions, exported by the Repository module, validate an OAI request against the protocol requirements. Returns an L object, with the code set to 200 if the request is well-formed, or an error code and the message set. + +e.g: + + my $r = validate_request(%paramlist); + + print header(-status=>$r->code.' '.$r->message), + $r->error_as_HTML; + +Note that validate_request attempts to be as strict to the Protocol as possible. + +=item $b = HTTP::OAI::Repository::validate_date($date) + +=item $b = HTTP::OAI::Repository::validate_metadataPrefix($mdp) + +=item $b = HTTP::OAI::Repository::validate_responseDate($date) + +=item $b = HTTP::OAI::Repository::validate_setSpec($set) + +These functions, exported by the Repository module, validate the given type of OAI data. Returns true if the given value is sane, false otherwise. + +=back + +=head1 EXAMPLE + +See the bin/gateway.pl for an example implementation (it's actually for creating a static repository gateway, but you get the idea!). diff --git a/HTTP/OAI/Response.pm b/HTTP/OAI/Response.pm new file mode 100644 index 0000000000..fde64f9816 --- /dev/null +++ b/HTTP/OAI/Response.pm @@ -0,0 +1,420 @@ +package HTTP::OAI::Response; + +use strict; +use warnings; + +=head1 NAME + +HTTP::OAI::Response - An OAI response + +=head1 DESCRIPTION + +C inherits from L and supplies some utility methods for OAI. + +=head1 METHODS + +=over 4 + +=cut + +use vars qw($BAD_REPLACEMENT_CHAR @ISA); + +our $USE_EVAL = 1; + +use utf8; + +use POSIX qw/strftime/; + +use CGI qw/-oldstyle_urls/; +$CGI::USE_PARAM_SEMICOLON = 0; + +use HTTP::OAI::SAXHandler qw/ :SAX /; + +@ISA = qw( HTTP::Response XML::SAX::Base ); +$BAD_REPLACEMENT_CHAR = '?'; + +=item $r = new HTTP::OAI::Response([responseDate=>$rd][, requestURL=>$ru]) + +This constructor method returns a new HTTP::OAI::Response object. Optionally set the responseDate and requestURL. + +Use $r->is_error to test whether the request was successful. In addition to the HTTP response codes, the following codes may be returned: + +600 - Error parsing XML or invalid OAI response + +Use $r->message to obtain a human-readable error message. + +=cut + +sub new { + my ($class,%args) = @_; + my $self = $class->SUPER::new( + $args{code}, + $args{message} + ); + # Force headers + $self->{handlers} = $args{handlers} || {}; + $self->{_headers} = new HTTP::OAI::Headers(handlers=>$args{handlers}); + $self->{errors} = $args{errors} || []; + $self->{resume} = $args{resume}; + + # Force the version of OAI to try to parse + $self->version($args{version}); + + # Add the harvestAgent + $self->harvestAgent($args{harvestAgent}); + + # OAI initialisation + if( $args{responseDate} ) { + $self->responseDate($args{responseDate}); + } + if( $args{requestURL} ) { + $self->requestURL($args{requestURL}); + } + if( $args{xslt} ) { + $self->xslt($args{xslt}); + } + + # Do some intelligent filling of undefined values + unless( defined($self->responseDate) ) { + $self->responseDate(strftime("%Y-%m-%dT%H:%M:%S",gmtime).'Z'); + } + unless( defined($self->requestURL) ) { + $self->requestURL(CGI::self_url()); + } + unless( defined($self->verb) ) { + my $verb = ref($self); + $verb =~ s/.*:://; + $self->verb($verb); + } + + return $self; +} + +=item $r->copy_from( $r ) + +Copies an L $r into this object. + +=cut + +sub copy_from +{ + my( $self, $r ) = @_; + + # The DOM stuff will break if headers isn't an HTTP::OAI::Headers object + $self->{_headers}->{$_} = $r->{_headers}->{$_} + for keys %{$r->{_headers}}; + + $self->{_content} = $r->{_content}; + + $self->code( $r->code ); + $self->message( $r->message ); + $self->request( $r->request ); + + $self; +} + +=item $headers = $r->headers + +Returns an L object. + +=cut + +sub parse_file { + my ($self, $fh) = @_; + + $self->code(200); + $self->message('parse_file'); + + my $parser = XML::LibXML::SAX->new( + Handler=>HTTP::OAI::SAXHandler->new( + Handler=>$self->headers + )); + +HTTP::OAI::Debug::trace( $self->verb . " " . ref($parser) . "->parse_file( ".ref($fh)." )" ); + $self->headers->set_handler($self); + $USE_EVAL ? + eval { $parser->parse_file($fh) } : + $parser->parse_file($fh); + $self->headers->set_handler(undef); # Otherwise we memory leak! + + if( $@ ) { + $self->code(600); + my $msg = $@; + $msg =~ s/^\s+//s; + $msg =~ s/\s+$//s; + if( $self->request ) { + $msg = "Error parsing XML from " . $self->request->uri . " " . $msg; + } else { + $msg = "Error parsing XML from string: $msg\n"; + } + $self->message($msg); + $self->errors(new HTTP::OAI::Error( + code=>'parseError', + message=>$msg + )); + } +} + +sub parse_string { + my ($self, $str) = @_; + + $self->code(200); + $self->message('parse_string'); + do { + my $parser = XML::LibXML::SAX->new( + Handler=>HTTP::OAI::SAXHandler->new( + Handler=>$self->headers + )); +HTTP::OAI::Debug::trace( $self->verb . " " . ref($parser) . "->parse_string(...)" ); + + $self->headers->set_handler($self); + eval { + local $SIG{__DIE__}; + $parser->parse_string( $str ) + }; + $self->headers->set_handler(undef); + undef $@ if $@ && $@ =~ /^done\n/; + + if( $@ ) { + die $@ if !$USE_EVAL; # rethrow + $self->errors(new HTTP::OAI::Error( + code=>'parseError', + message=>"Error while parsing XML: $@", + )); + } + } while( $@ && fix_xml(\$str,$@) ); + if( $@ ) { + $self->code(600); + my $msg = $@; + $msg =~ s/^\s+//s; + $msg =~ s/\s+$//s; + if( $self->request ) { + $msg = "Error parsing XML from " . $self->request->uri . " " . $msg; + } else { + $msg = "Error parsing XML from string: $msg\n"; + } + $self->message($msg); + $self->errors(new HTTP::OAI::Error( + code=>'parseError', + message=>$msg + )); + } + $self; +} + +sub harvestAgent { shift->headers->header('harvestAgent',@_) } + +# Resume a request using a resumptionToken +sub resume { + my ($self,%args) = @_; + my $ha = $args{harvestAgent} || $self->harvestAgent || Carp::confess "Required argument harvestAgent is undefined"; + my $token = $args{resumptionToken} || Carp::confess "Required argument resumptionToken is undefined"; + my $verb = $args{verb} || $self->verb || Carp::confess "Required argument verb is undefined"; + + if( !ref($token) or !$token->isa( "HTTP::OAI::ResumptionToken" ) ) + { + $token = HTTP::OAI::ResumptionToken->new( resumptionToken => $token ); + } + +HTTP::OAI::Debug::trace( "'" . $token->resumptionToken . "'" ); + + my $response; + %args = ( + baseURL=>$ha->repository->baseURL, + verb=>$verb, + resumptionToken=>$token->resumptionToken, + ); + $self->headers->{_args} = \%args; + + # Reset the resumptionToken + $self->headers->header('resumptionToken',undef); + + # Retry the request upto 3 times (leave a minute between retries) + my $tries = 3; + do { + $response = $ha->request(\%args, undef, undef, undef, $self); + unless( $response->is_success ) { + # If the token is expired, we need to break out (no point wasting 3 + # minutes) + if( my @errors = $response->errors ) { + for( grep { $_->code eq 'badResumptionToken' } @errors ) { + $tries = 0; + } + } +HTTP::OAI::Debug::trace( sprintf("Error response to '%s': %d '%s'\n", + $args{resumptionToken}, + $response->code, + $response->message + ) ); + } + } while( + !$response->is_success and + $tries-- and + sleep(60) + ); + + if( $self->resumptionToken and + !$self->resumptionToken->is_empty and + $self->resumptionToken->resumptionToken eq $token->resumptionToken ) { + $self->code(600); + $self->message("Flow-control error: Resumption token hasn't changed (" . $response->request->uri . ")."); + } + + $self; +} + +sub generate { + my ($self) = @_; + return unless defined(my $handler = $self->get_handler); + $self->headers->set_handler($handler); + + g_start_document($handler); + $handler->xml_decl({'Version'=>'1.0','Encoding'=>'UTF-8'}); + $handler->characters({'Data'=>"\n"}); + if( $self->xslt ) { + $handler->processing_instruction({ + 'Target' => 'xml-stylesheet', + 'Data' => 'type=\'text/xsl\' href=\''. $self->xslt . '\'' + }); + } + $self->headers->generate_start(); + + if( $self->errors ) { + for( $self->errors ) { + $_->set_handler($handler); + $_->generate(); + } + } else { + g_start_element($handler,'http://www.openarchives.org/OAI/2.0/',$self->verb,{}); + $self->generate_body(); + g_end_element($handler,'http://www.openarchives.org/OAI/2.0/',$self->verb,{}); + } + + $self->headers->generate_end(); + $handler->end_document(); +} + +sub toDOM { + my $self = shift; + $self->set_handler(my $builder = XML::LibXML::SAX::Builder->new()); + $self->generate(); + $builder->result; +} + +=item $errs = $r->errors([$err]) + +Returns and optionally adds to the OAI error list. Returns a reference to an array. + +=cut + +sub errors { + my $self = shift; + push @{$self->{errors}}, @_; + for (@_) { + if( $_->code eq 'badVerb' || $_->code eq 'badArgument' ) { + my $uri = URI->new($self->requestURL || ''); + $uri->query(''); + $self->requestURL($uri->as_string); + last; + } + } + @{$self->{errors}}; +} + +sub next { undef } + +=item $rd = $r->responseDate( [$rd] ) + +Returns and optionally sets the response date. + +=cut + +sub responseDate { shift->headers->header('responseDate',@_) } + +=item $ru = $r->requestURL( [$ru] ) + +Returns and optionally sets the request URL. + +=cut + +sub requestURL { + my $self = shift; + $_[0] =~ s/;/&/sg if @_ && $_[0] !~ /&/; + $self->headers->header('requestURL',@_) +} + +=item $verb = $r->verb( [$verb] ) + +Returns and optionally sets the OAI verb. + +=cut + +sub verb { shift->headers->header('verb',@_) } + +=item $r->version + +Return the version of the OAI protocol used by the remote site (protocolVersion is automatically changed by the underlying API). + +=cut + +sub version { shift->headers->header('version',@_) } + +=item $r->xslt( $url ) + +Set the stylesheet to use in a response. + +=cut + +sub xslt { shift->headers->header('xslt',@_) } + +# HTTP::Response::is_error doesn't consider 0 an error +sub is_error { return shift->code != 200 } + +sub end_element { + my ($self,$hash) = @_; + my $elem = lc($hash->{Name}); + $self->SUPER::end_element($hash); + if( $elem eq 'error' ) { + my $code = $hash->{Attributes}->{'{}code'}->{'Value'} || 'oai-lib: Undefined error code'; + my $msg = $hash->{Text} || 'oai-lib: Undefined error message'; + $self->errors(new HTTP::OAI::Error( + code=>$code, + message=>$msg, + )); + if( $code !~ '^noRecordsMatch|noSetHierarchy$' ) { + $self->verb($elem); + $self->code(600); + $self->message("Response contains error(s): " . $self->{errors}->[0]->code . " (" . $self->{errors}->[0]->message . ")"); + } + } +} + +sub fix_xml { + my ($str, $err) = @_; + return 0 unless( $err =~ /not well-formed.*byte (\d+)/ ); + my $offset = $1; + if( substr($$str,$offset-1,1) eq '&' ) { + substr($$str,$offset-1,1) = '&'; + return 1; + } elsif( substr($$str,$offset-1,1) eq '<' ) { + substr($$str,$offset-1,1) = '<'; + return 1; + } elsif( substr($$str,$offset,1) ne $BAD_REPLACEMENT_CHAR ) { + substr($$str,$offset,1) = $BAD_REPLACEMENT_CHAR; + return 1; + } else { + return 0; + } +} + +1; + +__END__ + +=back + +=head1 NOTE - requestURI/request + +Version 2.0 of OAI uses a "request" element to contain the client's request, rather than a URI. The OAI-PERL library automatically converts from a URI into the appropriate request structure, and back again when harvesting. + +The exception to this rule is for badVerb errors, where the arguments will not be available for conversion into a URI. diff --git a/HTTP/OAI/ResumptionToken.pm b/HTTP/OAI/ResumptionToken.pm new file mode 100644 index 0000000000..4595ec3ed2 --- /dev/null +++ b/HTTP/OAI/ResumptionToken.pm @@ -0,0 +1,93 @@ +package HTTP::OAI::ResumptionToken; + +use strict; +use warnings; + +use HTTP::OAI::SAXHandler qw/ :SAX /; + +use vars qw( @ISA ); +@ISA = qw( HTTP::OAI::Encapsulation ); + +use overload "bool" => \¬_empty; + +sub new { + my ($class,%args) = @_; + my $self = $class->SUPER::new(%args); + + $self->resumptionToken($args{resumptionToken}) unless $self->resumptionToken; + $self->expirationDate($args{expirationDate}) unless $self->expirationDate; + $self->completeListSize($args{completeListSize}) unless $self->completeListSize; + $self->cursor($args{cursor}) unless $self->cursor; + + $self; +} + +sub resumptionToken { shift->_elem('resumptionToken',@_) } +sub expirationDate { shift->_attr('expirationDate',@_) } +sub completeListSize { shift->_attr('completeListSize',@_) } +sub cursor { shift->_attr('cursor',@_) } + +sub not_empty { defined($_[0]->resumptionToken) and length($_[0]->resumptionToken) > 0 } +sub is_empty { !not_empty(@_) } + +sub generate { + my ($self) = @_; + return unless (my $handler = $self->get_handler); + my $attr; + while(my ($key,$value) = each %{$self->_attr}) { + $attr->{"{}$key"} = {'Name'=>$key,'LocalName'=>$key,'Value'=>$value,'Prefix'=>'','NamespaceURI'=>'http://www.openarchives.org/OAI/2.0/'}; + } + g_data_element($handler,'http://www.openarchives.org/OAI/2.0/','resumptionToken',$attr,$self->resumptionToken); +} + +sub end_element { + my ($self,$hash) = @_; + $self->SUPER::end_element($hash); + if( lc($hash->{Name}) eq 'resumptiontoken' ) { + my $attr = $hash->{Attributes}; + $self->resumptionToken($hash->{Text}); + + $self->expirationDate($attr->{'{}expirationDate'}->{'Value'}); + $self->completeListSize($attr->{'{}completeListSize'}->{'Value'}); + $self->cursor($attr->{'{}cursor'}->{'Value'}); + } +#warn "Got RT: $hash->{Text}"; +} + +1; + +__END__ + +=head1 NAME + +HTTP::OAI::ResumptionToken - Encapsulates an OAI resumption token + +=head1 METHODS + +=over 4 + +=item $rt = new HTTP::OAI::ResumptionToken + +This constructor method returns a new HTTP::OAI::ResumptionToken object. + +=item $token = $rt->resumptionToken([$token]) + +Returns and optionally sets the resumption token string. + +=item $ed = $rt->expirationDate([$rt]) + +Returns and optionally sets the expiration date of the resumption token. + +=item $cls = $rt->completeListSize([$cls]) + +Returns and optionally sets the cardinality of the result set. + +=item $cur = $rt->cursor([$cur]) + +Returns and optionally sets the index of the first record (of the current page) in the result set. + +=back + +=head1 NOTE - Completing incomplete list + +The final page of a record list which has been split using resumption tokens must contain an empty resumption token. diff --git a/HTTP/OAI/SAXHandler.pm b/HTTP/OAI/SAXHandler.pm new file mode 100644 index 0000000000..fda7ae3334 --- /dev/null +++ b/HTTP/OAI/SAXHandler.pm @@ -0,0 +1,266 @@ +package HTTP::OAI::SAXHandler; + +use strict; +use warnings; + +use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS); + +use Data::Dumper; # debugging for here + +@ISA = qw( Exporter XML::SAX::Base ); + +@EXPORT_OK = qw( g_start_document g_start_element g_end_element g_data_element ); +%EXPORT_TAGS = (SAX=>[qw( g_start_document g_start_element g_end_element g_data_element )]); + +=pod + +=head1 NAME + +HTTP::OAI::SAXHandler - SAX2 utility filter + +=head1 DESCRIPTION + +This module provides utility methods for SAX2, including collapsing multiple "characters" events into a single event. + +This module exports methods for generating SAX2 events with Namespace support. This *isn't* a fully-fledged SAX2 generator! + +=over 4 + +=item $h = HTTP::OAI::SAXHandler->new() + +Class constructor. + +=cut + +sub new { + my ($class,%args) = @_; + $class = ref($class) || $class; + my $self = $class->SUPER::new(%args); + $self->{Depth} = 0; + $self; +} + +sub g_start_document { + my ($handler) = @_; + $handler->start_document(); + $handler->start_prefix_mapping({ + 'Prefix'=>'xsi', + 'NamespaceURI'=>'http://www.w3.org/2001/XMLSchema-instance' + }); + $handler->start_prefix_mapping({ + 'Prefix'=>'', + 'NamespaceURI'=>'http://www.openarchives.org/OAI/2.0/' + }); +} + +sub g_data_element { + my ($handler,$uri,$qName,$attr,$value) = @_; + g_start_element($handler,$uri,$qName,$attr); + if( ref($value) ) { + $value->set_handler($handler); + $value->generate; + } else { + $handler->characters({'Data'=>$value}); + } + g_end_element($handler,$uri,$qName); +} + +sub g_start_element { + my ($handler,$uri,$qName,$attr) = @_; + $attr ||= {}; + my ($prefix,$localName) = split /:/, $qName; + unless(defined($localName)) { + $localName = $prefix; + $prefix = ''; + } + $handler->start_element({ + 'NamespaceURI'=>$uri, + 'Name'=>$qName, + 'Prefix'=>$prefix, + 'LocalName'=>$localName, + 'Attributes'=>$attr + }); +} + +sub g_end_element { + my ($handler,$uri,$qName) = @_; + my ($prefix,$localName) = split /:/, $qName; + unless(defined($localName)) { + $localName = $prefix; + $prefix = ''; + } + $handler->end_element({ + 'NamespaceURI'=>$uri, + 'Name'=>$qName, + 'Prefix'=>$prefix, + 'LocalName'=>$localName, + }); +} + +sub current_state { + my $self = shift; + return $self->{State}->[$#{$self->{State}}]; +} + +sub current_element { + my $self = shift; + return $self->{Elem}->[$#{$self->{Elem}}]; +} + +sub start_document { +HTTP::OAI::Debug::sax( Dumper($_[1]) ); + $_[0]->SUPER::start_document(); +} + +sub end_document { + $_[0]->SUPER::end_document(); +HTTP::OAI::Debug::sax( Dumper($_[1]) ); +} + +# Char data is rolled together by this module +sub characters { + my ($self,$hash) = @_; + $self->{Text} .= $hash->{Data}; +# characters are traced in {start,end}_element +#HTTP::OAI::Debug::sax( "'" . substr($hash->{Data},0,40) . "'" ); +} + +sub start_element { + my ($self,$hash) = @_; + push @{$self->{Attributes}}, $hash->{Attributes}; + + # Call characters with the joined character data + if( defined($self->{Text}) ) + { +HTTP::OAI::Debug::sax( "'".substr($self->{Text},0,40) . "'" ); + $self->SUPER::characters({Data=>$self->{Text}}); + $self->{Text} = undef; + } + + $hash->{State} = $self; + $hash->{Depth} = ++$self->{Depth}; +HTTP::OAI::Debug::sax( (" " x $hash->{Depth}) . '<'.$hash->{Name}.'>' ); + $self->SUPER::start_element($hash); +} + +sub end_element { + my ($self,$hash) = @_; + + # Call characters with the joined character data + $hash->{Text} = $self->{Text}; + if( defined($self->{Text}) ) + { + # Trailing whitespace causes problems + if( $self->{Text} =~ /\S/ ) + { +HTTP::OAI::Debug::sax( "'".substr($self->{Text},0,40) . "'" ); + $self->SUPER::characters({Data=>$self->{Text}}); + } + $self->{Text} = undef; + } + + $hash->{Attributes} = pop @{$self->{Attributes}} || {}; + $hash->{State} = $self; + $hash->{Depth} = $self->{Depth}--; +HTTP::OAI::Debug::sax( (" " x $hash->{Depth}) . ' <'.$hash->{Name}.'>' ); + $self->SUPER::end_element($hash); +} + +sub entity_reference { + my ($self,$hash) = @_; +HTTP::OAI::Debug::sax( $hash->{Name} ); +} + +sub start_cdata { +HTTP::OAI::Debug::sax(); +} + +sub end_cdata { +HTTP::OAI::Debug::sax(); +} + +sub comment { +HTTP::OAI::Debug::sax( $_[1]->{Data} ); +} + +sub doctype_decl { + # {SystemId,PublicId,Internal} +HTTP::OAI::Debug::sax( $_[1]->{Name} ); +} + +sub attlist_decl { + # {ElementName,AttributeName,Type,Default,Fixed} +HTTP::OAI::Debug::sax( $_[1]->{ElementName} ); +} + +sub xml_decl { + # {Version,Encoding,Standalone} +HTTP::OAI::Debug::sax( join ", ", map { defined($_) ? $_ : "null" } @{$_[1]}{qw( Version Encoding Standalone )} ); +} + +sub entity_decl { + # {Value,SystemId,PublicId,Notation} +HTTP::OAI::Debug::sax( $_[1]->{Name} ); +} + +sub unparsed_decl { +HTTP::OAI::Debug::sax(); +} + +sub element_decl { + # {Model} +HTTP::OAI::Debug::sax( $_[1]->{Name} ); +} + +sub notation_decl { + # {Name,Base,SystemId,PublicId} +HTTP::OAI::Debug::sax( $_[1]->{Name} ); +} + +sub processing_instruction { + # {Target,Data} +HTTP::OAI::Debug::sax( $_[1]->{Target} . " => " . $_[1]->{Data} ); +} + +package HTTP::OAI::FilterDOMFragment; + +use vars qw( @ISA ); + +@ISA = qw( XML::SAX::Base ); + +# Trap things that don't apply to a balanced fragment +sub start_document {} +sub end_document {} +sub xml_decl {} + +package XML::SAX::Debug; + +use Data::Dumper; + +use vars qw( @ISA $AUTOLOAD ); + +@ISA = qw( XML::SAX::Base ); + +sub DEBUG { + my ($event,$self,$hash) = @_; +warn "$event(".Dumper($hash).")\n"; + my $superior = "SUPER::$event"; + $self->$superior($hash); +} + +sub start_document { DEBUG('start_document',@_) } +sub end_document { DEBUG('end_document',@_) } +sub start_element { DEBUG('start_element',@_) } +sub end_element { DEBUG('end_element',@_) } +sub characters { DEBUG('characters',@_) } +sub xml_decl { DEBUG('xml_decl',@_) } + +1; + +__END__ + +=back + +=head1 AUTHOR + +Tim Brody diff --git a/HTTP/OAI/Set.pm b/HTTP/OAI/Set.pm new file mode 100644 index 0000000000..0d1e812c5b --- /dev/null +++ b/HTTP/OAI/Set.pm @@ -0,0 +1,94 @@ +package HTTP::OAI::Set; + +use strict; +use warnings; + +use HTTP::OAI::SAXHandler qw/ :SAX /; + +use vars qw( @ISA ); +@ISA = qw( HTTP::OAI::Encapsulation ); + +sub new { + my ($class,%args) = @_; + my $self = $class->SUPER::new(%args); + + $self->{handlers} = $args{handlers}; + + $self->setSpec($args{setSpec}); + $self->setName($args{setName}); + $self->{setDescription} = $args{setDescription} || []; + $self; +} + +sub setSpec { shift->_elem('setSpec',@_) } +sub setName { shift->_elem('setName',@_) } +sub setDescription { + my $self = shift; + push(@{$self->{setDescription}}, @_); + return @{$self->{setDescription}}; +} +sub next { shift @{shift->{setDescription}} } + +sub generate { + my ($self) = @_; + return unless defined(my $handler = $self->get_handler); + g_start_element($handler,'http://www.openarchives.org/OAI/2.0/','set',{}); + g_data_element($handler,'http://www.openarchives.org/OAI/2.0/','setSpec',{},$self->setSpec); + g_data_element($handler,'http://www.openarchives.org/OAI/2.0/','setName',{},$self->setName); + for( $self->setDescription ) { + $_->set_handler($handler); + $_->generate; + } + g_end_element($handler,'http://www.openarchives.org/OAI/2.0/','set'); +} + +sub start_element { + my ($self,$hash) = @_; + my $elem = lc($hash->{Name}); + if( $elem eq 'setdescription' ) { + $self->setDescription(my $d = $self->{handlers}->{description}->new(version=>$self->version)); + $self->set_handler($d); + g_start_document($d); + } + $self->SUPER::start_element($hash); +} +sub end_element { + my ($self,$hash) = @_; + $self->SUPER::end_element($hash); + my $elem = lc($hash->{Name}); + if( $elem eq 'setspec' ) { + die ref($self)." Parse error: Empty setSpec\n" unless $hash->{Text}; + $self->setSpec($hash->{Text}); + } elsif( $elem eq 'setname' ) { + warn ref($self)." Parse error: Empty setName\n", return + unless $hash->{Text}; + $self->setName($hash->{Text}); + } elsif( $elem eq 'setdescription' ) { + $self->SUPER::end_document(); + $self->set_handler(undef); + } +} + +1; + +__END__ + +=head1 NAME + +HTTP::OAI::Set - Encapsulates OAI set XML data + +=head1 METHODS + +=over 4 + +=item $spec = $s->setSpec([$spec]) + +=item $name = $s->setName([$name]) + +These methods return respectively, the setSpec and setName of the OAI Set. + +=item @descs = $s->setDescription([$desc]) + +Returns and optionally adds the list of set descriptions. Returns a reference to an array of L objects. + +=back diff --git a/HTTP/OAI/UserAgent.pm b/HTTP/OAI/UserAgent.pm new file mode 100644 index 0000000000..d3ceabc93b --- /dev/null +++ b/HTTP/OAI/UserAgent.pm @@ -0,0 +1,320 @@ +package HTTP::OAI::UserAgent; + +use strict; +use warnings; + +use vars qw(@ISA $ACCEPT); + +# Do not use eval() +our $USE_EVAL = 1; +# Ignore bad utf8 characters +our $IGNORE_BAD_CHARS = 1; +# Silence bad utf8 warnings +our $SILENT_BAD_CHARS = 0; + +use constant MAX_UTF8_BYTES => 4; + +require LWP::UserAgent; +@ISA = qw(LWP::UserAgent); + +unless( $@ ) { + $ACCEPT = "gzip"; +} + +sub delay { shift->_elem( "delay", @_ ) } +sub last_request_completed { shift->_elem( "last_request_completed", @_ ) } + +sub redirect_ok { 1 } + +sub request +{ + my $self = shift; + my ($request, $arg, $size, $previous, $response) = @_; + if( ref($request) eq 'HASH' ) { + $request = HTTP::Request->new(GET => _buildurl(%$request)); + } + + my $delay = $self->delay; + if( defined $delay ) + { + if( ref($delay) eq "CODE" ) + { + $delay = &$delay( $self->last_request_completed ); + } + select(undef,undef,undef,$delay) if $delay > 0; + } + + if( !defined $response ) + { + $response = $self->SUPER::request(@_); + $self->last_request_completed( time ); + return $response; + } + + my $parser = XML::LibXML->new( + Handler => HTTP::OAI::SAXHandler->new( + Handler => $response->headers + )); + $parser->{request} = $request; + $parser->{content_length} = 0; + $parser->{content_buffer} = Encode::encode('UTF-8',''); + $response->code(200); + $response->message('lwp_callback'); + $response->headers->set_handler($response); +HTTP::OAI::Debug::trace( $response->verb . " " . ref($parser) . "->parse_chunk()" ); + my $r; + { + local $SIG{__DIE__}; + $r = $self->SUPER::request($request,sub { + $self->lwp_callback( $parser, @_ ) + }); + $self->lwp_endparse( $parser ) if $r->is_success; + } + if( defined($r) && defined($r->headers->header( 'Client-Aborted' )) && $r->headers->header( 'Client-Aborted' ) eq 'die' ) + { + my $err = $r->headers->header( 'X-Died' ); + if( $err !~ /^done\n/ ) + { + $r->code(500); + $r->message( 'An error occurred while parsing: ' . $err ); + } + } + + $response->headers->set_handler(undef); + + # Allow access to the original headers through 'previous' + $response->previous($r); + + my $cnt_len = $parser->{content_length}; + undef $parser; + + # OAI retry-after + if( defined($r) && $r->code == 503 && defined(my $timeout = $r->headers->header('Retry-After')) ) { + $self->last_request_completed( time ); + if( $self->{recursion}++ > 10 ) { + $self->{recursion} = 0; + warn ref($self)."::request (retry-after) Given up requesting after 10 retries\n"; + return $response->copy_from( $r ); + } + if( !$timeout or $timeout =~ /\D/ or $timeout < 0 or $timeout > 86400 ) { + warn ref($self)." Archive specified an odd duration to wait (\"".($timeout||'null')."\")\n"; + return $response->copy_from( $r ); + } +HTTP::OAI::Debug::trace( "Waiting $timeout seconds" ); + sleep($timeout+10); # We wait an extra 10 secs for safety + return $self->request($request,undef,undef,undef,$response); + # Got an empty response + } elsif( defined($r) && $r->is_success && $cnt_len == 0 ) { + $self->last_request_completed( time ); + if( $self->{recursion}++ > 10 ) { + $self->{recursion} = 0; + warn ref($self)."::request (empty response) Given up requesting after 10 retries\n"; + return $response->copy_from( $r ); + } +HTTP::OAI::Debug::trace( "Retrying on empty response" ); + sleep(5); + return $self->request($request,undef,undef,undef,$response); + # An HTTP error occurred + } elsif( $r->is_error ) { + $response->copy_from( $r ); + $response->errors(HTTP::OAI::Error->new( + code=>$r->code, + message=>$r->message, + )); + # An error occurred during parsing + } elsif( $@ ) { + $response->code(my $code = $@ =~ /read timeout/ ? 504 : 600); + $response->message($@); + $response->errors(HTTP::OAI::Error->new( + code=>$code, + message=>$@, + )); + } + + # Reset the recursion timer + $self->{recursion} = 0; + + # Copy original $request => OAI $response to allow easy + # access to the requested URL + $response->request($request); + + $self->last_request_completed( time ); + + $response; +} + +sub lwp_badchar +{ + my $codepoint = sprintf('U+%04x', ord($_[2])); + unless( $SILENT_BAD_CHARS ) + { + warn "Bad Unicode character $codepoint at byte offset ".$_[1]->{content_length}." from ".$_[1]->{request}->uri."\n"; + } + return $codepoint; +} + +sub lwp_endparse +{ + my( $self, $parser ) = @_; + + my $utf8 = $parser->{content_buffer}; + # Replace bad chars with '?' + if( $IGNORE_BAD_CHARS and length($utf8) ) { + $utf8 = Encode::decode('UTF-8', $utf8, sub { $self->lwp_badchar($parser, @_) }); + } + if( length($utf8) > 0 ) + { + _ccchars($utf8); # Fix control chars + $parser->{content_length} += length($utf8); + $parser->parse_chunk($utf8); + } + delete($parser->{content_buffer}); + $parser->parse_chunk('', 1); +} + +sub lwp_callback +{ + my( $self, $parser ) = @_; + + use bytes; # fixing utf-8 will need byte semantics + + $parser->{content_buffer} .= $_[2]; + + do + { + # FB_QUIET won't split multi-byte chars on input + my $utf8 = Encode::decode('UTF-8', $parser->{content_buffer}, Encode::FB_QUIET); + + if( length($utf8) > 0 ) + { + use utf8; + _ccchars($utf8); # Fix control chars + $parser->{content_length} += length($utf8); + $parser->parse_chunk($utf8); + } + + if( length($parser->{content_buffer}) > MAX_UTF8_BYTES ) + { + $parser->{content_buffer} =~ s/^([\x80-\xff]{1,4})//s; + my $badbytes = $1; + if( length($badbytes) == 0 ) + { + Carp::confess "Internal error - bad bytes but not in 0x80-0xff range???"; + } + if( $IGNORE_BAD_CHARS ) + { + $badbytes = join('', map { + $self->lwp_badchar($parser, $_) + } split //, $badbytes); + } + $parser->parse_chunk( $badbytes ); + } + } while( length($parser->{content_buffer}) > MAX_UTF8_BYTES ); +} + +sub _ccchars { + $_[0] =~ s/([\x00-\x08\x0b-\x0c\x0e-\x1f])/sprintf("\\%04d",ord($1))/seg; +} + +sub _buildurl { + my %attr = @_; + Carp::confess "_buildurl requires baseURL" unless $attr{'baseURL'}; + Carp::confess "_buildurl requires verb" unless $attr{'verb'}; + my $uri = new URI(delete($attr{'baseURL'})); + if( defined($attr{resumptionToken}) && !$attr{force} ) { + $uri->query_form(verb=>$attr{'verb'},resumptionToken=>$attr{'resumptionToken'}); + } else { + delete $attr{force}; + # http://www.cshc.ubc.ca/oai/ breaks if verb isn't first, doh + $uri->query_form(verb=>delete($attr{'verb'}),%attr); + } + return $uri->as_string; +} + +sub url { + my $self = shift; + return _buildurl(@_); +} + +sub decompress { + my ($response) = @_; + my $type = $response->headers->header("Content-Encoding"); + return $response->{_content_filename} unless defined($type); + if( $type eq 'gzip' ) { + my $filename = File::Temp->new( UNLINK => 1 ); + my $gz = Compress::Zlib::gzopen($response->{_content_filename}, "r") or die $!; + my ($buffer,$c); + my $fh = IO::File->new($filename,"w"); + binmode($fh,":utf8"); + while( ($c = $gz->gzread($buffer)) > 0 ) { + print $fh $buffer; + } + $fh->close(); + $gz->gzclose(); + die "Error decompressing gziped response: " . $gz->gzerror() if -1 == $c; + return $response->{_content_filename} = $filename; + } else { + die "Unsupported compression returned: $type\n"; + } +} + +1; + +__END__ + +=head1 NAME + +HTTP::OAI::UserAgent - Extension of the LWP::UserAgent for OAI HTTP requests + +=head1 DESCRIPTION + +This module provides a simplified mechanism for making requests to an OAI repository, using the existing LWP::UserAgent module. + +=head1 SYNOPSIS + + require HTTP::OAI::UserAgent; + + my $ua = new HTTP::OAI::UserAgent; + + my $response = $ua->request( + baseURL=>'http://arXiv.org/oai1', + verb=>'ListRecords', + from=>'2001-08-01', + until=>'2001-08-31' + ); + + print $response->content; + +=head1 METHODS + +=over 4 + +=item $ua = new HTTP::OAI::UserAgent(proxy=>'www-cache',...) + +This constructor method returns a new instance of a HTTP::OAI::UserAgent module. All arguments are passed to the L constructor. + +=item $r = $ua->request($req) + +Requests the HTTP response defined by $req, which is a L object. + +=item $r = $ua->request(baseURL=>$baseref, verb=>$verb, %opts) + +Makes an HTTP request to the given OAI server (baseURL) with OAI arguments. Returns an L object. + +OAI-PMH related options: + + from => $from + until => $until + resumptionToken => $token + metadataPrefix => $mdp + set => $set + +=item $str = $ua->url(baseURL=>$baseref, verb=>$verb, ...) + +Takes the same arguments as request, but returns the URL that would be requested. + +=item $time_d = $ua->delay( $time_d ) + +Return and optionally set a time (in seconds) to wait between requests. $time_d may be a CODEREF. + +=back diff --git a/Makefile.PL b/Makefile.PL index ecd4297460..8d010b8097 100644 --- a/Makefile.PL +++ b/Makefile.PL @@ -313,6 +313,7 @@ my $target_map = { './etc/zebradb' => { target => 'ZEBRA_CONF_DIR', trimdir => -1 }, './etc/pazpar2' => { target => 'PAZPAR2_CONF_DIR', trimdir => -1 }, './help.pl' => 'INTRANET_CGI_DIR', + './HTTP' => 'PERL_MODULE_DIR', './ill' => 'INTRANET_CGI_DIR', './installer-CPAN.pl' => 'NONE', './installer' => 'INTRANET_CGI_DIR', -- 2.16.2