File Coverage

blib/lib/HTTP/OAI/Repository.pm
Criterion Covered Total %
statement 41 65 63.0
branch 14 42 33.3
condition 11 22 50.0
subroutine 9 14 64.2
pod 6 10 60.0
total 81 153 52.9


line stmt bran cond sub pod time code
1             package HTTP::OAI::Repository;
2              
3 11     11   83 use strict;
  11         21  
  11         315  
4 11     11   75 use warnings;
  11         25  
  11         335  
5              
6 11     11   67 use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
  11         31  
  11         1565  
7             require Exporter;
8              
9             our $VERSION = '4.13';
10              
11             @ISA = qw(Exporter);
12              
13             @EXPORT = qw();
14             @EXPORT_OK = qw( &validate_request &validate_request_1_1 &validate_date &validate_metadataPrefix &validate_responseDate &validate_setSpec );
15             %EXPORT_TAGS = (validate=>[qw(&validate_request &validate_date &validate_metadataPrefix &validate_responseDate &validate_setSpec)]);
16              
17 11     11   98 use HTTP::OAI::Error qw(%OAI_ERRORS);
  11         33  
  11         16189  
18              
19             # Copied from Simeon Warner's tutorial at
20             # http://library.cern.ch/HEPLW/4/papers/3/OAIServer.pm
21             # (note: corrected grammer for ListSets)
22             # 0 = optional, 1 = required, 2 = exclusive
23             my %grammer = (
24             'GetRecord' =>
25             {
26             'identifier' => [1, \&validate_identifier],
27             'metadataPrefix' => [1, \&validate_metadataPrefix]
28             },
29             'Identify' => {},
30             'ListIdentifiers' =>
31             {
32             'from' => [0, \&validate_date],
33             'until' => [0, \&validate_date],
34             'set' => [0, \&validate_setSpec_2_0],
35             'metadataPrefix' => [1, \&validate_metadataPrefix],
36             'resumptionToken' => [2, sub { 0 }]
37             },
38             'ListMetadataFormats' =>
39             {
40             'identifier' => [0, \&validate_identifier]
41             },
42             'ListRecords' =>
43             {
44             'from' => [0, \&validate_date],
45             'until' => [0, \&validate_date],
46             'set' => [0, \&validate_setSpec_2_0],
47             'metadataPrefix' => [1, \&validate_metadataPrefix],
48             'resumptionToken' => [2, sub { 0 }]
49             },
50             'ListSets' =>
51             {
52             'resumptionToken' => [2, sub { 0 }]
53             }
54             );
55              
56             sub new {
57 0     0 0 0 my ($class,%args) = @_;
58 0         0 my $self = bless {}, $class;
59 0         0 $self;
60             }
61              
62 9     9 1 26 sub validate_request { validate_request_2_0(@_); }
63              
64             sub validate_request_2_0 {
65 9     9 1 28 my %params = @_;
66 9         17 my $verb = $params{'verb'};
67 9         17 delete $params{'verb'};
68              
69 9         14 my @errors;
70              
71 9 50       27 return (new HTTP::OAI::Error(code=>'badVerb',message=>'No verb supplied')) unless defined $verb;
72              
73 9 50       40 my $grm = $grammer{$verb} or return (new HTTP::OAI::Error(code=>'badVerb',message=>"Unknown verb '$verb'"));
74              
75 9 50 66     94 if( defined $params{'from'} && defined $params{'until'} ) {
76 0 0       0 if( granularity($params{'from'}) ne granularity($params{'until'}) ) {
77 0         0 return (new HTTP::OAI::Error(
78             code=>'badArgument',
79             message=>'Granularity used in from and until must be the same'
80             ));
81             }
82             }
83              
84             # Check exclusivity
85 9         46 foreach my $arg (keys %$grm) {
86 24         34 my ($type, $valid_func) = @{$grm->{$arg}};
  24         75  
87 24 50 66     86 next unless ($type == 2 && defined($params{$arg}));
88              
89 0 0       0 if( my $err = &$valid_func($params{$arg}) ) {
90 0         0 return (new HTTP::OAI::Error(
91             code=>'badArgument',
92             message=>("Bad argument ($arg): " . $err)
93             ));
94             }
95              
96 0         0 delete $params{$arg};
97 0 0       0 if( %params ) {
98 0         0 for(keys %params) {
99 0         0 push @errors, new HTTP::OAI::Error(
100             code=>'badArgument',
101             message=>"'$_' can not be used in conjunction with $arg"
102             );
103             }
104 0         0 return @errors;
105             } else {
106 0         0 return ();
107             }
108             }
109              
110             # Check required/optional
111 9         31 foreach my $arg (keys %$grm) {
112 24         30 my ($type, $valid_func) = @{$grm->{$arg}};
  24         42  
113              
114 24 100       46 if( $params{$arg} ) {
115 7 50       25 if( my $err = &$valid_func($params{$arg}) ) {
116 0         0 return (new HTTP::OAI::Error(code=>'badArgument',message=>"Bad argument ($arg): " . $err))
117             }
118             }
119 24 50 33     79 if( $type == 1 && (!defined($params{$arg}) || $params{$arg} eq '') ) {
      66        
120 0         0 return (new HTTP::OAI::Error(code=>'badArgument',message=>"Required argument '$arg' was undefined"));
121             }
122 24         40 delete $params{$arg};
123             }
124              
125 9 50       59 if( %params ) {
126 0         0 for(keys %params) {
127 0         0 push @errors, new HTTP::OAI::Error(
128             code=>'badArgument',
129             message=>"'$_' is not a recognised argument for $verb"
130             );
131             }
132 0         0 return @errors;
133             } else {
134 9         48 return ();
135             }
136             }
137              
138             sub granularity {
139 0     0 0 0 my $date = shift;
140 0 0       0 return 'year' if $date =~ /^\d{4}-\d{2}-\d{2}$/;
141 0 0       0 return 'seconds' if $date =~ /^\d{4}-\d{2}-\d{2}T\d{2}:\d{2}:\d{2}Z$/;
142             }
143              
144             sub validate_date {
145 1     1 1 2 my $date = shift;
146 1 50       9 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)?$/;
147 1   50     8 my( $y, $m, $d ) = ($1,($2||1),($3||1));
      50        
148 1 50 33     16 return "Month in date is not in range 1-12" if ($m < 1 || $m > 12);
149 1 50 33     7 return "Day in date is not in range 1-31" if ($d < 1 || $d > 31);
150 1         10 0;
151             }
152              
153             sub validate_responseDate {
154             return
155 0 0   0 1 0 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])$/ ?
156             0 :
157             "responseDate not in OAI format (yyyy-mm-ddThh:mm:dd:ss[+-]hh:mm)";
158             }
159              
160             sub validate_setSpec {
161             return
162 0 0   0 1 0 shift =~ /^([A-Za-z0-9])+(:[A-Za-z0-9]+)*$/ ?
163             0 :
164             "Set spec not in OAI format, must match ^([A-Za-z0-9])+(:[A-Za-z0-9]+)*\$";
165             }
166              
167             sub validate_setSpec_2_0 {
168             return
169 0 0   0 0 0 shift =~ /^([A-Za-z0-9_!'\$\(\)\+\-\.\*])+(:[A-Za-z0-9_!'\$\(\)\+\-\.\*]+)*$/ ?
170             0 :
171             "Set spec not in OAI format, must match ([A-Za-z0-9_!'\\\$\(\\)\\+\\-\\.\\*])+(:[A-Za-z0-9_!'\\$\\(\\)\\+\\-\\.\\*]+)*";
172             }
173              
174             sub validate_metadataPrefix {
175             return
176 5 50   5 1 34 shift =~ /^[A-Za-z0-9\-_\.!\~\*\'\(\)]+$/ ?
177             0 :
178             "Metadata prefix not in OAI format, must match regexp ^[A-Za-z0-9\\-_\\.!\\~\\*\\'\\(\\)]+\$/";
179             }
180              
181             # OAI 2 requires identifiers by valid URIs
182             # This doesn't check for invalid chars, merely :
183             sub validate_identifier {
184             return
185 1 50   1 0 11 shift =~ /^[[:alpha:]][[:alnum:]\+\-\.]*:.+/ ?
186             0 :
187             "Identifier not in OAI format, must match regexp ^[[:alpha:]][[:alnum:]\\+\\-\\.]*:.+";
188             }
189              
190             1;
191              
192             __END__