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