C4/OAI/DP.pm

   1 #  ---------------------------------------------------------------------
   2 #   OAI Data Provider template (OAI-PMH v2.0)
   3 #    v3.05
   4 #    June 2002
   5 #  ------------------+--------------------+-----------------------------
   6 #   Hussein Suleman  |   hussein@vt.edu   |    www.husseinsspace.com
   7 #  ------------------+--------------------+-+---------------------------
   8 #   Department of Computer Science          |        www.cs.vt.edu
   9 #     Digital Library Research Laboratory   |       www.dlib.vt.edu
  10 #  -----------------------------------------+-------------+-------------
  11 #   Virginia Polytechnic Institute and State University   |  www.vt.edu
  12 #  -------------------------------------------------------+-------------
  13 #    January 2008
  14 #  ------------------+--------------------------------------------------
  15 #   Ph. Jaillon      |
  16 #  ------------------+----------------------+---------------------------
  17 #   Department of Computer Science          |
  18 #  -----------------------------------------+-------------+-------------
  19 #   Ecole Nationale Superieure des Mines de St-Etienne    |  www.emse.fr
  20 #  -------------------------------------------------------+-------------
  21
  22
  23 $VERSION = '1.0.0';
  24
  25 package C4::OAI::DP;
  26
  27 =head1 OAI::DP OAI Data Provider
  28
  29 This module provide a full  implementation of the OAI-PMH v2 protocol
  30 specification (http://www.openarchives.org/OAI/openarchivesprotocol.html).
  31
  32 It is simple to use, to answer to OAI-PMH requests you must create a new OAI::DP
  33 instance and call its run() method.
  34
  35 This new instance is an instance of a subclass of the OAI::DP class and the job
  36 of this subclass is to manage data and to format answers according to the meta data
  37 model used (see OAI::DC for an example).
  38
  39 Tipical OAI service looks like:
  40
  41         my $OAI = new A_OAI_SUBCLASS(some parameters);
  42
  43         $OAI->run();
  44         $OAI->dispose();
  45
  46 =cut
  47
  48 use POSIX;
  49
  50 use CGI;
  51 use C4::OAI::Utility;
  52
  53 # setting binmode to utf8 (any characters printed on STDOUT are utf8 encoded)
  54 binmode(STDOUT, ":utf8");
  55
  56 # constructor
  57 sub new
  58 {
  59    my ($classname) = @_;
  60
  61    my $self = {
  62       class           => $classname,
  63       xmlnsprefix     => 'http://www.openarchives.org/OAI/2.0/',
  64       protocolversion => '2.0',
  65       repositoryName  => 'NoName Repository',
  66       adminEmail      => 'someone@somewhere.org',
  67       granularity     => 'YYYY-MM-DD',
  68       deletedRecord   => 'no',
  69       metadatanamespace => {
  70          oai_dc       => 'http://www.openarchives.org/OAI/2.0/oai_dc/',
  71       },
  72       metadataschema => {
  73          oai_dc       => 'http://www.openarchives.org/OAI/2.0/oai_dc.xsd',
  74       },
  75       metadataroot => {
  76          oai_dc       => 'dc',
  77       },
  78       metadatarootparameters => {
  79          oai_dc       => '',
  80       },
  81       utility         => new C4::OAI::Utility,
  82       error           => [],
  83    };
  84
  85    bless $self, $classname;
  86    return $self;
  87 }
  88
  89
  90 # destructor
  91 sub dispose
  92 {
  93    my ($self) = @_;
  94 }
  95
  96
  97 # output XML HTTP header
  98 sub xmlheader
  99 {
 100    my ($self) = @_;
 101
 102    # calculate timezone automatically
 103    my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst)=gmtime (time);
 104    my $timezone = 'Z';
 105    my $datestring = sprintf ("%04d-%02d-%02dT%02d:%02d:%02d%s",
 106                     $year+1900, $mon+1, $mday, $hour, $min, $sec,
 107                     $timezone);
 108
 109    # make error strings
 110    my $errors = '';
 111    my $fullrequest = 1;
 112    foreach my $error (@{$self->{'error'}})
 113    {
 114       $errors .= "<error code=\"$error->[0]\">$error->[1]</error>\n";
 115       if (($error->[0] eq 'badVerb') || ($error->[0] eq 'badArgument'))
 116       {
 117          $fullrequest = 0;
 118       }
 119    }
 120
 121    # add verb container if no errors
 122    my $verbcontainer = '';
 123    if ($#{$self->{'error'}} == -1)
 124    {
 125       $verbcontainer = '<'.$self->{'verb'}.">\n";
 126    }
 127
 128    # compute request element with its parameters included if necessary
 129    my $request = '<request';
 130    if ($fullrequest == 1)
 131    {
 132       foreach my $param ($self->{'cgi'}->param)
 133       {
 134          $request .= " $param=\"".$self->{'cgi'}->param ($param)."\"";
 135       }
 136    }
 137    $request .= '>'.$self->{'cgi'}->{'baseURL'}.'</request>';
 138
 139    "Content-type: text/xml\n\n".
 140    "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n\n".
 141    "<OAI-PMH xmlns=\"$self->{'xmlnsprefix'}\" ".
 142    "xmlns:xsi=\"http://www.w3.org/2001/XMLSchema-instance\" ".
 143    "xsi:schemaLocation=\"$self->{'xmlnsprefix'} ".
 144    "$self->{'xmlnsprefix'}OAI-PMH.xsd\">\n\n".
 145    "<responseDate>$datestring</responseDate>\n".
 146    $request."\n\n".
 147    $errors.
 148    $verbcontainer;
 149 }
 150
 151
 152 # output XML HTTP footer
 153 sub xmlfooter
 154 {
 155    my ($self) = @_;
 156
 157    # add verb container if no errors
 158    my $verbcontainer = '';
 159    if ($#{$self->{'error'}} == -1)
 160    {
 161       $verbcontainer = '</'.$self->{'verb'}.">\n";
 162    }
 163
 164    $verbcontainer.
 165    "\n</OAI-PMH>\n";
 166 }
 167
 168
 169 # add an error to the running list of errors (if its not there already)
 170 sub AddError
 171 {
 172    my ($self, $errorcode, $errorstring) = @_;
 173
 174    my $found = 0;
 175    foreach my $error (@{$self->{'error'}})
 176    {
 177       if (($error->[0] eq $errorcode) && ($error->[1] eq $errorstring))
 178       { $found = 1 };
 179    }
 180
 181    if ($found == 0)
 182    {
 183       push (@{$self->{'error'}}, [ $errorcode, $errorstring ] );
 184    }
 185 }
 186
 187
 188 # create an error and output response
 189 sub Error
 190 {
 191    my ($self, $errorcode, $errorstring) = @_;
 192
 193    $self->AddError ($errorcode, $errorstring);
 194    $self->xmlheader.$self->xmlfooter;
 195 }
 196
 197
 198 # check for the validity of the date according to the OAI spec
 199 sub DateisValid
 200 {
 201    my ($self, $date) = @_;
 202
 203    my ($year, $month, $day, $hour, $minute, $second);
 204
 205    if ($date =~ /^([0-9]{4})-([0-9]{2})-([0-9]{2})/)
 206    {
 207       $year = $1;
 208       if ($year <= 0)
 209       { return 0; }
 210
 211       $month = $2;
 212       if (($month <= 0) || ($month > 12))
 213       { return 0; }
 214
 215       $day = $3;
 216       my $daysinmonth;
 217       if ((((($year % 4) == 0) && (($year % 100) != 0)) || (($year % 400) == 0))
 218           && ($month == 2))
 219       { $daysinmonth = 29; }
 220       elsif (($month == 4) || ($month == 6) || ($month == 9) || ($month == 11))
 221       { $daysinmonth = 30; }
 222       elsif ($month == 2)
 223       { $daysinmonth = 28; }
 224       else
 225       { $daysinmonth = 31; }
 226       if (($day <= 0) || ($day > $daysinmonth))
 227       { return 0; }
 228    }
 229    else
 230    { return 0; }
 231
 232    if ($date =~ /^[0-9]{4}-[0-9]{2}-[0-9]{2}T([0-9]{2}):([0-9]{2}):([0-9]{2})Z$/)
 233    {
 234       $hour = $1;
 235       $minute = $2;
 236       if (($hour < 0) || ($hour > 23) || ($minute < 0) || ($minute > 59))
 237       { return 0; }
 238
 239       $second = $3;
 240       if (($second < 0) || ($second > 59))
 241       { return 0; }
 242    }
 243    elsif (length ($date) > 10)
 244    { return 0; }
 245
 246    return 1;
 247 }
 248
 249
 250 # check that the granularity is ok
 251 sub GranularityisValid
 252 {
 253    my ($self, $date1, $date2) = @_;
 254
 255    my $granularity = $self->{'granularity'};
 256
 257    if (($granularity ne 'YYYY-MM-DDThh:mm:ssZ') && (length ($date1) > 10))
 258    {
 259       return 0;
 260    }
 261    if (defined $date2)
 262    {
 263       if (($granularity ne 'YYYY-MM-DDThh:mm:ssZ') && (length ($date2) > 10))
 264       {
 265          return 0;
 266       }
 267       if (length ($date1) != length ($date2))
 268       {
 269          return 0;
 270       }
 271    }
 272
 273    return 1;
 274 }
 275
 276
 277 # check for bad arguments
 278 sub ArgumentisValid
 279 {
 280    my ($self) = @_;
 281
 282    my %required = (
 283       'Identify' => [],
 284       'ListSets' => [],
 285       'ListMetadataFormats' => [],
 286       'ListIdentifiers' => [ 'metadataPrefix' ],
 287       'GetRecord' => [ 'identifier', 'metadataPrefix' ],
 288       'ListRecords' => [ 'metadataPrefix' ]
 289    );
 290    my %optional = (
 291       'Identify' => [],
 292       'ListSets' => [],
 293       'ListMetadataFormats' => [ 'identifier' ],
 294       'ListIdentifiers' => [ 'set', 'from', 'until', 'resumptionToken' ],
 295       'GetRecord' => [],
 296       'ListRecords' => [ 'set', 'from', 'until', 'resumptionToken' ]
 297    );
 298
 299    # get parameter lists
 300    my $verb = $self->{'cgi'}->param ('verb');
 301    my @parmsrequired = @{$required{$verb}};
 302    my @parmsoptional = @{$optional{$verb}};
 303    my @parmsall = (@parmsrequired, @parmsoptional);
 304    my @names = $self->{'cgi'}->param;
 305    my %paramhash = ();
 306    foreach my $name (@names)
 307    {
 308       $paramhash{$name} = 1;
 309    }
 310
 311    # check for required parameters
 312    foreach my $name (@parmsrequired)
 313    {
 314       if ((! exists $paramhash{$name}) &&
 315           ((($verb ne 'ListIdentifiers') && ($verb ne 'ListRecords')) ||
 316            (! exists $paramhash{'resumptionToken'})))
 317       {
 318          return $self->Error ('badArgument', "missing $name parameter");
 319       }
 320    }
 321
 322    # check for illegal parameters
 323    foreach my $name (@names)
 324    {
 325       my $found = 0;
 326       foreach my $name2 (@parmsall)
 327       {
 328          if ($name eq $name2)
 329          { $found = 1; }
 330       }
 331       if (($found == 0) && ($name ne 'verb'))
 332       {
 333          return $self->Error ('badArgument', "$name is an illegal parameter");
 334       }
 335    }
 336
 337    # check for duplicate parameters
 338    foreach my $name (@names)
 339    {
 340       my @values = $self->{'cgi'}->param ($name);
 341       if ($#values != 0)
 342       {
 343          return $self->Error ('badArgument', "multiple values are not allowed for the $name parameter");
 344       }
 345    }
 346
 347    # check for resumptionToken exclusivity
 348    if ((($verb eq 'ListIdentifiers') || ($verb eq 'ListRecords')) &&
 349         (exists $paramhash{'resumptionToken'}) &&
 350         ($#names > 1))
 351    {
 352       return $self->Error ('badArgument', 'resumptionToken cannot be combined with other parameters');
 353    }
 354
 355    return '';
 356 }
 357
 358
 359 # convert date/timestamp into seconds for comparisons
 360 sub ToSeconds
 361 {
 362    my ($self, $date, $from) = @_;
 363
 364    my ($month, $day, $hour, $minute, $second);
 365
 366    if ((defined $from) && ($from == 1))
 367    {
 368       ($month, $day, $hour, $minute, $second) = (1, 1, 0, 0, 0);
 369    }
 370    else
 371    {
 372       ($month, $day, $hour, $minute, $second) = (12, 31, 23, 59, 59);
 373    }
 374
 375    if ($date =~ /([0-9]{4})-([0-9]{2})-([0-9]{2})T([0-9]{2}):([0-9]{2}):([0-9]{2})Z/)
 376    {
 377       return mktime ($6, $5, $4, $3, $2-1, $1-1900);
 378    }
 379    elsif ($date =~ /([0-9]{4})-([0-9]{2})-([0-9]{2})/)
 380    {
 381       return mktime ($second, $minute, $hour, $3, $2-1, $1-1900);
 382    }
 383    else
 384    {
 385       return 0;
 386    }
 387 }
 388
 389
 390 # check if the metadata format is valid
 391 sub MetadataFormatisValid
 392 {
 393    my ($self, $metadataFormat) = @_;
 394
 395    my $found = 0;
 396    foreach my $i (keys %{$self->{'metadatanamespace'}})
 397    {
 398       if ($metadataFormat eq $i)
 399       { $found = 1; }
 400    }
 401
 402    if ($found == 1)
 403    { return 1; }
 404    else
 405    { return 0; }
 406 }
 407
 408
 409 # format the header for a record
 410 sub FormatHeader
 411 {
 412    my ($self, $identifier, $datestamp, $status, $setSpecs) = @_;
 413
 414    my $statusattribute = '';
 415    if ((defined $status) && ($status eq 'deleted'))
 416    {
 417       $statusattribute = " status=\"deleted\"";
 418    }
 419
 420    my $setstring = '';
 421    if (defined $setSpecs)
 422    {
 423       foreach my $setSpec (@$setSpecs)
 424       {
 425          $setstring .= '<setSpec>'.$setSpec."</setSpec>\n";
 426       }
 427    }
 428
 429    "<header$statusattribute>\n".
 430    "<identifier>$identifier</identifier>\n".
 431    "<datestamp>$datestamp</datestamp>\n".
 432    $setstring.
 433    "</header>\n";
 434 }
 435
 436
 437 # format the record by encapsulating it in a "record" container
 438 sub FormatRecord
 439 {
 440    my ($self, $identifier, $datestamp, $status, $setSpecs, $metadata, $about) = @_;
 441
 442    my $header = $self->FormatHeader ($identifier, $datestamp, $status, $setSpecs);
 443
 444    my $output =
 445       "<record>\n".
 446       $header;
 447
 448    if ((defined $metadata) && ($metadata ne ''))
 449    {
 450       $output .= "<metadata>\n$metadata</metadata>\n";
 451    }
 452    if ((defined $about) && ($about ne ''))
 453    {
 454       $output .= "<about>\n$about</about>\n";
 455    }
 456
 457    $output."</record>\n";
 458 }
 459
 460
 461 # standard handler for Identify verb
 462 sub Identify
 463 {
 464    my ($self) = @_;
 465
 466    my $identity = $self->Archive_Identify;
 467    if (! exists $identity->{'repositoryName'})
 468    {
 469       $identity->{'repositoryName'} = $self->{'repositoryName'};
 470    }
 471    if (! exists $identity->{'adminEmail'})
 472    {
 473       $identity->{'adminEmail'} = $self->{'adminEmail'};
 474    }
 475    $identity->{'protocolVersion'} = $self->{'protocolversion'};
 476    $identity->{'baseURL'} = $self->{'cgi'}->{'baseURL'};
 477    if (! exists $identity->{'granularity'})
 478    {
 479       $identity->{'granularity'} = $self->{'granularity'};
 480    }
 481    if (! exists $identity->{'deletedRecord'})
 482    {
 483       $identity->{'deletedRecord'} = $self->{'deletedRecord'};
 484    }
 485    if (! exists $identity->{'earliestDatestamp'})
 486    {
 487       my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst)=gmtime (0);
 488       my $timezone = 'Z';
 489       my $datestring = sprintf ("%04d-%02d-%02dT%02d:%02d:%02d%s",
 490                        $year+1900, $mon+1, $mday, $hour, $min, $sec,
 491                        $timezone);
 492       $identity->{'earliestDatestamp'} = $datestring;
 493    }
 494
 495    $identity->{'mdorder'} = [ qw ( repositoryName baseURL protocolVersion adminEmail earliestDatestamp deletedRecord granularity compression description ) ];
 496
 497    # add in description for toolkit
 498    if (! exists $identity->{'description'})
 499    {
 500       $identity->{'description'} = [];
 501    }
 502    my $desc = {
 503       'toolkit' => [[
 504          {
 505             'xmlns' => 'http://oai.dlib.vt.edu/OAI/metadata/toolkit',
 506             'xsi:schemaLocation' =>
 507                        'http://oai.dlib.vt.edu/OAI/metadata/toolkit '.
 508                        'http://oai.dlib.vt.edu/OAI/metadata/toolkit.xsd'
 509          },
 510          {
 511             'title'    => 'VTOAI Perl Data Provider',
 512             'author'   => [
 513                      {
 514                        'name' => 'Hussein Suleman',
 515                        'email' => 'hussein@vt.edu',
 516                        'institution' => 'Virginia Tech',
 517                        'mdorder' => [ qw ( name email institution ) ],
 518                      },
 519                      {
 520                        'name' => 'Philippe Jaillon',
 521                        'email' => 'jaillon@emse.fr',
 522                        'institution' => 'École Nationale Supérieure des Mines de Saint-Étienne',
 523                        'mdorder' => [ qw ( name email institution ) ],
 524                      }
 525              ],
 526             'version'  => '3.05',
 527             'URL'      => [
 528                 'http://www.dlib.vt.edu/projects/OAI/',
 529                 'http://oai-pmh.emse.fr/'
 530              ],
 531             'mdorder'  => [ qw ( title author version URL ) ]
 532          },
 533       ]]
 534    };
 535    push (@{$identity->{'description'}}, $desc);
 536
 537    $self->xmlheader.
 538    $self->{'utility'}->FormatXML ($identity).
 539    $self->xmlfooter;
 540 }
 541
 542
 543 # standard handler for ListMetadataFormats verb
 544 sub ListMetadataFormats
 545 {
 546    my ($self) = @_;
 547
 548    my $identifier = $self->{'cgi'}->param ('identifier');
 549    my $metadataNamespace = $self->{'metadatanamespace'};
 550    my $metadataSchema = $self->{'metadataschema'};
 551
 552    my $lmf = $self->Archive_ListMetadataFormats ($identifier);
 553    if ($#$lmf > 0)
 554    {
 555       $metadataNamespace = $$lmf[0];
 556       $metadataSchema = $$lmf[1];
 557    }
 558
 559    my $buffer = $self->xmlheader;
 560    if ($#{$self->{'error'}} == -1)
 561    {
 562       foreach my $i (keys %{$metadataNamespace})
 563       {
 564          $buffer .= "<metadataFormat>\n".
 565                     "<metadataPrefix>$i</metadataPrefix>\n".
 566                     "<schema>$metadataSchema->{$i}</schema>\n".
 567                     "<metadataNamespace>$metadataNamespace->{$i}</metadataNamespace>\n".
 568                     "</metadataFormat>\n";
 569       }
 570    }
 571    $buffer.$self->xmlfooter;
 572 }
 573
 574
 575 # standard handler for ListSets verb
 576 sub ListSets
 577 {
 578    my ($self) = @_;
 579
 580    my $setlist = $self->Archive_ListSets;
 581
 582    if ($#$setlist == -1)
 583    {
 584       $self->AddError ('noSetHierarchy', 'The repository does not support sets');
 585    }
 586
 587    my $buffer = $self->xmlheader;
 588    if ($#{$self->{'error'}} == -1)
 589    {
 590       foreach my $item (@$setlist)
 591       {
 592          $buffer .= "<set>\n".
 593                     "  <setSpec>".$self->{'utility'}->lclean ($$item[0])."</setSpec>\n".
 594                     "  <setName>".$self->{'utility'}->lclean ($$item[1])."</setName>\n";
 595          if (defined $$item[2])
 596          {
 597             $buffer .= '<setDescription>'.$$item[2].'</setDescription>';
 598          }
 599          $buffer .= "</set>\n";
 600       }
 601    }
 602    $buffer.$self->xmlfooter;
 603 }
 604
 605
 606 # standard handler for GetRecord verb
 607 sub GetRecord
 608 {
 609    my ($self) = @_;
 610
 611    my $identifier = $self->{'cgi'}->param ('identifier');
 612    my $metadataPrefix = $self->{'cgi'}->param ('metadataPrefix');
 613
 614    my $recref = $self->Archive_GetRecord ($identifier, $metadataPrefix);
 615    my $recbuffer;
 616    if ($recref)
 617    {
 618       $recbuffer = $self->Archive_FormatRecord ($recref, $metadataPrefix);
 619    }
 620
 621    my $buffer = $self->xmlheader;
 622    if ($#{$self->{'error'}} == -1)
 623    {
 624       $buffer .= $recbuffer;
 625    }
 626    $buffer.$self->xmlfooter;
 627 }
 628
 629
 630 # create extended resumptionToken
 631 sub createResumptionToken
 632 {
 633    my ($self, $resumptionToken, $resumptionParameters) = @_;
 634
 635    my $attrs = '';
 636    if (defined $resumptionParameters)
 637    {
 638       foreach my $key (keys %{$resumptionParameters})
 639       {
 640          $attrs .= " $key=\"$resumptionParameters->{$key}\"";
 641       }
 642    }
 643
 644    if (($resumptionToken ne '') || ($attrs ne ''))
 645    {
 646       "<resumptionToken".$attrs.">$resumptionToken</resumptionToken>\n";
 647    }
 648    else
 649    {
 650       '';
 651    }
 652 }
 653
 654
 655 # standard handler for ListRecords verb
 656 sub ListRecords
 657 {
 658    my ($self) = @_;
 659
 660    my ($set, $from, $until, $metadataPrefix);
 661    my ($resumptionToken, $allrows, $resumptionParameters);
 662
 663    $resumptionToken = $self->{'cgi'}->param ('resumptionToken');
 664    if ($resumptionToken eq '')
 665    {
 666       $set = $self->{'cgi'}->param ('set');
 667       $from = $self->{'cgi'}->param ('from');
 668       $until = $self->{'cgi'}->param ('until');
 669       $metadataPrefix = $self->{'cgi'}->param ('metadataPrefix');
 670
 671       if ($from ne '')
 672       {
 673          if (!($self->DateisValid ($from)))
 674          { return $self->Error ('badArgument', 'illegal from parameter'); }
 675          if (!($self->GranularityisValid ($from)))
 676          { return $self->Error ('badArgument', 'illegal granularity for from parameter'); }
 677       }
 678       if ($until ne '')
 679       {
 680          if (!($self->DateisValid ($until)))
 681          { return $self->Error ('badArgument', 'illegal until parameter'); }
 682          if (!($self->GranularityisValid ($until)))
 683          { return $self->Error ('badArgument', 'illegal granularity for until parameter'); }
 684       }
 685       if (($from ne '') && ($until ne '') && (!($self->GranularityisValid ($from, $until))))
 686       {
 687          return $self->Error ('badArgument', 'mismatched granularities in from/until');
 688       }
 689    }
 690
 691    ($allrows, $resumptionToken, $metadataPrefix, $resumptionParameters) =
 692      $self->Archive_ListRecords ($set, $from, $until, $metadataPrefix, $resumptionToken);
 693
 694    my $recbuffer;
 695    foreach my $recref (@$allrows)
 696    {
 697       $recbuffer .= $self->Archive_FormatRecord ($recref, $metadataPrefix);
 698    }
 699
 700    my $buffer = $self->xmlheader;
 701    if ($#{$self->{'error'}} == -1)
 702    {
 703       $buffer .= $recbuffer.$self->createResumptionToken ($resumptionToken, $resumptionParameters);
 704    }
 705    $buffer.$self->xmlfooter;
 706 }
 707
 708
 709 # standard handler for ListIdentifiers verb
 710 sub ListIdentifiers
 711 {
 712    my ($self) = @_;
 713
 714    my ($set, $from, $until, $metadataPrefix);
 715    my ($resumptionToken, $allrows, $resumptionParameters);
 716
 717    $resumptionToken = $self->{'cgi'}->param ('resumptionToken');
 718    if ($resumptionToken eq '')
 719    {
 720       $set = $self->{'cgi'}->param ('set');
 721       $from = $self->{'cgi'}->param ('from');
 722       $until = $self->{'cgi'}->param ('until');
 723       $metadataPrefix = $self->{'cgi'}->param ('metadataPrefix');
 724
 725       if ($from ne '')
 726       {
 727          if (!($self->DateisValid ($from)))
 728          { return $self->Error ('badArgument', 'illegal from parameter'); }
 729          if (!($self->GranularityisValid ($from)))
 730          { return $self->Error ('badArgument', 'illegal granularity for from parameter'); }
 731       }
 732       if ($until ne '')
 733       {
 734          if (!($self->DateisValid ($until)))
 735          { return $self->Error ('badArgument', 'illegal until parameter'); }
 736          if (!($self->GranularityisValid ($until)))
 737          { return $self->Error ('badArgument', 'illegal granularity for until parameter'); }
 738       }
 739       if (($from ne '') && ($until ne '') && (!($self->GranularityisValid ($from, $until))))
 740       {
 741          return $self->Error ('badArgument', 'mismatched granularities in from/until');
 742       }
 743    }
 744
 745    ($allrows, $resumptionToken, $metadataPrefix, $resumptionParameters) =
 746      $self->Archive_ListIdentifiers ($set, $from, $until, $metadataPrefix, $resumptionToken);
 747
 748    my $recbuffer = '';
 749    foreach my $recref (@$allrows)
 750    {
 751       $recbuffer .= $self->Archive_FormatHeader ($recref, $metadataPrefix);
 752    }
 753
 754    my $buffer = $self->xmlheader;
 755    if ($#{$self->{'error'}} == -1)
 756    {
 757       $buffer .= $recbuffer.$self->createResumptionToken ($resumptionToken, $resumptionParameters);
 758    }
 759    $buffer.$self->xmlfooter;
 760 }
 761
 762
 763 # stub routines to get actual data from archives
 764
 765
 766 sub Archive_FormatRecord
 767 {
 768    my ($self, $recref, $metadataFormat) = @_;
 769
 770    $self->FormatRecord ('identifier',
 771                         '1000-01-01',
 772                         '',
 773                         '',
 774                         $self->{'utility'}->FormatXML ({}),
 775                         $self->{'utility'}->FormatXML ({})
 776                        );
 777 }
 778
 779
 780 sub Archive_FormatHeader
 781 {
 782    my ($self, $recref, $metadataFormat) = @_;
 783
 784    $self->FormatHeader ('identifier',
 785                         '1000-01-01',
 786                         '',
 787                         ''
 788                        );
 789 }
 790
 791
 792 sub Archive_Identify
 793 {
 794    my ($self) = @_;
 795
 796    {};
 797 }
 798
 799
 800 sub Archive_ListSets
 801 {
 802    my ($self) = @_;
 803
 804    [];
 805 }
 806
 807
 808 sub Archive_ListMetadataFormats
 809 {
 810    my ($self, $identifier) = @_;
 811
 812    [];
 813 }
 814
 815
 816 sub Archive_GetRecord
 817 {
 818    my ($self, $identifier, $metadataPrefix) = @_;
 819
 820    my %records = ();
 821
 822    undef;
 823 }
 824
 825
 826 sub Archive_ListRecords
 827 {
 828    my ($self, $set, $from, $until, $metadataPrefix, $resumptionToken) = @_;
 829
 830    my $results = [];
 831    my @allrows = ();
 832    $resumptionToken = '';
 833
 834    ( \@allrows, $resumptionToken, $metadataPrefix, {} );
 835 }
 836
 837
 838 sub Archive_ListIdentifiers
 839 {
 840    my ($self, $set, $from, $until, $metadataPrefix, $resumptionToken) = @_;
 841
 842    my $results = [];
 843    my @allrows = ();
 844    $resumptionToken = '';
 845
 846    ( \@allrows, $resumptionToken, $metadataPrefix, {} );
 847 }
 848
 849
 850 # main loop to process parameters and call appropriate verb handler
 851 sub Run
 852 {
 853    my ($self) = @_;
 854
 855    if (! exists $self->{'cgi'})
 856    {
 857 ## PJ 20071021
 858       ##$self->{'cgi'} = new Pure::EZCGI;
 859       $self->{'cgi'} = new CGI;
 860    }
 861    $self->{'verb'} = $self->{'cgi'}->param ('verb');
 862
 863    # check for illegal verb
 864    if (($self->{'verb'} ne 'Identify') &&
 865        ($self->{'verb'} ne 'ListMetadataFormats') &&
 866        ($self->{'verb'} ne 'ListSets') &&
 867        ($self->{'verb'} ne 'ListIdentifiers') &&
 868        ($self->{'verb'} ne 'GetRecord') &&
 869        ($self->{'verb'} ne 'ListRecords'))
 870    {
 871       print $self->Error ('badVerb', 'illegal OAI verb');
 872    }
 873    else
 874    {
 875       # check for illegal parameters
 876       my $aiv = $self->ArgumentisValid;
 877       if ($aiv ne '')
 878       {
 879          print $aiv;
 880       }
 881       else
 882       {
 883          # run appropriate handler procedure
 884          if ($self->{'verb'} eq 'Identify')
 885          { print $self->Identify; }
 886          elsif ($self->{'verb'} eq 'ListMetadataFormats')
 887          { print $self->ListMetadataFormats; }
 888          elsif ($self->{'verb'} eq 'GetRecord')
 889          { print $self->GetRecord; }
 890          elsif ($self->{'verb'} eq 'ListSets')
 891          { print $self->ListSets; }
 892          elsif ($self->{'verb'} eq 'ListRecords')
 893          { print $self->ListRecords; }
 894          elsif ($self->{'verb'} eq 'ListIdentifiers')
 895          { print $self->ListIdentifiers; }
 896       }
 897    }
 898 }
 899
 900
 901 1;
 902
 903
 904 # HISTORY
 905 #
 906 # 2.01
 907 #  fixed ($identifier) error
 908 #  added status to FormatRecord
 909 # 2.02
 910 #  added metadataPrefix to GetRecord hander
 911 # 3.0
 912 #  converted to OAI2.0 alpha1
 913 # 3.01
 914 #  converted to OAI2.0 alpha2
 915 # 3.02
 916 #  converted to OAI2.0 alpha3
 917 # 3.03
 918 #  converted to OAI2.0 beta1
 919 # 3.04
 920 #  converted to OAI2.0 beta2
 921 #  added better argument handling
 922 # 3.05
 923 #  polished for OAI2.0