View | Details | Raw Unified | Return to bug 20437
Collapse All | Expand All

(-)a/HTTP/OAI.pm (+96 lines)
Line 0 Link Here
1
package HTTP::OAI;
2
3
use strict;
4
5
our $VERSION = '3.27';
6
7
# perlcore
8
use Carp;
9
use Encode;
10
11
# http related stuff
12
use URI;
13
use HTTP::Headers;
14
use HTTP::Request;
15
use HTTP::Response;
16
17
# xml related stuff
18
use XML::SAX;
19
use XML::SAX::ParserFactory;
20
use XML::LibXML;
21
use XML::LibXML::SAX;
22
use XML::LibXML::SAX::Parser;
23
use XML::LibXML::SAX::Builder;
24
25
# debug
26
use HTTP::OAI::Debug;
27
28
# oai data objects
29
use HTTP::OAI::Encapsulation; # Basic XML handling stuff
30
use HTTP::OAI::Metadata; # Super class of all data objects
31
use HTTP::OAI::Error;
32
use HTTP::OAI::Header;
33
use HTTP::OAI::MetadataFormat;
34
use HTTP::OAI::Record;
35
use HTTP::OAI::ResumptionToken;
36
use HTTP::OAI::Set;
37
38
# parses OAI headers and other utility bits
39
use HTTP::OAI::Headers;
40
41
# generic superclasses
42
use HTTP::OAI::Response;
43
use HTTP::OAI::PartialList;
44
45
# oai verbs
46
use HTTP::OAI::GetRecord;
47
use HTTP::OAI::Identify;
48
use HTTP::OAI::ListIdentifiers;
49
use HTTP::OAI::ListMetadataFormats;
50
use HTTP::OAI::ListRecords;
51
use HTTP::OAI::ListSets;
52
53
# oai agents
54
use HTTP::OAI::UserAgent;
55
use HTTP::OAI::Harvester;
56
use HTTP::OAI::Repository;
57
58
$HTTP::OAI::Harvester::VERSION = $VERSION;
59
60
if( $ENV{HTTP_OAI_TRACE} )
61
{
62
	HTTP::OAI::Debug::level( '+trace' );
63
}
64
if( $ENV{HTTP_OAI_SAX_TRACE} )
65
{
66
	HTTP::OAI::Debug::level( '+sax' );
67
}
68
69
1;
70
71
__END__
72
73
=head1 NAME
74
75
HTTP::OAI - API for the OAI-PMH
76
77
=head1 DESCRIPTION
78
79
This is a stub module, you probably want to look at
80
L<HTTP::OAI::Harvester|HTTP::OAI::Harvester> or
81
L<HTTP::OAI::Repository|HTTP::OAI::Repository>.
82
83
=head1 SEE ALSO
84
85
You can find links to this and other OAI tools (perl, C++, java) at:
86
http://www.openarchives.org/tools/tools.html.
87
88
Ed Summers L<Net::OAI::Harvester> module.
89
90
=head1 AUTHOR
91
92
Copyright 2004-2010 Tim Brody <tdb2@ecs.soton.ac.uk>, University of
93
Southampton.
94
95
This module is free software and is released under the BSD License (see
96
LICENSE).
(-)a/HTTP/OAI/Debug.pm (+80 lines)
Line 0 Link Here
1
package HTTP::OAI::Debug;
2
3
=pod
4
5
=head1 NAME
6
7
B<HTTP::OAI::Debug> - debug the HTTP::OAI libraries
8
9
=head1 DESCRIPTION
10
11
This package is a copy of L<LWP::Debug> and exposes the same API. In addition to "trace", "debug" and "conns" this exposes a "sax" level for debugging SAX events.
12
13
=cut
14
15
require Exporter;
16
@ISA = qw(Exporter);
17
@EXPORT_OK = qw(level trace debug conns);
18
19
use Carp ();
20
21
my @levels = qw(trace debug conns sax);
22
%current_level = ();
23
24
25
sub import
26
{
27
    my $pack = shift;
28
    my $callpkg = caller(0);
29
    my @symbols = ();
30
    my @levels = ();
31
    for (@_) {
32
	if (/^[-+]/) {
33
	    push(@levels, $_);
34
	}
35
	else {
36
	    push(@symbols, $_);
37
	}
38
    }
39
    Exporter::export($pack, $callpkg, @symbols);
40
    level(@levels);
41
}
42
43
44
sub level
45
{
46
    for (@_) {
47
	if ($_ eq '+') {              # all on
48
	    # switch on all levels
49
	    %current_level = map { $_ => 1 } @levels;
50
	}
51
	elsif ($_ eq '-') {           # all off
52
	    %current_level = ();
53
	}
54
	elsif (/^([-+])(\w+)$/) {
55
	    $current_level{$2} = $1 eq '+';
56
	}
57
	else {
58
	    Carp::croak("Illegal level format $_");
59
	}
60
    }
61
}
62
63
64
sub trace  { _log(@_) if $current_level{'trace'}; }
65
sub debug  { _log(@_) if $current_level{'debug'}; }
66
sub conns  { _log(@_) if $current_level{'conns'}; }
67
sub sax    { _log(@_) if $current_level{'sax'}; }
68
69
70
sub _log
71
{
72
    my $msg = shift;
73
	$msg =~ s/\n$//;
74
	$msg =~ s/\n/\\n/g;
75
76
    my($package,$filename,$line,$sub) = caller(2);
77
    print STDERR "$sub: $msg\n";
78
}
79
80
1;
(-)a/HTTP/OAI/Encapsulation.pm (+109 lines)
Line 0 Link Here
1
package HTTP::OAI::Encapsulation;
2
3
use strict;
4
use warnings;
5
6
use HTTP::OAI::SAXHandler qw( :SAX );
7
8
use vars qw(@ISA);
9
@ISA = qw(XML::SAX::Base);
10
11
sub new {
12
	my $class = shift;
13
	my %args = @_ > 1 ? @_ : (dom => shift);
14
	my $self = bless {}, ref($class) || $class;
15
	$self->version($args{version});
16
	$self->dom($args{dom});
17
	$self;
18
}
19
20
sub dom { shift->_elem('dom',@_) }
21
22
# Pseudo HTTP::Response
23
sub code { 200 }
24
sub message { 'OK' }
25
26
sub is_info { 0 }
27
sub is_success { 1 }
28
sub is_redirect { 0 }
29
sub is_error { 0 }
30
31
sub version { shift->_elem('version',@_) }
32
33
sub _elem {
34
	my $self = shift;
35
	my $name = shift;
36
	return @_ ? $self->{_elem}->{$name} = shift : $self->{_elem}->{$name};
37
}
38
39
sub _attr {
40
	my $self = shift;
41
	my $name = shift or return $self->{_attr};
42
	return $self->{_attr}->{$name} unless @_;
43
	if( defined(my $value = shift) ) {
44
		return $self->{_attr}->{$name} = $value;
45
	} else {
46
		delete $self->{_attr}->{$name};
47
		return undef;
48
	}
49
}
50
51
package HTTP::OAI::Encapsulation::DOM;
52
53
use strict;
54
use warnings;
55
56
use XML::LibXML qw( :all );
57
58
use vars qw(@ISA);
59
@ISA = qw(HTTP::OAI::Encapsulation);
60
61
sub toString { defined($_[0]->dom) ? $_[0]->dom->toString : undef }
62
63
sub generate {
64
	my $self = shift;
65
	unless( $self->dom ) {
66
		Carp::confess("Can't generate() without a dom.");
67
	}
68
	unless( $self->dom->nodeType == XML_DOCUMENT_NODE ) {
69
		Carp::confess( "Can only generate() from a DOM of type XML_DOCUMENT_NODE" );
70
	}
71
	return unless defined($self->get_handler);
72
	my $driver = XML::LibXML::SAX::Parser->new(
73
			Handler=>HTTP::OAI::FilterDOMFragment->new(
74
				Handler=>$self->get_handler
75
	));
76
	$driver->generate($self->dom);
77
}
78
79
sub start_document {
80
	my ($self) = @_;
81
HTTP::OAI::Debug::sax( ref($self) );
82
	my $builder = XML::LibXML::SAX::Builder->new() or die "Unable to create XML::LibXML::SAX::Builder: $!";
83
	$self->{OLDHandler} = $self->get_handler();
84
	$self->set_handler($builder);
85
	$self->SUPER::start_document();
86
	$self->SUPER::xml_decl({'Version'=>'1.0','Encoding'=>'UTF-8'});
87
}
88
89
sub end_document {
90
	my ($self) = @_;
91
	$self->SUPER::end_document();
92
	$self->dom($self->get_handler->result());
93
	$self->set_handler($self->{OLDHandler});
94
HTTP::OAI::Debug::sax( ref($self) . " <" . $self->dom->documentElement->nodeName . " />" );
95
}
96
97
1;
98
99
__END__
100
101
=head1 NAME
102
103
HTTP::OAI::Encapsulation - Base class for data objects that contain DOM trees
104
105
=head1 DESCRIPTION
106
107
This class shouldn't be used directly, use L<HTTP::OAI::Metadata>.
108
109
=cut
(-)a/HTTP/OAI/Error.pm (+118 lines)
Line 0 Link Here
1
package HTTP::OAI::Error;
2
3
use strict;
4
use warnings;
5
6
use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAG);
7
8
use vars qw(
9
	$PARSER
10
);
11
12
$PARSER = 600;
13
14
use Exporter;
15
use HTTP::OAI::SAXHandler qw( :SAX );
16
17
@ISA = qw(HTTP::OAI::Encapsulation Exporter);
18
19
@EXPORT = qw();
20
@EXPORT_OK = qw(%OAI_ERRORS);
21
%EXPORT_TAG = ();
22
23
my %OAI_ERRORS = (
24
	badArgument => 'The request includes illegal arguments, is missing required arguments, includes a repeated argument, or values for arguments have an illegal syntax.',
25
#	badGranularity => 'The values of the from and until arguments are illegal or specify a finer granularity than is supported by the repository.',
26
	badResumptionToken => 'The value of the resumptionToken argument is invalid or expired.',
27
	badVerb => 'Value of the verb argument is not a legal OAI-PMH verb, the verb argument is missing, or the verb argument is repeated.',
28
	cannotDisseminateFormat => 'The metadata format identified by the value given for the metadataPrefix argument is not supported by the item or by the repository',
29
	idDoesNotExist => 'The value of the identifier argument is unknown or illegal in this repository.',
30
	noRecordsMatch => 'The combination of the values of the from, until, set, and metadataPrefix arguments results in an empty list.',
31
	noMetadataFormats => 'There are no metadata formats available for the specified item.',
32
	noSetHierarchy => 'The repository does not support sets.'
33
);
34
35
sub new {
36
	my ($class,%args) = @_;
37
	my $self = $class->SUPER::new(%args);
38
39
	$self->code($args{code});
40
	$self->message($args{message});
41
42
	$self;
43
}
44
45
sub code { shift->_elem('code',@_) }
46
sub message { shift->_elem('message',@_) }
47
48
sub toString {
49
	my $self = shift;
50
	return $self->code . " (\"" . ($self->message || 'No further information available') . "\")";
51
}
52
53
sub generate {
54
	my ($self) = @_;
55
	return unless defined(my $handler = $self->get_handler);
56
	Carp::croak ref($self)."::generate Error code undefined" unless defined($self->code);
57
58
	g_data_element($handler,
59
		'http://www.openarchives.org/OAI/2.0/',
60
		'error',
61
		{
62
			'{}code'=>{
63
				'LocalName' => 'code',
64
				'Prefix' => '',
65
				'Value' => $self->code,
66
				'Name' => 'code',
67
				'NamespaceURI' => '',
68
			},
69
		},
70
		($self->message || $OAI_ERRORS{$self->code} || '')
71
	);
72
}
73
74
1;
75
76
__END__
77
78
=head1 NAME
79
80
HTTP::OAI::Error - Encapsulates OAI error codes
81
82
=head1 METHODS
83
84
=over 4
85
86
=item $err = new HTTP::OAI::Error(code=>'badArgument',[message=>'An incorrect argument was supplied'])
87
88
This constructor method returns a new HTTP::OAI::Error object.
89
90
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.
91
92
=item $code = $err->code([$code])
93
94
Returns and optionally sets the error name.
95
96
=item $msg = $err->message([$msg])
97
98
Returns and optionally sets the error message.
99
100
=back
101
102
=head1 NOTE - noRecordsMatch
103
104
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.
105
106
e.g.
107
108
	my $r = $ha->ListIdentifiers(metadataPrefix='oai_dc',from=>'3000-02-02');
109
110
	if( $r->is_success ) {
111
		print "Successful\n";
112
	} else {
113
		print "Failed\n";
114
	}
115
116
	print $r->verb, "\n";
117
118
Will print "Successful" followed by "error".
(-)a/HTTP/OAI/GetRecord.pm (+114 lines)
Line 0 Link Here
1
package HTTP::OAI::GetRecord;
2
3
use strict;
4
use warnings;
5
6
use HTTP::OAI::SAXHandler qw/ :SAX /;
7
8
use vars qw(@ISA);
9
10
@ISA = qw( HTTP::OAI::Response );
11
12
sub new {
13
	my ($class,%args) = @_;
14
15
	$args{handlers} ||= {};
16
	$args{handlers}->{header} ||= "HTTP::OAI::Header";
17
	$args{handlers}->{metadata} ||= "HTTP::OAI::Metadata";
18
	$args{handlers}->{about} ||= "HTTP::OAI::Metadata";
19
20
	my $self = $class->SUPER::new(%args);
21
22
	$self->verb('GetRecord') unless $self->verb;
23
	
24
	$self->{record} ||= [];
25
	$self->record($args{record}) if defined($args{record});
26
27
	return $self;
28
}
29
30
sub record {
31
	my $self = shift;
32
	$self->{record} = [shift] if @_;
33
	return wantarray ?
34
		@{$self->{record}} :
35
		$self->{record}->[0];
36
}
37
sub next { shift @{shift->{record}} }
38
39
sub generate_body {
40
	my ($self) = @_;
41
42
	for( $self->record ) {
43
		$_->set_handler($self->get_handler);
44
		$_->generate;
45
	}
46
}
47
48
sub start_element {
49
	my ($self,$hash) = @_;
50
	my $elem = $hash->{LocalName};
51
	if( $elem eq 'record' && !exists($self->{"in_record"}) ) {
52
		$self->{OLDHandler} = $self->get_handler;
53
		my $rec = HTTP::OAI::Record->new(
54
			version=>$self->version,
55
			handlers=>$self->{handlers},
56
		);
57
		$self->record($rec);
58
		$self->set_handler($rec);
59
		$self->{"in_record"} = $hash->{Depth};
60
	}
61
	$self->SUPER::start_element($hash);
62
}
63
64
sub end_element {
65
	my ($self,$hash) = @_;
66
	$self->SUPER::end_element($hash);
67
	my $elem = lc($hash->{LocalName});
68
	if( $elem eq 'record' &&
69
		exists($self->{"in_record"}) &&
70
		$self->{"in_record"} == $hash->{Depth} ) {
71
		$self->set_handler($self->{OLDHandler});
72
	}
73
}
74
75
1;
76
77
__END__
78
79
=head1 NAME
80
81
HTTP::OAI::GetRecord - An OAI GetRecord response
82
83
=head1 DESCRIPTION
84
85
HTTP::OAI::GetRecord is derived from L<HTTP::OAI::Response|HTTP::OAI::Response> and provides access to the data contained in an OAI GetRecord response in addition to the header information provided by OAI::Response.
86
87
=head1 SYNOPSIS
88
89
	use HTTP::OAI::GetRecord();
90
91
	$res = new HTTP::OAI::GetRecord();
92
	$res->record($rec);
93
94
=head1 METHODS
95
96
=over 4
97
98
=item $gr = new HTTP::OAI::GetRecord
99
100
This constructor method returns a new HTTP::OAI::GetRecord object.
101
102
=item $rec = $gr->next
103
104
Returns the next record stored in the response, or undef if no more record are available. The record is returned as an L<OAI::Record|OAI::Record>.
105
106
=item @recs = $gr->record([$rec])
107
108
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).
109
110
=item $dom = $gr->toDOM()
111
112
Returns an XML::DOM object representing the GetRecord response.
113
114
=back
(-)a/HTTP/OAI/Harvester.pm (+464 lines)
Line 0 Link Here
1
package HTTP::OAI::Harvester;
2
3
use strict;
4
use warnings;
5
6
use vars qw( @ISA );
7
8
@ISA = qw( HTTP::OAI::UserAgent );
9
10
sub new {
11
	my ($class,%args) = @_;
12
	my %ARGS = %args;
13
	delete @ARGS{qw(baseURL resume repository handlers onRecord)};
14
	my $self = $class->SUPER::new(%ARGS);
15
16
	$self->{'resume'} = exists($args{resume}) ? $args{resume} : 1;
17
	$self->{'handlers'} = $args{'handlers'};
18
	$self->{'onRecord'} = $args{'onRecord'};
19
	$self->agent('OAI-PERL/'.$HTTP::OAI::VERSION);
20
21
	# Record the base URL this harvester instance is associated with
22
	$self->{repository} =
23
		$args{repository} ||
24
		HTTP::OAI::Identify->new(baseURL=>$args{baseURL});
25
	Carp::croak "Requires repository or baseURL" unless $self->repository and $self->repository->baseURL;
26
	# Canonicalise
27
	$self->baseURL($self->baseURL);
28
29
	return $self;
30
}
31
32
sub resume {
33
	my $self = shift;
34
	return @_ ? $self->{resume} = shift : $self->{resume};
35
}
36
37
sub repository {
38
	my $self = shift;
39
	return $self->{repository} unless @_;
40
	my $id = shift;
41
	# Don't clobber a good existing base URL with a bad one
42
	if( $self->{repository} && $self->{repository}->baseURL ) {
43
		if( !$id->baseURL ) {
44
			Carp::carp "Attempt to set a non-existant baseURL";
45
			$id->baseURL($self->baseURL);
46
		} else {
47
			my $uri = URI->new($id->baseURL);
48
			if( $uri && $uri->scheme ) {
49
				$id->baseURL($uri->canonical);
50
			} else {
51
				Carp::carp "Ignoring attempt to use an invalid base URL: " . $id->baseURL;
52
				$id->baseURL($self->baseURL);
53
			}
54
		}
55
	}
56
	return $self->{repository} = $id;
57
}
58
59
sub baseURL {
60
	my $self = shift;
61
	return @_ ? 
62
		$self->repository->baseURL(URI->new(shift)->canonical) :
63
		$self->repository->baseURL();
64
}
65
66
sub version { shift->repository->version(@_); }
67
68
# build the methods for each OAI verb
69
foreach my $verb (qw( GetRecord Identify ListIdentifiers ListMetadataFormats ListRecords ListSets ))
70
{
71
	no strict "refs";
72
	*$verb = sub { shift->_oai( verb => $verb, @_ )};
73
}
74
75
sub _oai {
76
	my( $self, %args ) = @_;
77
78
	my $verb = $args{verb} or Carp::croak "Requires verb argument";
79
80
	my $handlers = delete($args{handlers}) || $self->{'handlers'};
81
	my $onRecord = delete($args{onRecord}) || $self->{'onRecord'};
82
83
	if( !$args{force} &&
84
		defined($self->repository->version) &&
85
		'2.0' eq $self->repository->version &&
86
		(my @errors = HTTP::OAI::Repository::validate_request(%args)) ) {
87
		return new HTTP::OAI::Response(
88
			code=>503,
89
			message=>'Invalid Request (use \'force\' to force a non-conformant request): ' . $errors[0]->toString,
90
			errors=>\@errors
91
		);
92
	}
93
94
	delete $args{force};
95
	# Get rid of any empty arguments
96
	for( keys %args ) {
97
		delete $args{$_} if !defined($args{$_}) || !length($args{$_});
98
	}
99
100
	# Check for a static repository (sets _static)
101
	if( !$self->{_interogated} ) {
102
		$self->interogate();
103
		$self->{_interogated} = 1;
104
	}
105
	
106
	if( 'ListIdentifiers' eq $verb &&
107
		defined($self->repository->version) && 
108
		'1.1' eq $self->repository->version ) {
109
		delete $args{metadataPrefix};
110
	}
111
112
	my $r = "HTTP::OAI::$verb"->new(
113
		harvestAgent => $self,
114
		resume => $self->resume,
115
		handlers => $handlers,
116
		onRecord => $onRecord,
117
	);
118
	$r->headers->{_args} = \%args;
119
120
	# Parse all the records if _static set
121
	if( defined($self->{_static}) && !defined($self->{_records}) ) {
122
		my $lmdf = HTTP::OAI::ListMetadataFormats->new(
123
			handlers => $handlers,
124
		);
125
		$lmdf->headers->{_args} = {
126
			%args,
127
			verb=>'ListMetadataFormats',
128
		};
129
		# Find the metadata formats
130
		$lmdf = $lmdf->parse_string($self->{_static});
131
		return $lmdf unless $lmdf->is_success;
132
		@{$self->{_formats}} = $lmdf->metadataFormat;
133
		# Extract all records
134
		$self->{_records} = {};
135
		for($lmdf->metadataFormat) {
136
			my $lr = HTTP::OAI::ListRecords->new(
137
				handlers => $handlers,
138
			);
139
			$lr->headers->{_args} = {
140
				%args,
141
				verb=>'ListRecords',
142
				metadataPrefix=>$_->metadataPrefix,
143
			};
144
			$lr->parse_string($self->{_static});
145
			return $lr if !$lr->is_success;
146
			@{$self->{_records}->{$_->metadataPrefix}} = $lr->record;
147
		}
148
		undef($self->{_static});
149
	}
150
	
151
	# Make the remote request and return the result
152
	if( !defined($self->{_records}) ) {
153
		$r = $self->request({baseURL=>$self->baseURL,%args},undef,undef,undef,$r);
154
		# Lets call next() for the user if she's using the callback interface
155
		if( $onRecord and $r->is_success and $r->isa("HTTP::OAI::PartialList") ) {
156
			$r->next;
157
		}
158
		return $r;
159
	# Parse our memory copy of the static repository
160
	} else {
161
		$r->code(200);
162
		# Format doesn't exist
163
		if( $verb =~ /^GetRecord|ListIdentifiers|ListRecords$/ &&
164
			!exists($self->{_records}->{$args{metadataPrefix}}) ) {
165
			$r->code(600);
166
			$r->errors(HTTP::OAI::Error->new(
167
				code=>'cannotDisseminateFormat',
168
			));
169
		# GetRecord
170
		} elsif( $verb eq 'GetRecord' ) {
171
			for(@{$self->{_records}->{$args{metadataPrefix}}}) {
172
				if( $_->identifier eq $args{identifier} ) {
173
					$r->record($_);
174
					return $r;
175
				}
176
			}
177
			$r->code(600);
178
			$r->errors(HTTP::OAI::Error->new(
179
				code=>'idDoesNotExist'
180
			));
181
		# Identify
182
		} elsif( $verb eq 'Identify' ) {
183
			$r = $self->repository();
184
		# ListIdentifiers
185
		} elsif( $verb eq 'ListIdentifiers' ) {
186
			$r->identifier(map { $_->header } @{$self->{_records}->{$args{metadataPrefix}}})
187
		# ListMetadataFormats
188
		} elsif( $verb eq 'ListMetadataFormats' ) {
189
			$r->metadataFormat(@{$self->{_formats}});
190
		# ListRecords
191
		} elsif( $verb eq 'ListRecords' ) {
192
			$r->record(@{$self->{_records}->{$args{metadataPrefix}}});
193
		# ListSets
194
		} elsif( $verb eq 'ListSets' ) {
195
			$r->errors(HTTP::OAI::Error->new(
196
				code=>'noSetHierarchy',
197
				message=>'Static Repositories do not support sets',
198
			));
199
		}
200
		return $r;
201
	}
202
}
203
204
sub interogate {
205
	my $self = shift;
206
	Carp::croak "Requires baseURL" unless $self->baseURL;
207
	
208
HTTP::OAI::Debug::trace($self->baseURL);
209
	my $r = $self->request(HTTP::Request->new(GET => $self->baseURL));
210
	return unless length($r->content);
211
	my $id = HTTP::OAI::Identify->new(
212
		handlers=>$self->{handlers},
213
	);
214
	$id->headers->{_args} = {verb=>'Identify'};
215
	$id->parse_string($r->content);
216
	if( $id->is_success && $id->version eq '2.0s' ) {
217
		$self->{_static} = $r->content;
218
		$self->repository($id);
219
	}
220
HTTP::OAI::Debug::trace("version = ".$id->version) if $id->is_success;
221
}
222
223
1;
224
225
__END__
226
227
=head1 NAME
228
229
HTTP::OAI::Harvester - Agent for harvesting from Open Archives version 1.0, 1.1, 2.0 and static ('2.0s') compatible repositories
230
231
=head1 DESCRIPTION
232
233
C<HTTP::OAI::Harvester> is the harvesting front-end in the OAI-PERL library.
234
235
To harvest from an OAI-PMH compliant repository create an C<HTTP::OAI::Harvester> 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<must> request C<Identify()> first.
236
237
It is recommended that you request an Identify from the Repository and use the C<repository()> method to update the Identify object used by the harvester.
238
239
When making OAI requests the underlying L<HTTP::OAI::UserAgent> 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<HTTP::OAI::Response>.
240
241
=head2 Static Repository Support
242
243
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.
244
245
	$h = HTTP::OAI::Harvester->new(
246
		repository=>HTTP::OAI::Identify->new(
247
			baseURL => 'http://arXiv.org/oai2',
248
			version => '2.0',
249
	));
250
251
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.
252
253
=head1 FURTHER READING
254
255
You should refer to the Open Archives Protocol version 2.0 and other OAI documentation, available from http://www.openarchives.org/.
256
257
Note OAI-PMH 1.0 and 1.1 are deprecated.
258
259
=head1 BEFORE USING EXAMPLES
260
261
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).
262
263
=head1 SYNOPSIS
264
265
	use HTTP::OAI;
266
267
	my $h = new HTTP::OAI::Harvester(baseURL=>'http://arXiv.org/oai2');
268
	my $response = $h->repository($h->Identify)
269
	if( $response->is_error ) {
270
		print "Error requesting Identify:\n",
271
			$response->code . " " . $response->message, "\n";
272
		exit;
273
	}
274
275
	# Note: repositoryVersion will always be 2.0, $r->version returns
276
	# the actual version the repository is running
277
	print "Repository supports protocol version ", $response->version, "\n";
278
279
	# Version 1.x repositories don't support metadataPrefix,
280
	# but OAI-PERL will drop the prefix automatically
281
	# if an Identify was requested first (as above)
282
	$response = $h->ListIdentifiers(
283
		metadataPrefix=>'oai_dc',
284
		from=>'2001-02-03',
285
		until=>'2001-04-10'
286
	);
287
288
	if( $response->is_error ) {
289
		die("Error harvesting: " . $response->message . "\n");
290
	}
291
292
	print "responseDate => ", $response->responseDate, "\n",
293
		"requestURL => ", $response->requestURL, "\n";
294
295
	while( my $id = $response->next ) {
296
		print "identifier => ", $id->identifier;
297
		# Only available from OAI 2.0 repositories
298
		print " (", $id->datestamp, ")" if $id->datestamp;
299
		print " (", $id->status, ")" if $id->status;
300
		print "\n";
301
		# Only available from OAI 2.0 repositories
302
		for( $id->setSpec ) {
303
			print "\t", $_, "\n";
304
		}
305
	}
306
307
	# Using a handler
308
	$response = $h->ListRecords(
309
		metadataPrefix=>'oai_dc',
310
		handlers=>{metadata=>'HTTP::OAI::Metadata::OAI_DC'},
311
	);
312
	while( my $rec = $response->next ) {
313
		print $rec->identifier, "\t",
314
			$rec->datestamp, "\n",
315
			$rec->metadata, "\n";
316
		print join(',', @{$rec->metadata->dc->{'title'}}), "\n";
317
	}
318
	if( $rec->is_error ) {
319
		die $response->message;
320
	}
321
322
	# Offline parsing
323
	$I = HTTP::OAI::Identify->new();
324
	$I->parse_string($content);
325
	$I->parse_file($fh);
326
327
=head1 METHODS
328
329
=over 4
330
331
=item HTTP::OAI::Harvester->new( %params )
332
333
This constructor method returns a new instance of C<HTTP::OAI::Harvester>. Requires either an L<HTTP::OAI::Identify> object, which in turn must contain a baseURL, or a baseURL from which to construct an Identify object.
334
335
Any other parameters are passed to the L<HTTP::OAI::UserAgent> module, and from there to the L<LWP::UserAgent> module.
336
337
	$h = HTTP::OAI::Harvester->new(
338
		baseURL	=>	'http://arXiv.org/oai2',
339
		resume=>0, # Suppress automatic resumption
340
	)
341
	$id = $h->repository();
342
	$h->repository($h->Identify);
343
344
	$h = HTTP::OAI::Harvester->new(
345
		HTTP::OAI::Identify->new(
346
			baseURL => 'http://arXiv.org/oai2',
347
	));
348
349
=item $h->repository()
350
351
Returns and optionally sets the L<HTTP::OAI::Identify> object used by the Harvester agent.
352
353
=item $h->resume( [1] )
354
355
If set to true (default) resumption tokens will automatically be handled by requesting the next partial list during C<next()> calls.
356
357
=back
358
359
=head1 OAI-PMH Verbs
360
361
The 6 OAI-PMH Verbs are the requests supported by an OAI-PMH interface.
362
363
=head2 Error Messages
364
365
Use C<is_success()> or C<is_error()> on the returned object to determine whether an error occurred (see L<HTTP::OAI::Response>).
366
367
C<code()> and C<message()> return the error code (200 is success) and a human-readable message respectively. L<Errors|HTTP::OAI::Error> returned by the repository can be retrieved using the C<errors()> method:
368
369
	foreach my $error ($r->errors) {
370
		print $error->code, "\t", $error->message, "\n";
371
	}
372
373
Note: C<is_success()> is true for the OAI Error Code C<noRecordsMatch> (i.e. empty set), although C<errors()> will still contain the OAI error.
374
375
=head2 Flow Control
376
377
If the response contained a L<resumption token|HTTP::OAI::ResumptionToken> this can be retrieved using the $r->resumptionToken method.
378
379
=head2 Methods
380
381
These methods return an object subclassed from L<HTTP::Response> (where the class corresponds to the verb requested, e.g. C<GetRecord> requests return an C<HTTP::OAI::GetRecord> object).
382
383
=over 4
384
385
=item $r = $h->GetRecord( %params )
386
387
Get a single record from the repository identified by identifier, in format metadataPrefix.
388
389
	$gr = $h->GetRecord(
390
		identifier	=>	'oai:arXiv:hep-th/0001001', # Required
391
		metadataPrefix	=>	'oai_dc' # Required
392
	);
393
	$rec = $gr->next;
394
	die $rec->message if $rec->is_error;
395
	printf("%s (%s)\n", $rec->identifier, $rec->datestamp);
396
	$dom = $rec->metadata->dom;
397
398
=item $r = $h->Identify()
399
400
Get information about the repository.
401
402
	$id = $h->Identify();
403
	print join ',', $id->adminEmail;
404
405
=item $r = $h->ListIdentifiers( %params )
406
407
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.
408
409
	$lr = $h->ListIdentifiers(
410
		metadataPrefix	=>	'oai_dc', # Required
411
		from		=>		'2001-10-01',
412
		until		=>		'2001-10-31',
413
		set=>'physics:hep-th',
414
	);
415
	while($rec = $lr->next)
416
	{
417
		{ ... do something with $rec ... }
418
	}
419
	die $lr->message if $lr->is_error;
420
421
=item $r = $h->ListMetadataFormats( %params )
422
423
List available metadata formats. Given an identifier the repository should only return those metadata formats for which that item can be disseminated.
424
425
	$lmdf = $h->ListMetadataFormats(
426
		identifier => 'oai:arXiv.org:hep-th/0001001'
427
	);
428
	for($lmdf->metadataFormat) {
429
		print $_->metadataPrefix, "\n";
430
	}
431
	die $lmdf->message if $lmdf->is_error;
432
433
=item $r = $h->ListRecords( %params )
434
435
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.
436
437
	$lr = $h->ListRecords(
438
		metadataPrefix=>'oai_dc', # Required
439
		from	=>	'2001-10-01',
440
		until	=>	'2001-10-01',
441
		set		=>	'physics:hep-th',
442
	);
443
	while($rec = $lr->next)
444
	{
445
		{ ... do something with $rec ... }
446
	}
447
	die $lr->message if $lr->is_error;
448
449
=item $r = $h->ListSets( %params )
450
451
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.
452
453
	$ls = $h->ListSets();
454
	while($set = $ls->next)
455
	{
456
		print $set->setSpec, "\n";
457
	}
458
	die $ls->message if $ls->is_error;
459
460
=back
461
462
=head1 AUTHOR
463
464
These modules have been written by Tim Brody E<lt>tdb01r@ecs.soton.ac.ukE<gt>.
(-)a/HTTP/OAI/Header.pm (+166 lines)
Line 0 Link Here
1
package HTTP::OAI::Header;
2
3
use strict;
4
use warnings;
5
6
use POSIX qw/strftime/;
7
8
use vars qw(@ISA);
9
10
use HTTP::OAI::SAXHandler qw( :SAX );
11
12
@ISA = qw(HTTP::OAI::Encapsulation);
13
14
sub new {
15
	my ($class,%args) = @_;
16
	my $self = $class->SUPER::new(%args);
17
18
	$self->identifier($args{identifier}) unless $self->identifier;
19
	$self->datestamp($args{datestamp}) unless $self->datestamp;
20
	$self->status($args{status}) unless $self->status;
21
	$self->{setSpec} ||= $args{setSpec} || [];
22
23
	$self;
24
}
25
26
sub identifier { shift->_elem('identifier',@_) }
27
sub now { return strftime("%Y-%m-%dT%H:%M:%SZ",gmtime()) }
28
sub datestamp {
29
	my $self = shift;
30
	return $self->_elem('datestamp') unless @_;
31
	my $ds = shift or return $self->_elem('datestamp',undef);
32
	if( $ds =~ /^(\d{4})(\d{2})(\d{2})$/ ) {
33
		$ds = "$1-$2-$3";
34
	} elsif( $ds =~ /^(\d{4})(\d{2})(\d{2})(\d{2})(\d{2})(\d{2})$/ ) {
35
		$ds = "$1-$2-$3T$4:$5:$6Z";
36
	}
37
	return $self->_elem('datestamp',$ds);
38
}
39
sub status { shift->_attr('status',@_) }
40
sub is_deleted { my $s = shift->status(); return defined($s) && $s eq 'deleted'; }
41
42
sub setSpec {
43
	my $self = shift;
44
	push(@{$self->{setSpec}},@_);
45
	@{$self->{setSpec}};
46
}
47
48
sub dom {
49
	my $self = shift;
50
	if( my $dom = shift ) {
51
		my $driver = XML::LibXML::SAX::Parser->new(
52
			Handler=>HTTP::OAI::SAXHandler->new(
53
				Handler=>$self
54
		));
55
		$driver->generate($dom->ownerDocument);
56
	} else {
57
		$self->set_handler(my $builder = XML::LibXML::SAX::Builder->new());
58
		g_start_document($self);
59
		$self->xml_decl({'Version'=>'1.0','Encoding'=>'UTF-8'});
60
		$self->characters({'Data'=>"\n"});
61
		$self->generate();
62
		$self->end_document();
63
		return $builder->result;
64
	}
65
}
66
67
sub generate {
68
	my ($self) = @_;
69
	return unless defined(my $handler = $self->get_handler);
70
71
	if( defined($self->status) ) {
72
		g_start_element($handler,'http://www.openarchives.org/OAI/2.0/','header',
73
			{
74
				"{}status"=>{
75
					'Name'=>'status',
76
					'LocalName'=>'status',
77
					'Value'=>$self->status,
78
					'Prefix'=>'',
79
					'NamespaceURI'=>''
80
				}
81
			});
82
	} else {
83
		g_start_element($handler,'http://www.openarchives.org/OAI/2.0/','header',{});
84
	}
85
	g_data_element($handler,'http://www.openarchives.org/OAI/2.0/','identifier',{},$self->identifier);
86
	g_data_element($handler,'http://www.openarchives.org/OAI/2.0/','datestamp',{},($self->datestamp || $self->now));
87
	for($self->setSpec) {
88
		g_data_element($handler,'http://www.openarchives.org/OAI/2.0/','setSpec',{},$_);
89
	}
90
	g_end_element($handler,'http://www.openarchives.org/OAI/2.0/','header');
91
}
92
93
sub end_element {
94
	my ($self,$hash) = @_;
95
	my $elem = lc($hash->{LocalName});
96
	my $text = $hash->{Text};
97
	if( defined $text )
98
	{
99
		$text =~ s/^\s+//;
100
		$text =~ s/\s+$//;
101
	}
102
	if( $elem eq 'identifier' ) {
103
		die "HTTP::OAI::Header parse error: Empty identifier\n" unless $text;
104
		$self->identifier($text);
105
	} elsif( $elem eq 'datestamp' ) {
106
		warn "HTTP::OAI::Header parse warning: Empty datestamp for ".$self->identifier."\n" unless $text;
107
		$self->datestamp($text);
108
	} elsif( $elem eq 'setspec' ) {
109
		$self->setSpec($text);
110
	} elsif( $elem eq 'header' ) {
111
		$self->status($hash->{Attributes}->{'{}status'}->{Value});
112
	}
113
}
114
115
1;
116
117
__END__
118
119
=head1 NAME
120
121
HTTP::OAI::Header - Encapsulates an OAI header structure
122
123
=head1 SYNOPSIS
124
125
	use HTTP::OAI::Header;
126
127
	my $h = new HTTP::OAI::Header(
128
		identifier=>'oai:myarchive.org:2233-add',
129
		datestamp=>'2002-04-12T20:31:00Z',
130
	);
131
132
	$h->setSpec('all:novels');
133
134
=head1 METHODS
135
136
=over 4
137
138
=item $h = new HTTP::OAI::Header
139
140
This constructor method returns a new C<HTTP::OAI::Header object>.
141
142
=item $h->identifier([$identifier])
143
144
Get and optionally set the record OAI identifier.
145
146
=item $h->datestamp([$datestamp])
147
148
Get and optionally set the record datestamp (OAI 2.0+).
149
150
=item $h->status([$status])
151
152
Get and optionally set the record status (valid values are 'deleted' or undef).
153
154
=item $h->is_deleted()
155
156
Returns whether this record's status is deleted.
157
158
=item @sets = $h->setSpec([$setSpec])
159
160
Returns the list of setSpecs and optionally appends a new setSpec C<$setSpec> (OAI 2.0+).
161
162
=item $dom_fragment = $id->generate()
163
164
Act as a SAX driver (use C<< $h->set_handler() >> to specify the filter to pass events to).
165
166
=back
(-)a/HTTP/OAI/Headers.pm (+249 lines)
Line 0 Link Here
1
package HTTP::OAI::Headers;
2
3
use strict;
4
use warnings;
5
6
use HTTP::OAI::SAXHandler qw( :SAX );
7
8
use vars qw( @ISA );
9
10
@ISA = qw( XML::SAX::Base );
11
12
my %VERSIONS = (
13
	'http://www.openarchives.org/oai/1.0/oai_getrecord' => '1.0',
14
	'http://www.openarchives.org/oai/1.0/oai_identify' => '1.0',
15
	'http://www.openarchives.org/oai/1.0/oai_listidentifiers' => '1.0',
16
	'http://www.openarchives.org/oai/1.0/oai_listmetadataformats' => '1.0',
17
	'http://www.openarchives.org/oai/1.0/oai_listrecords' => '1.0',
18
	'http://www.openarchives.org/oai/1.0/oai_listsets' => '1.0',
19
	'http://www.openarchives.org/oai/1.1/oai_getrecord' => '1.1',
20
	'http://www.openarchives.org/oai/1.1/oai_identify' => '1.1',
21
	'http://www.openarchives.org/oai/1.1/oai_listidentifiers' => '1.1',
22
	'http://www.openarchives.org/oai/1.1/oai_listmetadataformats' => '1.1',
23
	'http://www.openarchives.org/oai/1.1/oai_listrecords' => '1.1',
24
	'http://www.openarchives.org/oai/1.1/oai_listsets' => '1.1',
25
	'http://www.openarchives.org/oai/2.0/' => '2.0',
26
	'http://www.openarchives.org/oai/2.0/static-repository' => '2.0s',
27
);
28
29
sub new {
30
	my ($class,%args) = @_;
31
	my $self = bless {
32
		'field'=>{
33
			'xmlns'=>'http://www.openarchives.org/OAI/2.0/',
34
			'xmlns:xsi'=>'http://www.w3.org/2001/XMLSchema-instance',
35
			'xsi:schemaLocation'=>'http://www.openarchives.org/OAI/2.0/ http://www.openarchives.org/OAI/2.0/OAI-PMH.xsd'
36
		},
37
		%args,
38
	}, ref($class) || $class;
39
	return $self;
40
}
41
42
sub set_error
43
{
44
	my ($self,$error,$code) = @_;
45
	$code ||= 600;
46
47
	if( $self->get_handler ) {
48
		$self->get_handler->errors($error);
49
		$self->get_handler->code($code);
50
	} else {
51
		Carp::carp ref($self)." tried to set_error without having a handler to set it on!";
52
	}
53
}
54
sub generate_start {
55
	my ($self) = @_;
56
	return unless defined(my $handler = $self->get_handler);
57
58
	$handler->start_prefix_mapping({
59
			'Prefix'=>'xsi',
60
			'NamespaceURI'=>'http://www.w3.org/2001/XMLSchema-instance'
61
		});
62
	$handler->start_prefix_mapping({
63
			'Prefix'=>'',
64
			'NamespaceURI'=>'http://www.openarchives.org/OAI/2.0/'
65
		});
66
	g_start_element($handler,
67
		'http://www.openarchives.org/OAI/2.0/',
68
		'OAI-PMH',
69
			{
70
				'{http://www.w3.org/2001/XMLSchema-instance}schemaLocation'=>{
71
					'LocalName' => 'schemaLocation',
72
					'Prefix' => 'xsi',
73
					'Value' => 'http://www.openarchives.org/OAI/2.0/ http://www.openarchives.org/OAI/2.0/OAI-PMH.xsd',
74
					'Name' => 'xsi:schemaLocation',
75
					'NamespaceURI' => 'http://www.w3.org/2001/XMLSchema-instance',
76
				},
77
				'{}xmlns' => {
78
					'Prefix' => '',
79
					'LocalName' => 'xmlns',
80
					'Value' => 'http://www.openarchives.org/OAI/2.0/',
81
					'Name' => 'xmlns',
82
					'NamespaceURI' => '',
83
				},
84
				'{http://www.w3.org/2000/xmlns/}xsi'=>{
85
					'LocalName' => 'xsi',
86
					'Prefix' => 'xmlns',
87
					'Value' => 'http://www.w3.org/2001/XMLSchema-instance',
88
					'Name' => 'xmlns:xsi',
89
					'NamespaceURI' => 'http://www.w3.org/2000/xmlns/',
90
				},
91
			});
92
93
	g_data_element($handler,
94
		'http://www.openarchives.org/OAI/2.0/',
95
		'responseDate',
96
		{},
97
		$self->header('responseDate')
98
	);
99
	
100
	my $uri = URI->new($self->header('requestURL'));
101
	my $attr;
102
	my %QUERY = $uri->query_form;
103
	while(my ($key,$value) = each %QUERY) {
104
		$attr->{"{}$key"} = {
105
			'Name'=>$key,
106
			'LocalName'=>$key,
107
			'Value'=>$value,
108
			'Prefix'=>'',
109
			'NamespaceURI'=>'',
110
		};
111
	}
112
	$uri->query( undef );
113
	g_data_element($handler,
114
		'http://www.openarchives.org/OAI/2.0/',
115
		'request',
116
		$attr,
117
		$uri->as_string
118
	);
119
}
120
121
sub generate_end {
122
	my ($self) = @_;
123
	return unless defined(my $handler = $self->get_handler);
124
125
	g_end_element($handler,
126
		'http://www.openarchives.org/OAI/2.0/',
127
		'OAI-PMH'
128
	);
129
130
	$handler->end_prefix_mapping({
131
			'Prefix'=>'xsi',
132
			'NamespaceURI'=>'http://www.w3.org/2001/XMLSchema-instance'
133
		});
134
	$handler->end_prefix_mapping({
135
			'Prefix'=>'',
136
			'NamespaceURI'=>'http://www.openarchives.org/OAI/2.0/'
137
		});
138
}
139
140
sub header {
141
	my $self = shift;
142
	return @_ > 1 ? $self->{field}->{$_[0]} = $_[1] : $self->{field}->{$_[0]};
143
}
144
145
sub end_document {
146
	my $self = shift;
147
	$self->set_handler(undef);
148
	unless( defined($self->header('version')) ) {
149
		die "Not an OAI-PMH response: No recognised OAI-PMH namespace found before end of document\n";
150
	}
151
}
152
153
sub start_element {
154
	my ($self,$hash) = @_;
155
	return $self->SUPER::start_element($hash) if $self->{State};
156
	my $elem = $hash->{LocalName};
157
	my $attr = $hash->{Attributes};
158
159
	# Root element
160
	unless( defined($self->header('version')) ) {
161
		my $xmlns = $hash->{NamespaceURI};
162
		if( !defined($xmlns) || !length($xmlns) )
163
		{
164
			die "Error parsing response: no namespace on root element";
165
		}
166
		elsif( !exists $VERSIONS{lc($xmlns)} )
167
		{
168
			die "Error parsing response: unrecognised OAI namespace '$xmlns'";
169
		}
170
		else
171
		{
172
			$self->header('version',$VERSIONS{lc($xmlns)})
173
		}
174
	}
175
	# With a static repository, don't process any headers
176
	if( $self->header('version') && $self->header('version') eq '2.0s' ) {
177
		my %args = %{$self->{_args}};
178
		# ListRecords and the correct prefix
179
		if( $elem eq 'ListRecords' &&
180
			$elem eq $args{'verb'} && 
181
			$attr->{'{}metadataPrefix'}->{'Value'} eq $args{'metadataPrefix'} ) {
182
			$self->{State} = 1;
183
		# Start of the verb we're looking for
184
		} elsif(
185
			$elem ne 'ListRecords' && 
186
			$elem eq $args{'verb'}
187
		) {
188
			$self->{State} = 1;
189
		}
190
	} else {
191
		$self->{State} = 1;
192
	}
193
}
194
195
sub end_element {
196
	my ($self,$hash) = @_;
197
	my $elem = $hash->{LocalName};
198
	my $attr = $hash->{Attributes};
199
	my $text = $hash->{Text};
200
	# Static repository, don't process any headers
201
	if( $self->header('version') && $self->header('version') eq '2.0s' ) {
202
		# Stop parsing when we get to the closing verb
203
		if( $self->{State} &&
204
			$elem eq $self->{_args}->{'verb'} &&
205
			$hash->{NamespaceURI} eq 'http://www.openarchives.org/OAI/2.0/static-repository'
206
		) {
207
			$self->{State} = 0;
208
			die "done\n\n";
209
		}
210
		return $self->{State} ?
211
			$self->SUPER::end_element($hash) :
212
			undef;
213
	}
214
	$self->SUPER::end_element($hash);
215
	if( $elem eq 'responseDate' || $elem eq 'requestURL' ) {
216
		$self->header($elem,$text);
217
	} elsif( $elem eq 'request' ) {
218
		$self->header("request",$text);
219
		my $uri = new URI($text);
220
		$uri->query_form(map { ($_->{LocalName},$_->{Value}) } values %$attr);
221
		$self->header("requestURL",$uri);
222
	} else {
223
		die "Still in headers, but came across an unrecognised element: $elem";
224
	}
225
	if( $elem eq 'requestURL' || $elem eq 'request' ) {
226
		die "Oops! Root handler isn't \$self - $self != $hash->{State}"
227
			unless ref($self) eq ref($hash->{State}->get_handler);
228
		$hash->{State}->set_handler($self->get_handler);
229
	}
230
	return 1;
231
}
232
233
1;
234
235
__END__
236
237
=head1 NAME
238
239
HTTP::OAI::Headers - Encapsulation of 'header' values
240
241
=head1 METHODS
242
243
=over 4
244
245
=item $value = $hdrs->header($name,[$value])
246
247
Return and optionally set the header field $name to $value.
248
249
=back
(-)a/HTTP/OAI/Identify.pm (+194 lines)
Line 0 Link Here
1
package HTTP::OAI::Identify;
2
3
use strict;
4
use warnings;
5
6
use HTTP::OAI::SAXHandler qw( :SAX );
7
8
use vars qw( @ISA );
9
@ISA = qw( HTTP::OAI::Response );
10
11
sub new {
12
	my ($class,%args) = @_;
13
	delete $args{'harvestAgent'}; # Otherwise we get a memory cycle with $h->repository($id)!
14
	for(qw( adminEmail compression description )) {
15
		$args{$_} ||= [];
16
	}
17
	$args{handlers}->{description} ||= "HTTP::OAI::Metadata";
18
	my $self = $class->SUPER::new(%args);
19
20
	$self->verb('Identify') unless $self->verb;
21
	$self->baseURL($args{baseURL}) unless $self->baseURL;
22
	$self->adminEmail($args{adminEmail}) if !ref($args{adminEmail}) && !$self->adminEmail;
23
	$self->protocolVersion($args{protocolVersion} || '2.0') unless $self->protocolVersion;
24
	$self->repositoryName($args{repositoryName}) unless $self->repositoryName;
25
	$self->earliestDatestamp($args{earliestDatestamp}) unless $self->earliestDatestamp;
26
	$self->deletedRecord($args{deletedRecord}) unless $self->deletedRecord;
27
	$self->granularity($args{granularity}) unless $self->granularity;
28
29
	$self;
30
}
31
32
sub adminEmail {
33
	my $self = shift;
34
	push @{$self->{adminEmail}}, @_;
35
	return wantarray ?
36
		@{$self->{adminEmail}} :
37
		$self->{adminEmail}->[0]
38
}
39
sub baseURL { shift->headers->header('baseURL',@_) }
40
sub compression {
41
	my $self = shift;
42
	push @{$self->{compression}}, @_;
43
	return wantarray ?
44
		@{$self->{compression}} :
45
		$self->{compression}->[0];
46
}
47
sub deletedRecord { return shift->headers->header('deletedRecord',@_) }
48
sub description {
49
	my $self = shift;
50
	push(@{$self->{description}}, @_);
51
	return wantarray ?
52
		@{$self->{description}} :
53
		$self->{description}->[0];
54
};
55
sub earliestDatestamp { return shift->headers->header('earliestDatestamp',@_) }
56
sub granularity { return shift->headers->header('granularity',@_) }
57
sub protocolVersion { return shift->headers->header('protocolVersion',@_) };
58
sub repositoryName { return shift->headers->header('repositoryName',@_) };
59
60
sub next {
61
	my $self = shift;
62
	return shift @{$self->{description}};
63
}
64
65
sub generate_body {
66
	my ($self) = @_;
67
	return unless defined(my $handler = $self->get_handler);
68
69
	g_data_element($handler,'http://www.openarchives.org/OAI/2.0/','repositoryName',{},$self->repositoryName);
70
	g_data_element($handler,'http://www.openarchives.org/OAI/2.0/','baseURL',{},"".$self->baseURL);
71
	g_data_element($handler,'http://www.openarchives.org/OAI/2.0/','protocolVersion',{},$self->protocolVersion);
72
	g_data_element($handler,'http://www.openarchives.org/OAI/2.0/','adminEmail',{},$_) for $self->adminEmail;
73
	g_data_element($handler,'http://www.openarchives.org/OAI/2.0/','earliestDatestamp',{},$self->earliestDatestamp||'0001-01-01');
74
	g_data_element($handler,'http://www.openarchives.org/OAI/2.0/','deletedRecord',{},$self->deletedRecord||'no');
75
	g_data_element($handler,'http://www.openarchives.org/OAI/2.0/','granularity',{},$self->granularity) if defined($self->granularity);
76
	g_data_element($handler,'http://www.openarchives.org/OAI/2.0/','compression',{},$_) for $self->compression;
77
78
	for($self->description) {
79
		g_data_element($handler,'http://www.openarchives.org/OAI/2.0/','description',{},$_);
80
	}
81
}
82
83
sub start_element {
84
	my ($self,$hash) = @_;
85
	my $elem = lc($hash->{LocalName});
86
	$self->SUPER::start_element($hash);
87
	if( $elem eq 'description' && !$self->{"in_$elem"} ) {
88
		$self->{OLDHandler} = $self->get_handler();
89
		$self->set_handler(my $handler = $self->{handlers}->{$elem}->new());
90
		$self->description($handler);
91
		$self->{"in_$elem"} = $hash->{Depth};
92
		g_start_document($handler);
93
	}
94
}
95
96
sub end_element {
97
	my ($self,$hash) = @_;
98
	my $elem = $hash->{LocalName};
99
	my $text = $hash->{Text};
100
	if( defined $text )
101
	{
102
		$text =~ s/^\s+//;
103
		$text =~ s/\s+$//;
104
	}
105
	if( defined($self->get_handler) ) {
106
		if( $elem eq 'description' && $self->{"in_$elem"} == $hash->{Depth} ) {
107
			$self->SUPER::end_document();
108
			$self->set_handler($self->{OLDHandler});
109
			$self->{"in_$elem"} = undef;
110
		}
111
	} elsif( $elem eq 'adminEmail' ) {
112
		$self->adminEmail($text);
113
	} elsif( $elem eq 'compression' ) {
114
		$self->compression($text);
115
	} elsif( $elem eq 'baseURL' ) {
116
		$self->baseURL($text);
117
	} elsif( $elem eq 'protocolVersion' ) {
118
		$text = '2.0' if $text =~ /\D/ or $text < 2.0;
119
		$self->protocolVersion($text);
120
	} elsif( defined($text) && length($text) ) {
121
		$self->headers->header($elem,$text);
122
	}
123
	$self->SUPER::end_element($hash);
124
}
125
126
1;
127
128
__END__
129
130
=head1 NAME
131
132
HTTP::OAI::Identify - Provide access to an OAI Identify response
133
134
=head1 SYNOPSIS
135
136
	use HTTP::OAI::Identify;
137
138
	my $i = new HTTP::OAI::Identify(
139
		adminEmail=>'billg@microsoft.com',
140
		baseURL=>'http://www.myarchives.org/oai',
141
		repositoryName=>'www.myarchives.org'
142
	);
143
144
	for( $i->adminEmail ) {
145
		print $_, "\n";
146
	}
147
148
=head1 METHODS
149
150
=over 4
151
152
=item $i = new HTTP::OAI::Identify(-baseURL=>'http://arXiv.org/oai1'[, adminEmail=>$email, protocolVersion=>'2.0', repositoryName=>'myarchive'])
153
154
This constructor method returns a new instance of the OAI::Identify module.
155
156
=item $i->version
157
158
Return the original version of the OAI response, according to the given XML namespace.
159
160
=item $i->headers
161
162
Returns an HTTP::OAI::Headers object. Use $headers->header('headername') to retrive field values.
163
164
=item $burl = $i->baseURL([$burl])
165
166
=item $eds = $i->earliestDatestamp([$eds])
167
168
=item $gran = $i->granularity([$gran])
169
170
=item $version = $i->protocolVersion($version)
171
172
=item $name = $i->repositoryName($name)
173
174
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.
175
176
=item @addys = $i->adminEmail([$email])
177
178
=item @cmps = $i->compression([$cmp])
179
180
Returns and optionally adds to the multi-value headers.
181
182
=item @dl = $i->description([$d])
183
184
Returns the description list and optionally appends a new description $d. Returns an array ref of L<HTTP::OAI::Description|HTTP::OAI::Description>s, or an empty ref if there are no description.
185
186
=item $d = $i->next
187
188
Returns the next description or undef if no more description left.
189
190
=item $dom = $i->toDOM
191
192
Returns a XML::DOM object representing the Identify response.
193
194
=back
(-)a/HTTP/OAI/ListIdentifiers.pm (+118 lines)
Line 0 Link Here
1
package HTTP::OAI::ListIdentifiers;
2
3
use strict;
4
use warnings;
5
6
use vars qw( @ISA );
7
@ISA = qw( HTTP::OAI::PartialList );
8
9
sub new {
10
	my $class = shift;
11
	my %args = @_;
12
	
13
	my $self = $class->SUPER::new(@_);
14
15
	$self->{in_record} = 0;
16
17
	$self;
18
}
19
20
sub identifier { shift->item(@_) }
21
22
sub generate_body {
23
	my ($self) = @_;
24
	return unless defined(my $handler = $self->get_handler);
25
26
	for($self->identifier) {
27
		$_->set_handler($handler);
28
		$_->generate;
29
	}
30
	if( defined($self->resumptionToken) ) {
31
		$self->resumptionToken->set_handler($handler);
32
		$self->resumptionToken->generate;
33
	}
34
}
35
36
sub start_element {
37
	my ($self,$hash) = @_;
38
	my $elem = lc($hash->{LocalName});
39
	if( $elem eq 'header' ) {
40
		$self->set_handler(new HTTP::OAI::Header(
41
			version=>$self->version
42
		));
43
	} elsif( $elem eq 'resumptiontoken' ) {
44
		$self->set_handler(new HTTP::OAI::ResumptionToken(
45
			version=>$self->version
46
		));
47
	}
48
	$self->SUPER::start_element($hash);
49
}
50
51
sub end_element {
52
	my ($self,$hash) = @_;
53
	my $elem = lc($hash->{LocalName});
54
	$self->SUPER::end_element($hash);
55
	if( $elem eq 'header' ) {
56
		$self->identifier( $self->get_handler );
57
		$self->set_handler( undef );
58
	} elsif( $elem eq 'resumptiontoken' ) {
59
		$self->resumptionToken( $self->get_handler );
60
		$self->set_handler( undef );
61
	}
62
	# OAI 1.x
63
	if( $self->version eq '1.1' && $elem eq 'identifier' ) {
64
		$self->identifier(new HTTP::OAI::Header(
65
			version=>$self->version,
66
			identifier=>$hash->{Text},
67
			datestamp=>'0000-00-00',
68
		));
69
	}
70
}
71
72
1;
73
74
__END__
75
76
=head1 NAME
77
78
HTTP::OAI::ListIdentifiers - Provide access to an OAI ListIdentifiers response
79
80
=head1 SYNOPSIS
81
82
	my $r = $h->ListIdentifiers;
83
84
	while(my $rec = $r->next) {
85
		print "identifier => ", $rec->identifier, "\n",
86
		print "datestamp => ", $rec->datestamp, "\n" if $rec->datestamp;
87
		print "status => ", ($rec->status || 'undef'), "\n";
88
	}
89
	
90
	die $r->message if $r->is_error;
91
92
=head1 METHODS
93
94
=over 4
95
96
=item $li = new OAI::ListIdentifiers
97
98
This constructor method returns a new OAI::ListIdentifiers object.
99
100
=item $rec = $li->next
101
102
Returns either an L<HTTP::OAI::Header|HTTP::OAI::Header> 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).
103
104
If -resume was set to false in the Harvest Agent, next may return a string (the resumptionToken).
105
106
=item @il = $li->identifier([$idobj])
107
108
Returns the identifier list and optionally adds an identifier or resumptionToken, $idobj. Returns an array ref of L<HTTP::OAI::Header|HTTP::OAI::Header>s.
109
110
=item $dom = $li->toDOM
111
112
Returns a XML::DOM object representing the ListIdentifiers response.
113
114
=item $token = $li->resumptionToken([$token])
115
116
Returns and optionally sets the L<HTTP::OAI::ResumptionToken|HTTP::OAI::ResumptionToken>.
117
118
=back
(-)a/HTTP/OAI/ListMetadataFormats.pm (+103 lines)
Line 0 Link Here
1
package HTTP::OAI::ListMetadataFormats;
2
3
use strict;
4
use warnings;
5
6
use vars qw( @ISA );
7
8
@ISA = qw( HTTP::OAI::Response );
9
10
sub new {
11
	my $class = shift;
12
	my $self = $class->SUPER::new(@_);
13
	$self->{'metadataFormat'} ||= [];
14
	$self->{in_mdf} = 0;
15
	$self->verb('ListMetadataFormats') unless $self->verb;
16
17
	$self;
18
}
19
20
sub metadataFormat {
21
	my $self = shift;
22
	push(@{$self->{metadataformat}}, @_);
23
	return wantarray ?
24
		@{$self->{metadataformat}} :
25
		$self->{metadataformat}->[0];
26
}
27
28
sub next { shift @{shift->{metadataformat}} }
29
30
sub generate_body {
31
	my ($self) = @_;
32
	return unless defined(my $handler = $self->get_handler);
33
34
	for( $self->metadataFormat ) {
35
		$_->set_handler($handler);
36
		$_->generate;
37
	}
38
}
39
40
sub start_element {
41
	my ($self,$hash) = @_;
42
	if( !$self->{'in_mdf'} ) {
43
		if( lc($hash->{LocalName}) eq 'metadataformat' ) {
44
			$self->set_handler(new HTTP::OAI::MetadataFormat());
45
			$self->{'in_mdf'} = $hash->{Depth};
46
		}
47
	}
48
	$self->SUPER::start_element($hash);
49
}
50
51
sub end_element {
52
	my ($self,$hash) = @_;
53
	$self->SUPER::end_element($hash);
54
	if( $self->{'in_mdf'} == $hash->{Depth} ) {
55
		if( lc($hash->{LocalName}) eq 'metadataformat' ) {
56
HTTP::OAI::Debug::trace( "metadataFormat: " . $self->get_handler->metadataPrefix );
57
			$self->metadataFormat( $self->get_handler );
58
			$self->set_handler( undef );
59
			$self->{'in_mdf'} = 0;
60
		}
61
	}
62
}
63
64
1;
65
66
__END__
67
68
=head1 NAME
69
70
HTTP::OAI::ListMetadataFormats - Provide access to an OAI ListMetadataFormats response
71
72
=head1 SYNOPSIS
73
74
	my $r = $h->ListMetadataFormats;
75
76
	# ListMetadataFormats doesn't use flow control
77
	while( my $rec = $r->next ) {
78
		print $rec->metadataPrefix, "\n";
79
	}
80
81
	die $r->message if $r->is_error;
82
83
=head1 METHODS
84
85
=over 4
86
87
=item $lmdf = new HTTP::OAI::ListMetadataFormats
88
89
This constructor method returns a new HTTP::OAI::ListMetadataFormats object.
90
91
=item $mdf = $lmdf->next
92
93
Returns either an L<HTTP::OAI::MetadataFormat|HTTP::OAI::MetadataFormat> object, or undef, if no more records are available.
94
95
=item @mdfl = $lmdf->metadataFormat([$mdf])
96
97
Returns the metadataFormat list and optionally adds a new metadataFormat, $mdf. Returns an array ref of L<HTTP::OAI::MetadataFormat|HTTP::OAI::MetadataFormat>s.
98
99
=item $dom = $lmdf->toDOM
100
101
Returns a XML::DOM object representing the ListMetadataFormats response.
102
103
=back
(-)a/HTTP/OAI/ListRecords.pm (+133 lines)
Line 0 Link Here
1
package HTTP::OAI::ListRecords;
2
3
use strict;
4
use warnings;
5
6
use vars qw( @ISA );
7
@ISA = qw( HTTP::OAI::PartialList );
8
9
sub new {
10
	my ($class,%args) = @_;
11
	
12
	$args{handlers} ||= {};
13
	$args{handlers}->{header} ||= "HTTP::OAI::Header";
14
	$args{handlers}->{metadata} ||= "HTTP::OAI::Metadata";
15
	$args{handlers}->{about} ||= "HTTP::OAI::Metadata";
16
17
	my $self = $class->SUPER::new(%args);
18
	
19
	$self->{in_record} = 0;
20
21
	$self;
22
}
23
24
sub record { shift->item(@_) }
25
26
sub generate_body {
27
	my ($self) = @_;
28
	return unless defined(my $handler = $self->get_handler);
29
30
	for( $self->record ) {
31
		$_->set_handler($self->get_handler);
32
		$_->generate;
33
	}
34
	if( defined($self->resumptionToken) ) {
35
		$self->resumptionToken->set_handler($handler);
36
		$self->resumptionToken->generate;
37
	}
38
}
39
40
sub start_element {
41
	my ($self,$hash) = @_;
42
	if( !$self->{'in_record'} ) {
43
		my $elem = lc($hash->{LocalName});
44
		if( $elem eq 'record' ) {
45
			$self->set_handler(new HTTP::OAI::Record(
46
					version=>$self->version,
47
					handlers=>$self->{handlers},
48
			));
49
			$self->{'in_record'} = $hash->{Depth};
50
		} elsif( $elem eq 'resumptiontoken' ) {
51
			$self->set_handler(new HTTP::OAI::ResumptionToken(
52
				version=>$self->version
53
			));
54
			$self->{'in_record'} = $hash->{Depth};
55
		}
56
	}
57
	$self->SUPER::start_element($hash);
58
}
59
60
sub end_element {
61
	my ($self,$hash) = @_;
62
	$self->SUPER::end_element($hash);
63
	if( $self->{'in_record'} == $hash->{Depth} ) {
64
		my $elem = lc($hash->{LocalName});
65
		if( $elem eq 'record' ) {
66
HTTP::OAI::Debug::trace( "record: " . $self->get_handler->identifier );
67
			$self->record( $self->get_handler );
68
			$self->set_handler( undef );
69
			$self->{'in_record'} = 0;
70
		} elsif( $elem eq 'resumptiontoken' ) {
71
			$self->resumptionToken( $self->get_handler );
72
			$self->set_handler( undef );
73
			$self->{'in_record'} = 0;
74
		}
75
	}
76
}
77
78
1;
79
80
__END__
81
82
=head1 NAME
83
84
HTTP::OAI::ListRecords - Provide access to an OAI ListRecords response
85
86
=head1 SYNOPSIS
87
88
	my $r = $h->ListRecords(
89
		metadataPrefix=>'oai_dc',
90
	);
91
92
	while( my $rec = $r->next ) {
93
		print "Identifier => ", $rec->identifier, "\n";
94
	}
95
	
96
	die $r->message if $r->is_error;
97
98
	# Using callback method
99
	sub callback {
100
		my $rec = shift;
101
		print "Identifier => ", $rec->identifier, "\n";
102
	};
103
	my $r = $h->ListRecords(
104
		metadataPrefix=>'oai_dc',
105
		onRecord=>\&callback
106
	);
107
	die $r->message if $r->is_error;
108
	
109
=head1 METHODS
110
111
=over 4
112
113
=item $lr = new HTTP::OAI::ListRecords
114
115
This constructor method returns a new HTTP::OAI::ListRecords object.
116
117
=item $rec = $lr->next
118
119
Returns either an L<HTTP::OAI::Record|HTTP::OAI::Record> object, or undef, if no more record are available. Use $rec->is_error to test whether there was an error getting the next record.
120
121
=item @recl = $lr->record([$rec])
122
123
Returns the record list and optionally adds a new record or resumptionToken, $rec. Returns an array ref of L<HTTP::OAI::Record|HTTP::OAI::Record>s, including an optional resumptionToken string.
124
125
=item $token = $lr->resumptionToken([$token])
126
127
Returns and optionally sets the L<HTTP::OAI::ResumptionToken|HTTP::OAI::ResumptionToken>.
128
129
=item $dom = $lr->toDOM
130
131
Returns a XML::DOM object representing the ListRecords response.
132
133
=back
(-)a/HTTP/OAI/ListSets.pm (+120 lines)
Line 0 Link Here
1
package HTTP::OAI::ListSets;
2
3
use strict;
4
use warnings;
5
6
use vars qw( @ISA );
7
@ISA = qw( HTTP::OAI::PartialList );
8
9
sub new {
10
	my ($class,%args) = @_;
11
	
12
	$args{handlers} ||= {};
13
	$args{handlers}->{description} ||= 'HTTP::OAI::Metadata';
14
	
15
	my $self = $class->SUPER::new(%args);
16
	
17
	$self->{in_set} = 0;
18
19
	$self;
20
}
21
 
22
sub set { shift->item(@_) }
23
24
sub generate_body {
25
	my ($self) = @_;
26
	return unless defined(my $handler = $self->get_handler);
27
28
	for( $self->set ) {
29
		$_->set_handler($handler);
30
		$_->generate;
31
	}
32
	if( defined($self->resumptionToken) ) {
33
		$self->resumptionToken->set_handler($handler);
34
		$self->resumptionToken->generate;
35
	}
36
}
37
38
sub start_element {
39
	my ($self,$hash) = @_;
40
	my $elem = lc($hash->{Name});
41
	if( !$self->{in_set} ) {
42
		if( $elem eq 'set' ) {
43
			$self->set_handler(new HTTP::OAI::Set(
44
				version=>$self->version,
45
				handlers=>$self->{handlers}
46
			));
47
			$self->{'in_set'} = $hash->{Depth};
48
		} elsif( $elem eq 'resumptiontoken' ) {
49
			$self->set_handler(new HTTP::OAI::ResumptionToken(
50
				version=>$self->version
51
			));
52
			$self->{'in_set'} = $hash->{Depth};
53
		}
54
	}
55
	$self->SUPER::start_element($hash);
56
}
57
58
sub end_element {
59
	my ($self,$hash) = @_;
60
	my $elem = lc($hash->{LocalName});
61
	$self->SUPER::end_element($hash);
62
	if( $self->{'in_set'} == $hash->{Depth} )
63
	{
64
		if( $elem eq 'set' ) {
65
			$self->set( $self->get_handler );
66
			$self->set_handler( undef );
67
			$self->{in_set} = 0;
68
		} elsif( $elem eq 'resumptionToken' ) {
69
			$self->resumptionToken( $self->get_handler );
70
			$self->set_handler( undef );
71
			$self->{in_set} = 0;
72
		}
73
	}
74
}
75
76
1;
77
78
__END__
79
80
=head1 NAME
81
82
HTTP::OAI::ListSets - Provide access to an OAI ListSets response
83
84
=head1 SYNOPSIS
85
86
	my $r = $h->ListSets();
87
88
	while( my $rec = $r->next ) {
89
		print $rec->setSpec, "\n";
90
	}
91
92
	die $r->message if $r->is_error;
93
94
=head1 METHODS
95
96
=over 4
97
98
=item $ls = new HTTP::OAI::ListSets
99
100
This constructor method returns a new OAI::ListSets object.
101
102
=item $set = $ls->next
103
104
Returns either an L<HTTP::OAI::Set|HTTP::OAI::Set> object, or undef, if no more records are available. Use $set->is_error to test whether there was an error getting the next record.
105
106
If -resume was set to false in the Harvest Agent, next may return a string (the resumptionToken).
107
108
=item @setl = $ls->set([$set])
109
110
Returns the set list and optionally adds a new set or resumptionToken, $set. Returns an array ref of L<HTTP::OAI::Set|HTTP::OAI::Set>s, with an optional resumptionToken string.
111
112
=item $token = $ls->resumptionToken([$token])
113
114
Returns and optionally sets the L<HTTP::OAI::ResumptionToken|HTTP::OAI::ResumptionToken>.
115
116
=item $dom = $ls->toDOM
117
118
Returns a XML::DOM object representing the ListSets response.
119
120
=back
(-)a/HTTP/OAI/Metadata.pm (+35 lines)
Line 0 Link Here
1
package HTTP::OAI::Metadata;
2
3
use vars qw(@ISA);
4
@ISA = qw(HTTP::OAI::Encapsulation::DOM);
5
6
1;
7
8
__END__
9
10
=head1 NAME
11
12
HTTP::OAI::Metadata - Base class for data objects that contain DOM trees
13
14
=head1 SYNOPSIS
15
16
	use HTTP::OAI::Metadata;
17
18
	$xml = XML::LibXML::Document->new();
19
	$xml = XML::LibXML->new->parse( ... );
20
21
	$md = new HTTP::OAI::Metadata(dom=>$xml);
22
23
	print $md->dom->toString;
24
25
	my $dom = $md->dom(); # Return internal DOM tree
26
27
=head1 METHODS
28
29
=over 4
30
31
=item $md->dom( [$dom] )
32
33
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.
34
35
=back
(-)a/HTTP/OAI/Metadata/METS.pm (+66 lines)
Line 0 Link Here
1
package HTTP::OAI::Metadata::METS;
2
3
use strict;
4
use warnings;
5
6
use HTTP::OAI::Metadata;
7
use vars qw(@ISA);
8
@ISA = qw(HTTP::OAI::Metadata);
9
10
use XML::LibXML;
11
use XML::LibXML::XPathContext;
12
13
sub new {
14
	my $class = shift;
15
	my $self = $class->SUPER::new(@_);
16
	my %args = @_;
17
	$self;
18
}
19
20
sub _xc
21
{
22
	my $xc = XML::LibXML::XPathContext->new( @_ );
23
	$xc->registerNs( 'mets', 'http://www.loc.gov/METS/' );
24
	$xc->registerNs( 'xlink', 'http://www.w3.org/1999/xlink' );
25
	return $xc;
26
}
27
28
sub files
29
{
30
	my $self = shift;
31
	my $dom = $self->dom;
32
33
	my $xc = _xc($dom);
34
35
	my @files;
36
	foreach my $file ($xc->findnodes( '//mets:file' ))
37
	{
38
		my $f = {};
39
		foreach my $attr ($file->attributes)
40
		{
41
			$f->{ $attr->nodeName } = $attr->nodeValue;
42
		}
43
		$file = _xc($file);
44
		foreach my $locat ($file->findnodes( 'mets:FLocat' ))
45
		{
46
			$f->{ url } = $locat->getAttribute( 'xlink:href' );
47
		}
48
		push @files, $f;
49
	}
50
51
	return @files;
52
}
53
54
1;
55
56
__END__
57
58
=head1 NAME
59
60
HTTP::OAI::Metadata::METS - METS accessor utility
61
62
=head1 DESCRIPTION
63
64
=head1 SYNOPSIS
65
66
=head1 NOTE
(-)a/HTTP/OAI/Metadata/OAI_DC.pm (+161 lines)
Line 0 Link Here
1
package HTTP::OAI::Metadata::OAI_DC;
2
3
use XML::LibXML;
4
use HTTP::OAI::Metadata;
5
@ISA = qw(HTTP::OAI::Metadata);
6
7
use strict;
8
9
our $OAI_DC_SCHEMA = 'http://www.openarchives.org/OAI/2.0/oai_dc/';
10
our $DC_SCHEMA = 'http://purl.org/dc/elements/1.1/';
11
our @DC_TERMS = qw( contributor coverage creator date description format identifier language publisher relation rights source subject title type );
12
13
sub new {
14
	my( $class, %self ) = @_;
15
16
	my $self = $class->SUPER::new( %self );
17
18
	if( exists $self{dc} && ref($self{dc}) eq 'HASH' )
19
	{
20
		my ($dom,$dc) =_oai_dc_dom();
21
		foreach my $term (@DC_TERMS)
22
		{
23
			foreach my $value (@{$self{dc}->{$term}||[]})
24
			{
25
				$dc->appendChild($dom->createElementNS($DC_SCHEMA, $term))->appendText( $value );
26
			}
27
		}
28
		$self->dom($dom);
29
	}
30
31
	$self;
32
}
33
34
sub dc
35
{
36
	my( $self ) = @_;
37
38
	my $dom = $self->dom;
39
	my $metadata = $dom->documentElement;
40
41
	return $self->{dc} if defined $self->{dc};
42
43
	my %dc = map { $_ => [] } @DC_TERMS;
44
45
	$self->_dc( $metadata, \%dc );
46
47
	return \%dc;
48
}
49
50
sub _dc
51
{
52
	my( $self, $node, $dc ) = @_;
53
54
	my $ns = $node->getNamespaceURI;
55
	$ns =~ s/\/?$/\//;
56
57
	if( $ns eq $DC_SCHEMA )
58
	{
59
		push @{$dc->{lc($node->localName)}}, $node->textContent;
60
	}
61
	elsif( $node->hasChildNodes )
62
	{
63
		for($node->childNodes)
64
		{
65
			next if $_->nodeType != XML_ELEMENT_NODE;
66
			$self->_dc( $_, $dc );
67
		}
68
	}
69
}
70
71
sub _oai_dc_dom {
72
	my $dom = XML::LibXML->createDocument();
73
	$dom->setDocumentElement(my $dc = $dom->createElement('oai_dc:dc'));
74
	$dc->setAttribute('xmlns:oai_dc','http://www.openarchives.org/OAI/2.0/oai_dc/');
75
	$dc->setAttribute('xmlns:dc','http://purl.org/dc/elements/1.1/');
76
	$dc->setAttribute('xmlns:xsi','http://www.w3.org/2001/XMLSchema-instance');
77
	$dc->setAttribute('xsi:schemaLocation','http://www.openarchives.org/OAI/2.0/oai_dc/ http://www.openarchives.org/OAI/2.0/oai_dc.xsd');
78
	return ($dom,$dc);
79
}
80
81
sub metadata { 
82
	my( $self, $md ) = @_;
83
84
	return $self->dom if @_ == 1;
85
86
	delete $self->{dc};
87
	$self->dom( $md );
88
89
	return if !defined $md;
90
91
	my $dc = $self->dc;
92
93
	my ($dom,$metadata) = _oai_dc_dom();
94
95
	foreach my $term (@DC_TERMS)
96
	{
97
		foreach my $value (@{$dc->{$term}})
98
		{
99
			$metadata->appendChild( $dom->createElementNS( $DC_SCHEMA, $term ) )->appendText( $value );
100
		}
101
	}
102
103
	$self->dom($dom)
104
}
105
106
sub toString {
107
	my $self = shift;
108
	my $str = "Open Archives Initiative Dublin Core (".ref($self).")\n";
109
	foreach my $term ( @DC_TERMS ) {
110
		for(@{$self->{dc}->{$term}}) {
111
			$str .= sprintf("%s:\t%s\n", $term, $_||'');
112
		}
113
	}
114
	$str;
115
}
116
117
sub end_element {
118
	my ($self,$hash) = @_;
119
	my $elem = lc($hash->{LocalName});
120
	if( exists($self->{dc}->{$elem}) ) {
121
		push @{$self->{dc}->{$elem}}, $hash->{Text};
122
	}
123
	$self->SUPER::end_element($hash);
124
}
125
126
sub end_document {
127
	my $self = shift;
128
	$self->SUPER::end_document();
129
	$self->metadata($self->dom);
130
}
131
132
1;
133
134
__END__
135
136
=head1 NAME
137
138
HTTP::OAI::Metadata::OAI_DC - Easy access to OAI Dublin Core
139
140
=head1 DESCRIPTION
141
142
HTTP::OAI::Metadata::OAI_DC provides a simple interface to parsing and generating OAI Dublin Core ("oai_dc").
143
144
=head1 SYNOPSIS
145
146
	use HTTP::OAI::Metadata::OAI_DC;
147
148
	my $md = new HTTP::OAI::Metadata(
149
		dc=>{title=>['Hello, World!','Hi, World!']},
150
	);
151
152
	# Prints "Hello, World!"
153
	print $md->dc->{title}->[0], "\n";
154
155
	my $xml = $md->metadata();
156
157
	$md->metadata($xml);
158
159
=head1 NOTE
160
161
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.
(-)a/HTTP/OAI/Metadata/OAI_Eprints.pm (+42 lines)
Line 0 Link Here
1
package HTTP::OAI::Metadata::OAI_Eprints;
2
3
use strict;
4
use warnings;
5
6
use Carp;
7
use XML::LibXML;
8
use HTTP::OAI::Metadata;
9
10
use vars qw( @ISA );
11
@ISA = qw( HTTP::OAI::Metadata );
12
13
sub new {
14
	my $self = shift->SUPER::new(@_);
15
	my %args = @_;
16
	my $dom = XML::LibXML->createDocument();
17
	$dom->setDocumentElement(my $root = $dom->createElementNS('http://www.openarchives.org/OAI/1.1/eprints','eprints'));
18
#	$root->setAttribute('xmlns','http://www.openarchives.org/OAI/2.0/oai-identifier');
19
	$root->setAttribute('xmlns:xsi','http://www.w3.org/2001/XMLSchema-instance');
20
	$root->setAttribute('xsi:schemaLocation','http://www.openarchives.org/OAI/1.1/eprints http://www.openarchives.org/OAI/1.1/eprints.xsd');
21
	for(qw( content metadataPolicy dataPolicy submissionPolicy )) {
22
		Carp::croak "Required argument $_ undefined" if !defined($args{$_}) && $_ =~ /metadataPolicy|dataPolicy/;
23
		next unless defined($args{$_});
24
		my $node = $root->appendChild($dom->createElement($_));
25
		$args{$_}->{'URL'} ||= [];
26
		$args{$_}->{'text'} ||= [];
27
		foreach my $value (@{$args{$_}->{'URL'}}) {
28
			$node->appendChild($dom->createElement('URL'))->appendChild($dom->createTextNode($value));
29
		}
30
		foreach my $value (@{$args{$_}->{'text'}}) {
31
			$node->appendChild($dom->createElement('text'))->appendChild($dom->createTextNode($value));
32
		}
33
	}
34
	$args{'comment'} ||= [];
35
	for(@{$args{'comment'}}) {
36
		$root->appendChild($dom->createElement('comment'))->appendChild($dom->createTextNode($_));
37
	}
38
	$self->dom($dom);
39
	$self;
40
}
41
42
1;
(-)a/HTTP/OAI/Metadata/OAI_Identifier.pm (+29 lines)
Line 0 Link Here
1
package HTTP::OAI::Metadata::OAI_Identifier;
2
3
use strict;
4
use warnings;
5
6
use Carp;
7
use XML::LibXML;
8
use HTTP::OAI::Metadata;
9
10
use vars qw( @ISA );
11
@ISA = qw( HTTP::OAI::Metadata );
12
13
sub new {
14
	my $self = shift->SUPER::new(@_);
15
	my %args = @_;
16
	my $dom = XML::LibXML->createDocument();
17
	$dom->setDocumentElement(my $root = $dom->createElementNS('http://www.openarchives.org/OAI/2.0/oai-identifier','oai-identifier'));
18
#	$root->setAttribute('xmlns','http://www.openarchives.org/OAI/2.0/oai-identifier');
19
	$root->setAttribute('xmlns:xsi','http://www.w3.org/2001/XMLSchema-instance');
20
	$root->setAttribute('xsi:schemaLocation','http://www.openarchives.org/OAI/2.0/oai-identifier http://www.openarchives.org/OAI/2.0/oai-identifier.xsd');
21
	for(qw( scheme repositoryIdentifier delimiter sampleIdentifier )) {
22
		Carp::croak "Required argument $_ is undefined" unless defined($args{$_});
23
		$root->appendChild($dom->createElement($_))->appendChild($dom->createTextNode($args{$_}));
24
	}
25
	$self->dom($dom);
26
	$self;
27
}
28
29
1;
(-)a/HTTP/OAI/MetadataFormat.pm (+94 lines)
Line 0 Link Here
1
package HTTP::OAI::MetadataFormat;
2
3
use strict;
4
use warnings;
5
6
use HTTP::OAI::SAXHandler qw/ :SAX /;
7
8
use vars qw( @ISA );
9
@ISA = qw( HTTP::OAI::Encapsulation );
10
11
sub new {
12
	my ($class,%args) = @_;
13
14
	my $self = $class->SUPER::new(%args);
15
16
	$self->metadataPrefix($args{metadataPrefix}) if $args{metadataPrefix};
17
	$self->schema($args{schema}) if $args{schema};
18
	$self->metadataNamespace($args{metadataNamespace}) if $args{metadataNamespace};
19
20
	$self;
21
}
22
23
sub metadataPrefix {
24
	my $self = shift;
25
	return @_ ? $self->{metadataPrefix} = shift : $self->{metadataPrefix}
26
}
27
sub schema {
28
	my $self = shift;
29
	return @_ ? $self->{schema} = shift : $self->{schema} }
30
sub metadataNamespace {
31
	my $self = shift;
32
	return @_ ? $self->{metadataNamespace} = shift : $self->{metadataNamespace}
33
}
34
35
sub generate {
36
	my ($self) = @_;
37
	return unless defined(my $handler = $self->get_handler);
38
39
	g_start_element($handler,'http://www.openarchives.org/OAI/2.0/','metadataFormat',{});
40
	
41
	g_data_element($handler,'http://www.openarchives.org/OAI/2.0/','metadataPrefix',{},$self->metadataPrefix);
42
	g_data_element($handler,'http://www.openarchives.org/OAI/2.0/','schema',{},$self->schema);
43
	if( defined($self->metadataNamespace) ) {
44
		g_data_element($handler,'http://www.openarchives.org/OAI/2.0/','metadataNamespace',{},$self->metadataNamespace);
45
	}
46
	
47
	g_end_element($handler,'http://www.openarchives.org/OAI/2.0/','metadataFormat');
48
}
49
50
sub end_element {
51
	my ($self,$hash) = @_;
52
	$self->SUPER::end_element($hash);
53
	my $elem = lc($hash->{LocalName});
54
	if( defined $hash->{Text} )
55
	{
56
		$hash->{Text} =~ s/^\s+//;
57
		$hash->{Text} =~ s/\s+$//;
58
	}
59
	if( $elem eq 'metadataprefix' ) {
60
		$self->metadataPrefix($hash->{Text});
61
	} elsif( $elem eq 'schema' ) {
62
		$self->schema($hash->{Text});
63
	} elsif( $elem eq 'metadatanamespace' ) {
64
		$self->metadataNamespace($hash->{Text});
65
	}
66
}
67
68
1;
69
70
__END__
71
72
=head1 NAME
73
74
HTTP::OAI::MetadataFormat - Encapsulates OAI metadataFormat XML data
75
76
=head1 METHODS
77
78
=over 4
79
80
=item $mdf = new HTTP::OAI::MetadataFormat
81
82
This constructor method returns a new HTTP::OAI::MetadataFormat object.
83
84
=item $mdp = $mdf->metadataPrefix([$mdp])
85
86
=item $schema = $mdf->schema([$schema])
87
88
=item $ns = $mdf->metadataNamespace([$ns])
89
90
These methods respectively return and optionally set the metadataPrefix, schema and, metadataNamespace, for the metadataFormat record.
91
92
metadataNamespace is optional in OAI 1.x and therefore may be undef when harvesting pre OAI 2 repositories.
93
94
=back
(-)a/HTTP/OAI/PartialList.pm (+43 lines)
Line 0 Link Here
1
package HTTP::OAI::PartialList;
2
3
use strict;
4
use warnings;
5
6
use vars qw( @ISA );
7
@ISA = qw( HTTP::OAI::Response );
8
9
sub new {
10
	my( $class, %args ) = @_;
11
	my $self = $class->SUPER::new(%args);
12
	$self->{onRecord} = delete $args{onRecord};
13
	$self->{item} ||= [];
14
	return $self;
15
}
16
17
sub resumptionToken { shift->headers->header('resumptionToken',@_) }
18
19
sub item {
20
	my $self = shift;
21
	if( defined($self->{onRecord}) ) {
22
		$self->{onRecord}->($_, $self) for @_;
23
	} else {
24
		push(@{$self->{item}}, @_);
25
	}
26
	return wantarray ?
27
		@{$self->{item}} :
28
		$self->{item}->[0];
29
}
30
31
sub next {
32
	my $self = shift;
33
	return shift @{$self->{item}} if @{$self->{item}};
34
	return undef unless $self->{'resume'} and $self->resumptionToken;
35
36
	do {
37
		$self->resume(resumptionToken=>$self->resumptionToken);
38
	} while( $self->{onRecord} and $self->is_success and $self->resumptionToken );
39
40
	return $self->is_success ? $self->next : undef;
41
}
42
43
1;
(-)a/HTTP/OAI/Record.pm (+157 lines)
Line 0 Link Here
1
package HTTP::OAI::Record;
2
3
use strict;
4
use warnings;
5
6
use vars qw(@ISA);
7
8
use HTTP::OAI::SAXHandler qw/ :SAX /;
9
10
@ISA = qw(HTTP::OAI::Encapsulation);
11
12
sub new {
13
	my ($class,%args) = @_;
14
	my $self = $class->SUPER::new(%args);
15
16
	$self->{handlers} = $args{handlers};
17
18
	$self->header($args{header}) unless defined($self->header);
19
	$self->metadata($args{metadata}) unless defined($self->metadata);
20
	$self->{about} = $args{about} || [] unless defined($self->{about});
21
22
	$self->{in_record} = 0;
23
24
	$self->header(new HTTP::OAI::Header(%args)) unless defined $self->header;
25
26
	$self;
27
}
28
29
sub header { shift->_elem('header',@_) }
30
sub metadata { shift->_elem('metadata',@_) }
31
sub about {
32
	my $self = shift;
33
	push @{$self->{about}}, @_ if @_;
34
	return @{$self->{about}};
35
}
36
37
sub identifier { shift->header->identifier(@_) }
38
sub datestamp { shift->header->datestamp(@_) }
39
sub status { shift->header->status(@_) }
40
sub is_deleted { shift->header->is_deleted(@_) }
41
42
sub generate {
43
	my ($self) = @_;
44
	return unless defined(my $handler = $self->get_handler);
45
46
	g_start_element($handler,'http://www.openarchives.org/OAI/2.0/','record',{});
47
	$self->header->set_handler($handler);
48
	$self->header->generate;
49
	g_data_element($handler,'http://www.openarchives.org/OAI/2.0/','metadata',{},$self->metadata) if defined($self->metadata);
50
	g_data_element($handler,'http://www.openarchives.org/OAI/2.0/','about',{},$_) for $self->about;
51
	g_end_element($handler,'http://www.openarchives.org/OAI/2.0/','record');
52
}
53
54
sub start_element {
55
	my ($self,$hash) = @_;
56
	return $self->SUPER::start_element( $hash ) if $self->{in_record};
57
	my $elem = lc($hash->{LocalName});
58
	if( $elem eq 'record' && $self->version eq '1.1' ) {
59
		$self->status($hash->{Attributes}->{'{}status'}->{Value});
60
	}
61
	elsif( $elem =~ /^header|metadata|about$/ ) {
62
		my $handler = $self->{handlers}->{$elem}->new()
63
			or die "Error getting handler for <$elem> (failed to create new $self->{handlers}->{$elem})";
64
		$self->set_handler($handler);
65
		$self->{in_record} = $hash->{Depth};
66
		g_start_document( $handler );
67
		$self->SUPER::start_element( $hash );
68
	}
69
}
70
71
sub end_element {
72
	my ($self,$hash) = @_;
73
	$self->SUPER::end_element($hash);
74
	if( $self->{in_record} == $hash->{Depth} ) {
75
		$self->SUPER::end_document();
76
77
		my $elem = lc ($hash->{LocalName});
78
		$self->$elem ($self->get_handler);
79
		$self->set_handler ( undef );
80
		$self->{in_record} = 0;
81
	}
82
}
83
84
1;
85
86
__END__
87
88
=head1 NAME
89
90
HTTP::OAI::Record - Encapsulates an OAI record
91
92
=head1 SYNOPSIS
93
94
	use HTTP::OAI::Record;
95
96
	# Create a new HTTP::OAI Record
97
	my $r = new HTTP::OAI::Record();
98
99
	$r->header->identifier('oai:myarchive.org:oid-233');
100
	$r->header->datestamp('2002-04-01');
101
	$r->header->setSpec('all:novels');
102
	$r->header->setSpec('all:books');
103
104
	$r->metadata(new HTTP::OAI::Metadata(dom=>$md));
105
	$r->about(new HTTP::OAI::Metadata(dom=>$ab));
106
107
=head1 METHODS
108
109
=over 4
110
111
=item $r = new HTTP::OAI::Record( %opts )
112
113
This constructor method returns a new L<HTTP::OAI::Record> object.
114
115
Options (see methods below):
116
117
	header => $header
118
	metadata => $metadata
119
	about => [$about]
120
121
=item $r->header([HTTP::OAI::Header])
122
123
Returns and optionally sets the record header (an L<HTTP::OAI::Header> object).
124
125
=item $r->metadata([HTTP::OAI::Metadata])
126
127
Returns and optionally sets the record metadata (an L<HTTP::OAI::Metadata> object).
128
129
=item $r->about([HTTP::OAI::Metadata])
130
131
Optionally adds a new About record (an L<HTTP::OAI::Metadata> object) and returns an array of objects (may be empty).
132
133
=back
134
135
=head2 Header Accessor Methods
136
137
These methods are equivalent to C<< $rec->header->$method([$value]) >>.
138
139
=over 4
140
141
=item $r->identifier([$identifier])
142
143
Get and optionally set the record OAI identifier.
144
145
=item $r->datestamp([$datestamp])
146
147
Get and optionally set the record datestamp.
148
149
=item $r->status([$status])
150
151
Get and optionally set the record status (valid values are 'deleted' or undef).
152
153
=item $r->is_deleted()
154
155
Returns whether this record's status is deleted.
156
157
=back
(-)a/HTTP/OAI/Repository.pm (+271 lines)
Line 0 Link Here
1
package HTTP::OAI::Repository;
2
3
use strict;
4
use warnings;
5
6
use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
7
require Exporter;
8
9
@ISA = qw(Exporter);
10
11
@EXPORT = qw();
12
@EXPORT_OK = qw( &validate_request &validate_request_1_1 &validate_date &validate_metadataPrefix &validate_responseDate &validate_setSpec );
13
%EXPORT_TAGS = (validate=>[qw(&validate_request &validate_date &validate_metadataPrefix &validate_responseDate &validate_setSpec)]);
14
15
use HTTP::OAI::Error qw(%OAI_ERRORS);
16
17
# Copied from Simeon Warner's tutorial at
18
# http://library.cern.ch/HEPLW/4/papers/3/OAIServer.pm
19
# (note: corrected grammer for ListSets)
20
# 0 = optional, 1 = required, 2 = exclusive
21
my %grammer = (
22
	'GetRecord' =>
23
	{
24
		'identifier' => [1, \&validate_identifier],
25
		'metadataPrefix' => [1, \&validate_metadataPrefix]
26
	},
27
	'Identify' => {},
28
	'ListIdentifiers' =>
29
	{
30
		'from' => [0, \&validate_date],
31
		'until' => [0, \&validate_date],
32
		'set' => [0, \&validate_setSpec_2_0],
33
		'metadataPrefix' => [1, \&validate_metadataPrefix],
34
		'resumptionToken' => [2, sub { 0 }]
35
	},
36
	'ListMetadataFormats' =>
37
	{
38
		'identifier' => [0, \&validate_identifier]
39
	},
40
	'ListRecords' =>
41
	{
42
		'from' => [0, \&validate_date],
43
		'until' => [0, \&validate_date],
44
		'set' => [0, \&validate_setSpec_2_0],
45
		'metadataPrefix' => [1, \&validate_metadataPrefix],
46
		'resumptionToken' => [2, sub { 0 }]
47
	},
48
	'ListSets' =>
49
	{
50
		'resumptionToken' => [2, sub { 0 }]
51
	}
52
);
53
54
sub new {
55
	my ($class,%args) = @_;
56
	my $self = bless {}, $class;
57
	$self;
58
}
59
60
sub validate_request { validate_request_2_0(@_); }
61
62
sub validate_request_2_0 {
63
	my %params = @_;
64
	my $verb = $params{'verb'};
65
	delete $params{'verb'};
66
67
	my @errors;
68
69
	return (new HTTP::OAI::Error(code=>'badVerb',message=>'No verb supplied')) unless defined $verb;
70
71
	my $grm = $grammer{$verb} or return (new HTTP::OAI::Error(code=>'badVerb',message=>"Unknown verb '$verb'"));
72
73
	if( defined $params{'from'} && defined $params{'until'} ) {
74
		if( granularity($params{'from'}) ne granularity($params{'until'}) ) {
75
			return (new HTTP::OAI::Error(
76
				code=>'badArgument',
77
				message=>'Granularity used in from and until must be the same'
78
			));
79
		}
80
	}
81
82
	# Check exclusivity
83
	foreach my $arg (keys %$grm) {
84
		my ($type, $valid_func) = @{$grm->{$arg}};
85
		next unless ($type == 2 && defined($params{$arg}));
86
87
		if( my $err = &$valid_func($params{$arg}) ) {
88
			return (new HTTP::OAI::Error(
89
					code=>'badArgument', 
90
					message=>("Bad argument ($arg): " . $err)
91
				));
92
		}
93
94
		delete $params{$arg};
95
		if( %params ) {
96
			for(keys %params) {
97
				push @errors, new HTTP::OAI::Error(
98
					code=>'badArgument',
99
					message=>"'$_' can not be used in conjunction with $arg"
100
				);
101
			}
102
			return @errors;
103
		} else {
104
			return ();
105
		}
106
	}
107
108
	# Check required/optional
109
	foreach my $arg (keys %$grm) {
110
		my ($type, $valid_func) = @{$grm->{$arg}};
111
112
		if( $params{$arg} ) {
113
			if( my $err = &$valid_func($params{$arg}) ) {
114
				return (new HTTP::OAI::Error(code=>'badArgument',message=>"Bad argument ($arg): " . $err))
115
			}
116
		}
117
		if( $type == 1 && (!defined($params{$arg}) || $params{$arg} eq '') ) {
118
			return (new HTTP::OAI::Error(code=>'badArgument',message=>"Required argument '$arg' was undefined"));
119
		}
120
		delete $params{$arg};
121
	}
122
123
	if( %params ) {
124
		for(keys %params) {
125
			push @errors, new HTTP::OAI::Error(
126
				code=>'badArgument',
127
				message=>"'$_' is not a recognised argument for $verb"
128
			);
129
		}
130
		return @errors;
131
	} else {
132
		return ();
133
	}
134
}
135
136
sub granularity {
137
	my $date = shift;
138
	return 'year' if $date =~ /^\d{4}-\d{2}-\d{2}$/;
139
	return 'seconds' if $date =~ /^\d{4}-\d{2}-\d{2}T\d{2}:\d{2}:\d{2}Z$/;
140
}
141
142
sub validate_date {
143
	my $date = shift;
144
	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)?$/;
145
	my( $y, $m, $d ) = ($1,($2||1),($3||1));
146
	return "Month in date is not in range 1-12" if ($m < 1 || $m > 12);
147
	return "Day in date is not in range 1-31" if ($d < 1 || $d > 31);
148
	0;
149
}
150
151
sub validate_responseDate {
152
	return 
153
		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])$/ ?
154
		0 :
155
		"responseDate not in OAI format (yyyy-mm-ddThh:mm:dd:ss[+-]hh:mm)";
156
}
157
158
sub validate_setSpec {
159
	return 
160
		shift =~ /^([A-Za-z0-9])+(:[A-Za-z0-9]+)*$/ ?
161
		0 :
162
		"Set spec not in OAI format, must match ^([A-Za-z0-9])+(:[A-Za-z0-9]+)*\$";
163
}
164
165
sub validate_setSpec_2_0 {
166
	return
167
		shift =~ /^([A-Za-z0-9_!'\$\(\)\+\-\.\*])+(:[A-Za-z0-9_!'\$\(\)\+\-\.\*]+)*$/ ?
168
		0 :
169
		"Set spec not in OAI format, must match ([A-Za-z0-9_!'\\\$\(\\)\\+\\-\\.\\*])+(:[A-Za-z0-9_!'\\$\\(\\)\\+\\-\\.\\*]+)*";
170
}
171
172
sub validate_metadataPrefix {
173
	return
174
		shift =~ /^[\w]+$/ ?
175
		0 :
176
		"Metadata prefix not in OAI format, must match regexp ^[\\w]+\$";
177
}
178
179
# OAI 2 requires identifiers by valid URIs
180
# This doesn't check for invalid chars, merely <sheme>:<scheme-specific>
181
sub validate_identifier {
182
	return
183
		shift =~ /^[[:alpha:]][[:alnum:]\+\-\.]*:.+/ ?
184
		0 :
185
		"Identifier not in OAI format, must match regexp ^[[:alpha:]][[:alnum:]\\+\\-\\.]*:.+";
186
}
187
188
1;
189
190
__END__
191
192
=head1 NAME
193
194
HTTP::OAI::Repository - Documentation for building an OAI compliant repository using OAI-PERL
195
196
=head1 DESCRIPTION
197
198
Using the OAI-PERL library in a repository context requires the user to build the OAI responses to be sent to OAI harvesters.
199
200
=head1 SYNOPSIS 1
201
202
	use HTTP::OAI::Harvester;
203
	use HTTP::OAI::Metadata::OAI_DC;
204
	use XML::SAX::Writer;
205
	use XML::LibXML;
206
207
	# (all of these options _must_ be supplied to comply with the OAI protocol)
208
	# (protocolVersion and responseDate both have sensible defaults)
209
	my $r = new HTTP::OAI::Identify(
210
		baseURL=>'http://yourhost/cgi/oai',
211
		adminEmail=>'youremail@yourhost',
212
		repositoryName=>'agoodname',
213
		requestURL=>self_url()
214
	);
215
216
	# Include a description (an XML::LibXML Dom object)
217
	$r->description(new HTTP::OAI::Metadata(dom=>$dom));
218
219
	my $r = HTTP::OAI::Record->new(
220
		header=>HTTP::OAI::Header->new(
221
			identifier=>'oai:myrepo:10',
222
			datestamp=>'2004-10-01'
223
			),
224
		metadata=>HTTP::OAI::Metadata::OAI_DC->new(
225
			dc=>{title=>['Hello, World!'],description=>['My Record']}
226
			)
227
	);
228
	$r->about(HTTP::OAI::Metadata->new(dom=>$dom));
229
230
	my $writer = XML::SAX::Writer->new();
231
	$r->set_handler($writer);
232
	$r->generate;
233
234
=head1 Building an OAI compliant repository
235
236
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.
237
238
=head1 METHODS
239
240
=over 4
241
242
=item $r = HTTP::OAI::Repository::validate_request(%paramlist)
243
244
=item $r = HTTP::OAI::Repository::validate_request_2_0(%paramlist)
245
246
These functions, exported by the Repository module, validate an OAI request against the protocol requirements. Returns an L<HTTP::Response|HTTP::Response> object, with the code set to 200 if the request is well-formed, or an error code and the message set.
247
248
e.g:
249
250
	my $r = validate_request(%paramlist);
251
252
	print header(-status=>$r->code.' '.$r->message),
253
		$r->error_as_HTML;
254
255
Note that validate_request attempts to be as strict to the Protocol as possible.
256
257
=item $b = HTTP::OAI::Repository::validate_date($date)
258
259
=item $b = HTTP::OAI::Repository::validate_metadataPrefix($mdp)
260
261
=item $b = HTTP::OAI::Repository::validate_responseDate($date)
262
263
=item $b = HTTP::OAI::Repository::validate_setSpec($set)
264
265
These functions, exported by the Repository module, validate the given type of OAI data. Returns true if the given value is sane, false otherwise.
266
267
=back
268
269
=head1 EXAMPLE
270
271
See the bin/gateway.pl for an example implementation (it's actually for creating a static repository gateway, but you get the idea!).
(-)a/HTTP/OAI/Response.pm (+420 lines)
Line 0 Link Here
1
package HTTP::OAI::Response;
2
3
use strict;
4
use warnings;
5
6
=head1 NAME
7
8
HTTP::OAI::Response - An OAI response
9
10
=head1 DESCRIPTION
11
12
C<HTTP::OAI::Response> inherits from L<HTTP::Response> and supplies some utility methods for OAI.
13
14
=head1 METHODS
15
16
=over 4
17
18
=cut
19
20
use vars qw($BAD_REPLACEMENT_CHAR @ISA);
21
22
our $USE_EVAL = 1;
23
24
use utf8;
25
26
use POSIX qw/strftime/;
27
28
use CGI qw/-oldstyle_urls/;
29
$CGI::USE_PARAM_SEMICOLON = 0;
30
31
use HTTP::OAI::SAXHandler qw/ :SAX /;
32
33
@ISA = qw( HTTP::Response XML::SAX::Base );
34
$BAD_REPLACEMENT_CHAR = '?';
35
36
=item $r = new HTTP::OAI::Response([responseDate=>$rd][, requestURL=>$ru])
37
38
This constructor method returns a new HTTP::OAI::Response object. Optionally set the responseDate and requestURL.
39
40
Use $r->is_error to test whether the request was successful. In addition to the HTTP response codes, the following codes may be returned:
41
42
600 - Error parsing XML or invalid OAI response
43
44
Use $r->message to obtain a human-readable error message.
45
46
=cut
47
48
sub new {
49
	my ($class,%args) = @_;
50
	my $self = $class->SUPER::new(
51
		$args{code},
52
		$args{message}
53
	);
54
	# Force headers
55
	$self->{handlers} = $args{handlers} || {};
56
	$self->{_headers} = new HTTP::OAI::Headers(handlers=>$args{handlers});
57
	$self->{errors} = $args{errors} || [];
58
	$self->{resume} = $args{resume};
59
60
	# Force the version of OAI to try to parse
61
	$self->version($args{version});
62
63
	# Add the harvestAgent
64
	$self->harvestAgent($args{harvestAgent});
65
66
	# OAI initialisation
67
	if( $args{responseDate} ) {
68
		$self->responseDate($args{responseDate});
69
	}
70
	if( $args{requestURL} ) {
71
		$self->requestURL($args{requestURL});
72
	}
73
	if( $args{xslt} ) {
74
		$self->xslt($args{xslt});
75
	}
76
77
	# Do some intelligent filling of undefined values
78
	unless( defined($self->responseDate) ) {
79
		$self->responseDate(strftime("%Y-%m-%dT%H:%M:%S",gmtime).'Z');
80
	}
81
	unless( defined($self->requestURL) ) {
82
		$self->requestURL(CGI::self_url());
83
	}
84
	unless( defined($self->verb) ) {
85
		my $verb = ref($self);
86
		$verb =~ s/.*:://;
87
		$self->verb($verb);
88
	}
89
90
	return $self;
91
}
92
93
=item $r->copy_from( $r )
94
95
Copies an L<HTTP::Response> $r into this object.
96
97
=cut
98
99
sub copy_from
100
{
101
	my( $self, $r ) = @_;
102
103
	# The DOM stuff will break if headers isn't an HTTP::OAI::Headers object
104
	$self->{_headers}->{$_} = $r->{_headers}->{$_}
105
		for keys %{$r->{_headers}};
106
107
	$self->{_content} = $r->{_content};
108
109
	$self->code( $r->code );
110
	$self->message( $r->message );
111
	$self->request( $r->request );
112
113
	$self;
114
}
115
116
=item $headers = $r->headers
117
118
Returns an  L<HTTP::OAI::Headers> object.
119
120
=cut
121
122
sub parse_file {
123
	my ($self, $fh) = @_;
124
125
	$self->code(200);
126
	$self->message('parse_file');
127
	
128
	my $parser = XML::LibXML::SAX->new(
129
		Handler=>HTTP::OAI::SAXHandler->new(
130
			Handler=>$self->headers
131
	));
132
133
HTTP::OAI::Debug::trace( $self->verb . " " . ref($parser) . "->parse_file( ".ref($fh)." )" );
134
	$self->headers->set_handler($self);
135
	$USE_EVAL ?
136
		eval { $parser->parse_file($fh) } :
137
		$parser->parse_file($fh);
138
	$self->headers->set_handler(undef); # Otherwise we memory leak!
139
140
	if( $@ ) {
141
		$self->code(600);
142
		my $msg = $@;
143
		$msg =~ s/^\s+//s;
144
		$msg =~ s/\s+$//s;
145
		if( $self->request ) {
146
			$msg = "Error parsing XML from " . $self->request->uri . " " . $msg;
147
		} else {
148
			$msg = "Error parsing XML from string: $msg\n";
149
		}
150
		$self->message($msg);
151
		$self->errors(new HTTP::OAI::Error(
152
				code=>'parseError',
153
				message=>$msg
154
			));
155
	}
156
}
157
158
sub parse_string {
159
	my ($self, $str) = @_;
160
161
	$self->code(200);
162
	$self->message('parse_string');
163
	do {
164
		my $parser = XML::LibXML::SAX->new(
165
			Handler=>HTTP::OAI::SAXHandler->new(
166
				Handler=>$self->headers
167
		));
168
HTTP::OAI::Debug::trace( $self->verb . " " . ref($parser) . "->parse_string(...)" );
169
170
		$self->headers->set_handler($self);
171
		eval {
172
			local $SIG{__DIE__};
173
			$parser->parse_string( $str )
174
		};
175
		$self->headers->set_handler(undef);
176
		undef $@ if $@ && $@ =~ /^done\n/;
177
178
		if( $@ ) {
179
			die $@ if !$USE_EVAL; # rethrow
180
			$self->errors(new HTTP::OAI::Error(
181
				code=>'parseError',
182
				message=>"Error while parsing XML: $@",
183
			));
184
		}
185
	} while( $@ && fix_xml(\$str,$@) );
186
	if( $@ ) {
187
		$self->code(600);
188
		my $msg = $@;
189
		$msg =~ s/^\s+//s;
190
		$msg =~ s/\s+$//s;
191
		if( $self->request ) {
192
			$msg = "Error parsing XML from " . $self->request->uri . " " . $msg;
193
		} else {
194
			$msg = "Error parsing XML from string: $msg\n";
195
		}
196
		$self->message($msg);
197
		$self->errors(new HTTP::OAI::Error(
198
				code=>'parseError',
199
				message=>$msg
200
			));
201
	}
202
	$self;
203
}
204
205
sub harvestAgent { shift->headers->header('harvestAgent',@_) }
206
207
# Resume a request using a resumptionToken
208
sub resume {
209
	my ($self,%args) = @_;
210
	my $ha = $args{harvestAgent} || $self->harvestAgent || Carp::confess "Required argument harvestAgent is undefined";
211
	my $token = $args{resumptionToken} || Carp::confess "Required argument resumptionToken is undefined";
212
	my $verb = $args{verb} || $self->verb || Carp::confess "Required argument verb is undefined";
213
214
	if( !ref($token) or !$token->isa( "HTTP::OAI::ResumptionToken" ) )
215
	{
216
		$token = HTTP::OAI::ResumptionToken->new( resumptionToken => $token );
217
	}
218
219
HTTP::OAI::Debug::trace( "'" . $token->resumptionToken . "'" );
220
221
	my $response;
222
	%args = (
223
		baseURL=>$ha->repository->baseURL,
224
		verb=>$verb,
225
		resumptionToken=>$token->resumptionToken,
226
	);
227
	$self->headers->{_args} = \%args;
228
229
	# Reset the resumptionToken
230
	$self->headers->header('resumptionToken',undef);
231
	
232
	# Retry the request upto 3 times (leave a minute between retries)
233
	my $tries = 3;
234
	do {
235
		$response = $ha->request(\%args, undef, undef, undef, $self);
236
		unless( $response->is_success ) {
237
			# If the token is expired, we need to break out (no point wasting 3
238
			# minutes)
239
			if( my @errors = $response->errors ) {
240
				for( grep { $_->code eq 'badResumptionToken' } @errors ) {
241
					$tries = 0;
242
				}
243
			}
244
HTTP::OAI::Debug::trace( sprintf("Error response to '%s': %d '%s'\n",
245
	$args{resumptionToken},
246
	$response->code,
247
	$response->message
248
	) );
249
		}
250
	} while(
251
		!$response->is_success and
252
		$tries-- and
253
		sleep(60)
254
	);
255
256
	if( $self->resumptionToken and
257
		!$self->resumptionToken->is_empty and
258
		$self->resumptionToken->resumptionToken eq $token->resumptionToken ) {
259
		$self->code(600);
260
		$self->message("Flow-control error: Resumption token hasn't changed (" . $response->request->uri . ").");
261
	}
262
263
	$self;
264
}
265
266
sub generate {
267
	my ($self) = @_;
268
	return unless defined(my $handler = $self->get_handler);
269
	$self->headers->set_handler($handler);
270
271
	g_start_document($handler);
272
	$handler->xml_decl({'Version'=>'1.0','Encoding'=>'UTF-8'});
273
	$handler->characters({'Data'=>"\n"});
274
	if( $self->xslt ) {
275
		$handler->processing_instruction({
276
			'Target' => 'xml-stylesheet',
277
			'Data' => 'type=\'text/xsl\' href=\''. $self->xslt . '\''
278
		});
279
	}
280
	$self->headers->generate_start();
281
282
	if( $self->errors ) {
283
		for( $self->errors ) {
284
			$_->set_handler($handler);
285
			$_->generate();
286
		}
287
	} else {
288
		g_start_element($handler,'http://www.openarchives.org/OAI/2.0/',$self->verb,{});
289
		$self->generate_body();
290
		g_end_element($handler,'http://www.openarchives.org/OAI/2.0/',$self->verb,{});
291
	}
292
293
	$self->headers->generate_end();
294
	$handler->end_document();
295
}
296
297
sub toDOM {
298
	my $self = shift;
299
	$self->set_handler(my $builder = XML::LibXML::SAX::Builder->new());
300
	$self->generate();
301
	$builder->result;
302
}
303
304
=item $errs = $r->errors([$err])
305
306
Returns and optionally adds to the OAI error list. Returns a reference to an array.
307
308
=cut
309
310
sub errors {
311
	my $self = shift;
312
	push @{$self->{errors}}, @_;
313
	for (@_) {
314
		if( $_->code eq 'badVerb' || $_->code eq 'badArgument' ) {
315
			my $uri = URI->new($self->requestURL || '');
316
			$uri->query('');
317
			$self->requestURL($uri->as_string);
318
			last;
319
		}
320
	}
321
	@{$self->{errors}};
322
}
323
324
sub next { undef }
325
326
=item $rd = $r->responseDate( [$rd] )
327
328
Returns and optionally sets the response date.
329
330
=cut
331
332
sub responseDate { shift->headers->header('responseDate',@_) }
333
334
=item $ru = $r->requestURL( [$ru] )
335
336
Returns and optionally sets the request URL.
337
338
=cut
339
340
sub requestURL {
341
	my $self = shift;
342
	$_[0] =~ s/;/&/sg if @_ && $_[0] !~ /&/;
343
	$self->headers->header('requestURL',@_)
344
}
345
346
=item $verb = $r->verb( [$verb] )
347
348
Returns and optionally sets the OAI verb.
349
350
=cut
351
352
sub verb { shift->headers->header('verb',@_) }
353
354
=item $r->version
355
356
Return the version of the OAI protocol used by the remote site (protocolVersion is automatically changed by the underlying API).
357
358
=cut
359
360
sub version { shift->headers->header('version',@_) }
361
362
=item $r->xslt( $url )
363
364
Set the stylesheet to use in a response.
365
366
=cut
367
368
sub xslt { shift->headers->header('xslt',@_) }
369
370
# HTTP::Response::is_error doesn't consider 0 an error
371
sub is_error { return shift->code != 200 }
372
373
sub end_element {
374
	my ($self,$hash) = @_;
375
	my $elem = lc($hash->{Name});
376
	$self->SUPER::end_element($hash);
377
	if( $elem eq 'error' ) {
378
		my $code = $hash->{Attributes}->{'{}code'}->{'Value'} || 'oai-lib: Undefined error code';
379
		my $msg = $hash->{Text} || 'oai-lib: Undefined error message';
380
		$self->errors(new HTTP::OAI::Error(
381
			code=>$code,
382
			message=>$msg,
383
		));
384
		if( $code !~ '^noRecordsMatch|noSetHierarchy$' ) {
385
			$self->verb($elem);
386
			$self->code(600);
387
			$self->message("Response contains error(s): " . $self->{errors}->[0]->code . " (" . $self->{errors}->[0]->message . ")");
388
		}
389
	}
390
}
391
392
sub fix_xml {
393
	my ($str, $err) = @_;
394
	return 0 unless( $err =~ /not well-formed.*byte (\d+)/ );
395
        my $offset = $1;
396
        if( substr($$str,$offset-1,1) eq '&' ) {
397
                substr($$str,$offset-1,1) = '&amp;';
398
                return 1;
399
        } elsif( substr($$str,$offset-1,1) eq '<' ) {
400
                substr($$str,$offset-1,1) = '&lt;';
401
                return 1;
402
        } elsif( substr($$str,$offset,1) ne $BAD_REPLACEMENT_CHAR ) {
403
                substr($$str,$offset,1) = $BAD_REPLACEMENT_CHAR;
404
                return 1;
405
        } else {
406
                return 0;
407
        }
408
}
409
410
1;
411
412
__END__
413
414
=back
415
416
=head1 NOTE - requestURI/request
417
418
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.
419
420
The exception to this rule is for badVerb errors, where the arguments will not be available for conversion into a URI.
(-)a/HTTP/OAI/ResumptionToken.pm (+93 lines)
Line 0 Link Here
1
package HTTP::OAI::ResumptionToken;
2
3
use strict;
4
use warnings;
5
6
use HTTP::OAI::SAXHandler qw/ :SAX /;
7
8
use vars qw( @ISA );
9
@ISA = qw( HTTP::OAI::Encapsulation );
10
11
use overload "bool" => \&not_empty;
12
13
sub new {
14
	my ($class,%args) = @_;
15
	my $self = $class->SUPER::new(%args);
16
17
	$self->resumptionToken($args{resumptionToken}) unless $self->resumptionToken;
18
	$self->expirationDate($args{expirationDate}) unless $self->expirationDate;
19
	$self->completeListSize($args{completeListSize}) unless $self->completeListSize;
20
	$self->cursor($args{cursor}) unless $self->cursor;
21
22
	$self;
23
}
24
25
sub resumptionToken { shift->_elem('resumptionToken',@_) }
26
sub expirationDate { shift->_attr('expirationDate',@_) }
27
sub completeListSize { shift->_attr('completeListSize',@_) }
28
sub cursor { shift->_attr('cursor',@_) }
29
30
sub not_empty { defined($_[0]->resumptionToken) and length($_[0]->resumptionToken) > 0 }
31
sub is_empty { !not_empty(@_) }
32
33
sub generate {
34
	my ($self) = @_;
35
	return unless (my $handler = $self->get_handler);
36
	my $attr;
37
	while(my ($key,$value) = each %{$self->_attr}) {
38
		$attr->{"{}$key"} = {'Name'=>$key,'LocalName'=>$key,'Value'=>$value,'Prefix'=>'','NamespaceURI'=>'http://www.openarchives.org/OAI/2.0/'};
39
	}
40
	g_data_element($handler,'http://www.openarchives.org/OAI/2.0/','resumptionToken',$attr,$self->resumptionToken);
41
}
42
43
sub end_element {
44
	my ($self,$hash) = @_;
45
	$self->SUPER::end_element($hash);
46
	if( lc($hash->{Name}) eq 'resumptiontoken' ) {
47
		my $attr = $hash->{Attributes};
48
		$self->resumptionToken($hash->{Text});
49
50
		$self->expirationDate($attr->{'{}expirationDate'}->{'Value'});
51
		$self->completeListSize($attr->{'{}completeListSize'}->{'Value'});
52
		$self->cursor($attr->{'{}cursor'}->{'Value'});
53
	}
54
#warn "Got RT: $hash->{Text}";
55
}
56
57
1;
58
59
__END__
60
61
=head1 NAME
62
63
HTTP::OAI::ResumptionToken - Encapsulates an OAI resumption token
64
65
=head1 METHODS
66
67
=over 4
68
69
=item $rt = new HTTP::OAI::ResumptionToken
70
71
This constructor method returns a new HTTP::OAI::ResumptionToken object.
72
73
=item $token = $rt->resumptionToken([$token])
74
75
Returns and optionally sets the resumption token string.
76
77
=item $ed = $rt->expirationDate([$rt])
78
79
Returns and optionally sets the expiration date of the resumption token.
80
81
=item $cls = $rt->completeListSize([$cls])
82
83
Returns and optionally sets the cardinality of the result set.
84
85
=item $cur = $rt->cursor([$cur])
86
87
Returns and optionally sets the index of the first record (of the current page) in the result set.
88
89
=back
90
91
=head1 NOTE - Completing incomplete list
92
93
The final page of a record list which has been split using resumption tokens must contain an empty resumption token.
(-)a/HTTP/OAI/SAXHandler.pm (+266 lines)
Line 0 Link Here
1
package HTTP::OAI::SAXHandler;
2
3
use strict;
4
use warnings;
5
6
use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
7
8
use Data::Dumper; # debugging for here
9
10
@ISA = qw( Exporter XML::SAX::Base );
11
12
@EXPORT_OK = qw( g_start_document g_start_element g_end_element g_data_element );
13
%EXPORT_TAGS = (SAX=>[qw( g_start_document g_start_element g_end_element g_data_element )]);
14
15
=pod
16
17
=head1 NAME
18
19
HTTP::OAI::SAXHandler - SAX2 utility filter
20
21
=head1 DESCRIPTION
22
23
This module provides utility methods for SAX2, including collapsing multiple "characters" events into a single event.
24
25
This module exports methods for generating SAX2 events with Namespace support. This *isn't* a fully-fledged SAX2 generator!
26
27
=over 4
28
29
=item $h = HTTP::OAI::SAXHandler->new()
30
31
Class constructor.
32
33
=cut
34
35
sub new {
36
	my ($class,%args) = @_;
37
	$class = ref($class) || $class;
38
	my $self = $class->SUPER::new(%args);
39
	$self->{Depth} = 0;
40
	$self;
41
}
42
43
sub g_start_document {
44
	my ($handler) = @_;
45
	$handler->start_document();
46
	$handler->start_prefix_mapping({
47
			'Prefix'=>'xsi',
48
			'NamespaceURI'=>'http://www.w3.org/2001/XMLSchema-instance'
49
	});
50
	$handler->start_prefix_mapping({
51
			'Prefix'=>'',
52
			'NamespaceURI'=>'http://www.openarchives.org/OAI/2.0/'
53
	});
54
}
55
56
sub g_data_element {
57
	my ($handler,$uri,$qName,$attr,$value) = @_;
58
	g_start_element($handler,$uri,$qName,$attr);
59
	if( ref($value) ) {
60
		$value->set_handler($handler);
61
		$value->generate;
62
	} else {
63
		$handler->characters({'Data'=>$value});
64
	}
65
	g_end_element($handler,$uri,$qName);
66
}
67
68
sub g_start_element {
69
	my ($handler,$uri,$qName,$attr) = @_;
70
	$attr ||= {};
71
	my ($prefix,$localName) = split /:/, $qName;
72
	unless(defined($localName)) {
73
		$localName = $prefix;
74
		$prefix = '';
75
	}
76
	$handler->start_element({
77
		'NamespaceURI'=>$uri,
78
		'Name'=>$qName,
79
		'Prefix'=>$prefix,
80
		'LocalName'=>$localName,
81
		'Attributes'=>$attr
82
	});
83
}
84
85
sub g_end_element {
86
	my ($handler,$uri,$qName) = @_;
87
	my ($prefix,$localName) = split /:/, $qName;
88
	unless(defined($localName)) {
89
		$localName = $prefix;
90
		$prefix = '';
91
	}
92
	$handler->end_element({
93
		'NamespaceURI'=>$uri,
94
		'Name'=>$qName,
95
		'Prefix'=>$prefix,
96
		'LocalName'=>$localName,
97
	});
98
}
99
100
sub current_state {
101
	my $self = shift;
102
	return $self->{State}->[$#{$self->{State}}];
103
}
104
105
sub current_element {
106
	my $self = shift;
107
	return $self->{Elem}->[$#{$self->{Elem}}];
108
}
109
110
sub start_document {
111
HTTP::OAI::Debug::sax( Dumper($_[1]) );
112
	$_[0]->SUPER::start_document();
113
}
114
115
sub end_document {
116
	$_[0]->SUPER::end_document();
117
HTTP::OAI::Debug::sax( Dumper($_[1]) );
118
}
119
120
# Char data is rolled together by this module
121
sub characters {
122
	my ($self,$hash) = @_;
123
	$self->{Text} .= $hash->{Data};
124
# characters are traced in {start,end}_element
125
#HTTP::OAI::Debug::sax( "'" . substr($hash->{Data},0,40) . "'" );
126
}
127
128
sub start_element {
129
	my ($self,$hash) = @_;
130
	push @{$self->{Attributes}}, $hash->{Attributes};
131
	
132
	# Call characters with the joined character data
133
	if( defined($self->{Text}) )
134
	{
135
HTTP::OAI::Debug::sax( "'".substr($self->{Text},0,40) . "'" );
136
		$self->SUPER::characters({Data=>$self->{Text}});
137
		$self->{Text} = undef;
138
	}
139
140
	$hash->{State} = $self;
141
	$hash->{Depth} = ++$self->{Depth};
142
HTTP::OAI::Debug::sax( (" " x $hash->{Depth}) . '<'.$hash->{Name}.'>' );
143
	$self->SUPER::start_element($hash);
144
}
145
146
sub end_element {
147
	my ($self,$hash) = @_;
148
149
	# Call characters with the joined character data
150
	$hash->{Text} = $self->{Text};
151
	if( defined($self->{Text}) )
152
	{
153
		# Trailing whitespace causes problems
154
		if( $self->{Text} =~ /\S/ )
155
		{
156
HTTP::OAI::Debug::sax( "'".substr($self->{Text},0,40) . "'" );
157
			$self->SUPER::characters({Data=>$self->{Text}});
158
		}
159
		$self->{Text} = undef;
160
	}
161
	
162
	$hash->{Attributes} = pop @{$self->{Attributes}} || {};
163
	$hash->{State} = $self;
164
	$hash->{Depth} = $self->{Depth}--;
165
HTTP::OAI::Debug::sax( (" " x $hash->{Depth}) . '  <'.$hash->{Name}.'>' );
166
	$self->SUPER::end_element($hash);
167
}
168
169
sub entity_reference {
170
	my ($self,$hash) = @_;
171
HTTP::OAI::Debug::sax( $hash->{Name} );
172
}
173
174
sub start_cdata {
175
HTTP::OAI::Debug::sax();
176
}
177
178
sub end_cdata {
179
HTTP::OAI::Debug::sax();
180
}
181
182
sub comment {
183
HTTP::OAI::Debug::sax( $_[1]->{Data} );
184
}
185
186
sub doctype_decl {
187
	# {SystemId,PublicId,Internal}
188
HTTP::OAI::Debug::sax( $_[1]->{Name} );
189
}
190
191
sub attlist_decl {
192
	# {ElementName,AttributeName,Type,Default,Fixed}
193
HTTP::OAI::Debug::sax( $_[1]->{ElementName} );
194
}
195
196
sub xml_decl {
197
	# {Version,Encoding,Standalone}
198
HTTP::OAI::Debug::sax( join ", ", map { defined($_) ? $_ : "null" } @{$_[1]}{qw( Version Encoding Standalone )} );
199
}
200
201
sub entity_decl {
202
	# {Value,SystemId,PublicId,Notation}
203
HTTP::OAI::Debug::sax( $_[1]->{Name} );
204
}
205
206
sub unparsed_decl {
207
HTTP::OAI::Debug::sax();
208
}
209
210
sub element_decl {
211
	# {Model}
212
HTTP::OAI::Debug::sax( $_[1]->{Name} );
213
}
214
215
sub notation_decl {
216
	# {Name,Base,SystemId,PublicId}
217
HTTP::OAI::Debug::sax( $_[1]->{Name} );
218
}
219
220
sub processing_instruction {
221
	# {Target,Data}
222
HTTP::OAI::Debug::sax( $_[1]->{Target} . " => " . $_[1]->{Data} );
223
}
224
225
package HTTP::OAI::FilterDOMFragment;
226
227
use vars qw( @ISA );
228
229
@ISA = qw( XML::SAX::Base );
230
231
# Trap things that don't apply to a balanced fragment
232
sub start_document {}
233
sub end_document {}
234
sub xml_decl {}
235
236
package XML::SAX::Debug;
237
238
use Data::Dumper;
239
240
use vars qw( @ISA $AUTOLOAD );
241
242
@ISA = qw( XML::SAX::Base );
243
244
sub DEBUG {
245
	my ($event,$self,$hash) = @_;
246
warn "$event(".Dumper($hash).")\n";
247
	my $superior = "SUPER::$event";
248
	$self->$superior($hash);
249
}
250
251
sub start_document { DEBUG('start_document',@_) }
252
sub end_document { DEBUG('end_document',@_) }
253
sub start_element { DEBUG('start_element',@_) }
254
sub end_element { DEBUG('end_element',@_) }
255
sub characters { DEBUG('characters',@_) }
256
sub xml_decl { DEBUG('xml_decl',@_) }
257
258
1;
259
260
__END__
261
262
=back
263
264
=head1 AUTHOR
265
266
Tim Brody <tdb01r@ecs.soton.ac.uk>
(-)a/HTTP/OAI/Set.pm (+94 lines)
Line 0 Link Here
1
package HTTP::OAI::Set;
2
3
use strict;
4
use warnings;
5
6
use HTTP::OAI::SAXHandler qw/ :SAX /;
7
8
use vars qw( @ISA );
9
@ISA = qw( HTTP::OAI::Encapsulation );
10
11
sub new {
12
	my ($class,%args) = @_;
13
	my $self = $class->SUPER::new(%args);
14
15
	$self->{handlers} = $args{handlers};
16
	
17
	$self->setSpec($args{setSpec});
18
	$self->setName($args{setName});
19
	$self->{setDescription} = $args{setDescription} || [];
20
	$self;
21
}
22
23
sub setSpec { shift->_elem('setSpec',@_) }
24
sub setName { shift->_elem('setName',@_) }
25
sub setDescription {
26
	my $self = shift;
27
	push(@{$self->{setDescription}}, @_);
28
	return @{$self->{setDescription}};
29
}
30
sub next { shift @{shift->{setDescription}} }
31
32
sub generate {
33
	my ($self) = @_;
34
	return unless defined(my $handler = $self->get_handler);
35
	g_start_element($handler,'http://www.openarchives.org/OAI/2.0/','set',{});
36
	g_data_element($handler,'http://www.openarchives.org/OAI/2.0/','setSpec',{},$self->setSpec);
37
	g_data_element($handler,'http://www.openarchives.org/OAI/2.0/','setName',{},$self->setName);
38
	for( $self->setDescription ) {
39
		$_->set_handler($handler);
40
		$_->generate;
41
	}
42
	g_end_element($handler,'http://www.openarchives.org/OAI/2.0/','set');
43
}
44
45
sub start_element {
46
	my ($self,$hash) = @_;
47
	my $elem = lc($hash->{Name});
48
	if( $elem eq 'setdescription' ) {
49
		$self->setDescription(my $d = $self->{handlers}->{description}->new(version=>$self->version));
50
		$self->set_handler($d);
51
		g_start_document($d);
52
	}
53
	$self->SUPER::start_element($hash);
54
}
55
sub end_element {
56
	my ($self,$hash) = @_;
57
	$self->SUPER::end_element($hash);
58
	my $elem = lc($hash->{Name});
59
	if( $elem eq 'setspec' ) {
60
		die ref($self)." Parse error: Empty setSpec\n" unless $hash->{Text};
61
		$self->setSpec($hash->{Text});
62
	} elsif( $elem eq 'setname' ) {
63
		warn ref($self)." Parse error: Empty setName\n", return
64
			unless $hash->{Text};
65
		$self->setName($hash->{Text});
66
	} elsif( $elem eq 'setdescription' ) {
67
		$self->SUPER::end_document();
68
		$self->set_handler(undef);
69
	}
70
}
71
72
1;
73
74
__END__
75
76
=head1 NAME
77
78
HTTP::OAI::Set - Encapsulates OAI set XML data
79
80
=head1 METHODS
81
82
=over 4
83
84
=item $spec = $s->setSpec([$spec])
85
86
=item $name = $s->setName([$name])
87
88
These methods return respectively, the setSpec and setName of the OAI Set.
89
90
=item @descs = $s->setDescription([$desc])
91
92
Returns and optionally adds the list of set descriptions. Returns a reference to an array of L<HTTP::OAI::Description|HTTP::OAI::Description> objects.
93
94
=back
(-)a/HTTP/OAI/UserAgent.pm (+320 lines)
Line 0 Link Here
1
package HTTP::OAI::UserAgent;
2
3
use strict;
4
use warnings;
5
6
use vars qw(@ISA $ACCEPT);
7
8
# Do not use eval()
9
our $USE_EVAL = 1;
10
# Ignore bad utf8 characters
11
our $IGNORE_BAD_CHARS = 1;
12
# Silence bad utf8 warnings
13
our $SILENT_BAD_CHARS = 0;
14
15
use constant MAX_UTF8_BYTES => 4;
16
17
require LWP::UserAgent;
18
@ISA = qw(LWP::UserAgent);
19
20
unless( $@ ) {
21
	$ACCEPT = "gzip";
22
}
23
24
sub delay { shift->_elem( "delay", @_ ) }
25
sub last_request_completed { shift->_elem( "last_request_completed", @_ ) }
26
27
sub redirect_ok { 1 }
28
29
sub request
30
{
31
	my $self = shift;
32
	my ($request, $arg, $size, $previous, $response) = @_;
33
	if( ref($request) eq 'HASH' ) {
34
		$request = HTTP::Request->new(GET => _buildurl(%$request));
35
	}
36
37
	my $delay = $self->delay;
38
	if( defined $delay )
39
	{
40
		if( ref($delay) eq "CODE" )
41
		{
42
			$delay = &$delay( $self->last_request_completed );
43
		}
44
		select(undef,undef,undef,$delay) if $delay > 0;
45
	}
46
47
	if( !defined $response )
48
	{
49
		$response = $self->SUPER::request(@_);
50
		$self->last_request_completed( time );
51
		return $response;
52
	}
53
54
	my $parser = XML::LibXML->new(
55
		Handler => HTTP::OAI::SAXHandler->new(
56
			Handler => $response->headers
57
	));
58
	$parser->{request} = $request;
59
	$parser->{content_length} = 0;
60
	$parser->{content_buffer} = Encode::encode('UTF-8','');
61
	$response->code(200);
62
	$response->message('lwp_callback');
63
	$response->headers->set_handler($response);
64
HTTP::OAI::Debug::trace( $response->verb . " " . ref($parser) . "->parse_chunk()" );
65
	my $r;
66
	{
67
		local $SIG{__DIE__};
68
		$r = $self->SUPER::request($request,sub {
69
			$self->lwp_callback( $parser, @_ )
70
		});
71
		$self->lwp_endparse( $parser ) if $r->is_success;
72
	}
73
	if( defined($r) && defined($r->headers->header( 'Client-Aborted' )) && $r->headers->header( 'Client-Aborted' ) eq 'die' )
74
	{
75
		my $err = $r->headers->header( 'X-Died' );
76
		if( $err !~ /^done\n/ )
77
		{
78
			$r->code(500);
79
			$r->message( 'An error occurred while parsing: ' . $err );
80
		}
81
	}
82
83
	$response->headers->set_handler(undef);
84
	
85
	# Allow access to the original headers through 'previous'
86
	$response->previous($r);
87
	
88
	my $cnt_len = $parser->{content_length};
89
	undef $parser;
90
91
	# OAI retry-after
92
	if( defined($r) && $r->code == 503 && defined(my $timeout = $r->headers->header('Retry-After')) ) {
93
		$self->last_request_completed( time );
94
		if( $self->{recursion}++ > 10 ) {
95
			$self->{recursion} = 0;
96
			warn ref($self)."::request (retry-after) Given up requesting after 10 retries\n";
97
			return $response->copy_from( $r );
98
		}
99
		if( !$timeout or $timeout =~ /\D/ or $timeout < 0 or $timeout > 86400 ) {
100
			warn ref($self)." Archive specified an odd duration to wait (\"".($timeout||'null')."\")\n";
101
			return $response->copy_from( $r );
102
		}
103
HTTP::OAI::Debug::trace( "Waiting $timeout seconds" );
104
		sleep($timeout+10); # We wait an extra 10 secs for safety
105
		return $self->request($request,undef,undef,undef,$response);
106
	# Got an empty response
107
	} elsif( defined($r) && $r->is_success && $cnt_len == 0 ) {
108
		$self->last_request_completed( time );
109
		if( $self->{recursion}++ > 10 ) {
110
			$self->{recursion} = 0;
111
			warn ref($self)."::request (empty response) Given up requesting after 10 retries\n";
112
			return $response->copy_from( $r );
113
		}
114
HTTP::OAI::Debug::trace( "Retrying on empty response" );
115
		sleep(5);
116
		return $self->request($request,undef,undef,undef,$response);
117
	# An HTTP error occurred
118
	} elsif( $r->is_error ) {
119
		$response->copy_from( $r );
120
		$response->errors(HTTP::OAI::Error->new(
121
			code=>$r->code,
122
			message=>$r->message,
123
		));
124
	# An error occurred during parsing
125
	} elsif( $@ ) {
126
		$response->code(my $code = $@ =~ /read timeout/ ? 504 : 600);
127
		$response->message($@);
128
		$response->errors(HTTP::OAI::Error->new(
129
			code=>$code,
130
			message=>$@,
131
		));
132
	}
133
134
	# Reset the recursion timer
135
	$self->{recursion} = 0;
136
	
137
	# Copy original $request => OAI $response to allow easy
138
	# access to the requested URL
139
	$response->request($request);
140
141
	$self->last_request_completed( time );
142
143
	$response;
144
}
145
146
sub lwp_badchar
147
{
148
	my $codepoint = sprintf('U+%04x', ord($_[2]));
149
	unless( $SILENT_BAD_CHARS )
150
	{
151
		warn "Bad Unicode character $codepoint at byte offset ".$_[1]->{content_length}." from ".$_[1]->{request}->uri."\n";
152
	}
153
	return $codepoint;
154
}
155
156
sub lwp_endparse
157
{
158
	my( $self, $parser ) = @_; 
159
160
	my $utf8 = $parser->{content_buffer};
161
	# Replace bad chars with '?'
162
	if( $IGNORE_BAD_CHARS and length($utf8) ) {
163
		$utf8 = Encode::decode('UTF-8', $utf8, sub { $self->lwp_badchar($parser, @_) });
164
	}
165
	if( length($utf8) > 0 )
166
	{
167
		_ccchars($utf8); # Fix control chars
168
		$parser->{content_length} += length($utf8);
169
		$parser->parse_chunk($utf8);
170
	}
171
	delete($parser->{content_buffer});
172
	$parser->parse_chunk('', 1);
173
}
174
175
sub lwp_callback
176
{
177
	my( $self, $parser ) = @_;
178
179
	use bytes; # fixing utf-8 will need byte semantics
180
181
	$parser->{content_buffer} .= $_[2];
182
183
	do
184
	{
185
		# FB_QUIET won't split multi-byte chars on input
186
		my $utf8 = Encode::decode('UTF-8', $parser->{content_buffer}, Encode::FB_QUIET);
187
188
		if( length($utf8) > 0 )
189
		{
190
			use utf8;
191
			_ccchars($utf8); # Fix control chars
192
			$parser->{content_length} += length($utf8);
193
			$parser->parse_chunk($utf8);
194
		}
195
196
		if( length($parser->{content_buffer}) > MAX_UTF8_BYTES )
197
		{
198
			$parser->{content_buffer} =~ s/^([\x80-\xff]{1,4})//s;
199
			my $badbytes = $1;
200
			if( length($badbytes) == 0 )
201
			{
202
				Carp::confess "Internal error - bad bytes but not in 0x80-0xff range???";
203
			}
204
			if( $IGNORE_BAD_CHARS )
205
			{
206
				$badbytes = join('', map {
207
					$self->lwp_badchar($parser, $_)
208
				} split //, $badbytes);
209
			}
210
			$parser->parse_chunk( $badbytes );
211
		}
212
	} while( length($parser->{content_buffer}) > MAX_UTF8_BYTES );
213
}
214
215
sub _ccchars {
216
	$_[0] =~ s/([\x00-\x08\x0b-\x0c\x0e-\x1f])/sprintf("\\%04d",ord($1))/seg;
217
}
218
219
sub _buildurl {
220
	my %attr = @_;
221
	Carp::confess "_buildurl requires baseURL" unless $attr{'baseURL'};
222
	Carp::confess "_buildurl requires verb" unless $attr{'verb'};
223
	my $uri = new URI(delete($attr{'baseURL'}));
224
	if( defined($attr{resumptionToken}) && !$attr{force} ) {
225
		$uri->query_form(verb=>$attr{'verb'},resumptionToken=>$attr{'resumptionToken'});
226
	} else {
227
		delete $attr{force};
228
		# http://www.cshc.ubc.ca/oai/ breaks if verb isn't first, doh
229
		$uri->query_form(verb=>delete($attr{'verb'}),%attr);
230
	}
231
	return $uri->as_string;
232
}
233
234
sub url {
235
	my $self = shift;
236
	return _buildurl(@_);
237
}
238
239
sub decompress {
240
	my ($response) = @_;
241
	my $type = $response->headers->header("Content-Encoding");
242
	return $response->{_content_filename} unless defined($type);
243
	if( $type eq 'gzip' ) {
244
		my $filename = File::Temp->new( UNLINK => 1 );
245
		my $gz = Compress::Zlib::gzopen($response->{_content_filename}, "r") or die $!;
246
		my ($buffer,$c);
247
		my $fh = IO::File->new($filename,"w");
248
		binmode($fh,":utf8");
249
		while( ($c = $gz->gzread($buffer)) > 0 ) {
250
			print $fh $buffer;
251
		}
252
		$fh->close();
253
		$gz->gzclose();
254
		die "Error decompressing gziped response: " . $gz->gzerror() if -1 == $c;
255
		return $response->{_content_filename} = $filename;
256
	} else {
257
		die "Unsupported compression returned: $type\n";
258
	}
259
}
260
261
1;
262
263
__END__
264
265
=head1 NAME
266
267
HTTP::OAI::UserAgent - Extension of the LWP::UserAgent for OAI HTTP requests
268
269
=head1 DESCRIPTION
270
271
This module provides a simplified mechanism for making requests to an OAI repository, using the existing LWP::UserAgent module.
272
273
=head1 SYNOPSIS
274
275
	require HTTP::OAI::UserAgent;
276
277
	my $ua = new HTTP::OAI::UserAgent;
278
279
	my $response = $ua->request(
280
		baseURL=>'http://arXiv.org/oai1',
281
		verb=>'ListRecords',
282
		from=>'2001-08-01',
283
		until=>'2001-08-31'
284
	);
285
286
	print $response->content;
287
288
=head1 METHODS
289
290
=over 4
291
292
=item $ua = new HTTP::OAI::UserAgent(proxy=>'www-cache',...)
293
294
This constructor method returns a new instance of a HTTP::OAI::UserAgent module. All arguments are passed to the L<LWP::UserAgent|LWP::UserAgent> constructor.
295
296
=item $r = $ua->request($req)
297
298
Requests the HTTP response defined by $req, which is a L<HTTP::Request|HTTP::Request> object.
299
300
=item $r = $ua->request(baseURL=>$baseref, verb=>$verb, %opts)
301
302
Makes an HTTP request to the given OAI server (baseURL) with OAI arguments. Returns an L<HTTP::Response> object.
303
304
OAI-PMH related options:
305
306
	from => $from
307
	until => $until
308
	resumptionToken => $token
309
	metadataPrefix => $mdp
310
	set => $set
311
312
=item $str = $ua->url(baseURL=>$baseref, verb=>$verb, ...)
313
314
Takes the same arguments as request, but returns the URL that would be requested.
315
316
=item $time_d = $ua->delay( $time_d )
317
318
Return and optionally set a time (in seconds) to wait between requests. $time_d may be a CODEREF.
319
320
=back
(-)a/Makefile.PL (-1 / +1 lines)
Lines 313-318 my $target_map = { Link Here
313
  './etc/zebradb'               => { target => 'ZEBRA_CONF_DIR', trimdir => -1 },
313
  './etc/zebradb'               => { target => 'ZEBRA_CONF_DIR', trimdir => -1 },
314
  './etc/pazpar2'               => { target => 'PAZPAR2_CONF_DIR', trimdir => -1 },
314
  './etc/pazpar2'               => { target => 'PAZPAR2_CONF_DIR', trimdir => -1 },
315
  './help.pl'                   => 'INTRANET_CGI_DIR',
315
  './help.pl'                   => 'INTRANET_CGI_DIR',
316
  './HTTP'                      => 'PERL_MODULE_DIR',
316
  './ill'                       => 'INTRANET_CGI_DIR',
317
  './ill'                       => 'INTRANET_CGI_DIR',
317
  './installer-CPAN.pl'         => 'NONE',
318
  './installer-CPAN.pl'         => 'NONE',
318
  './installer'                 => 'INTRANET_CGI_DIR',
319
  './installer'                 => 'INTRANET_CGI_DIR',
319
- 

Return to bug 20437