SRU-1.01/0000775000175000017500000000000012230305477011401 5ustar bricasbricasSRU-1.01/Changes0000644000175000017500000000557712230305477012710 0ustar bricasbricasRevision history for perl module SRU 1.01 2013-10-18 - Move POD tests to release testing (RT #89420) 1.00 2013-01-22 - Add asURI() method to SRU::Request - SRU::Request constructor now supports PSGI - CQL error handling is now in CQL::Parser 0.99 2009-12-02 - remove use of UNIVERSAL->import 0.98 2009-11-20 - repackaged with a new version of Module::Install 0.97 2008-03-05 - switched to Module::Install and repackaged 0.96 2007-02-26 - repackaged -- no functional changes 0.95 2006-10-21 - doc fixes 0.94 2006-10-20 - removed dep on CGI::Application (it's only used for SRU::Server) - converted Catalyst::Plugin::SRU to a controller base class 0.93 2006-01-09 - added better cql diagnostics for servers (Walter Lewis) - resolve possible method conflict in Catalyst plugin 0.92 2005-12-15 - updated Catalyst plugin for Catalyst 5.5 - pod updates - made SRU::Response::type() more generic - added type() to SRU::Request - use case sensitive names in Catalyst plugin to be consistent with SRU::Server 0.91 2005-10-05 - modified Response/SearchRetrieve.pm to - always return version 1.1 - allow different encoding types - send back extra response data (thanks Xiaorong Xiang and Eric Lease Morgan of the ockham project) 0.90 2005-09-01 - added pod test 0.89 2005-08-09 - added Catalyst plugin - added default namespaces 0.88 2005-02-02 - added resultSetId and resultSetIdleTime to searchRetrieve output 0.87 2005-02-01 - added ability to set numberOfRecords() in searchRetrieve request: thanks Bernd Diekmann 0.86 2005-01-11 - removed diagnostic handling for explain responses that lack version and operator - fixed explain response to use element properly 0.85 2004-12-20 - added diagnostic when a default explain is returned when no operator was specified 0.8 2004-12-17 - renamed SRU::Application to SRU::Server 0.7 2004-12-09 - new tests for exception handling - newFromCGI() now forces ampersands in query string - removed base parameter from request constructors since it wasn't used - fixed nesting problem with in explain response (thanks Eric Morgan) 0.6 2004-12-06 - needed to add SRU::Application to the MANIFEST - require CQL::Parser 0.3 0.5 2004-12-04 - CGI::Application framework courtesy of Brian Cassidy (who now shares ownership of this module). - Updated Makefile.PL to include new dependencies. - Explain is now the default response. - Responses automatically have an echo section added to their XML when using the newFromRequest() factory method. - searchRetrieve and scan requests parse CQL where appropriate using CQL::Parser. 0.4 2004-11-16 - doc fixes and tuneups from Brian Cassidy 0.3 2004-09-05 - fixed SRU::Request::newFromCGI() and added test t/cgi.t - fixed stylesheet handling in response objects - fixed diagnostics handling 0.2 2004-09-05 - updated docs 0.1 2004-09-04 - initial release SRU-1.01/Makefile.PL0000644000175000017500000000305012230305477013347 0ustar bricasbricas use strict; use warnings; use 5.010001; use ExtUtils::MakeMaker 6.30; my %WriteMakefileArgs = ( "ABSTRACT" => "Search and Retrieval by URL", "AUTHOR" => "Ed Summers , Brian Cassidy , Jakob Vo\303\237 ", "BUILD_REQUIRES" => {}, "CONFIGURE_REQUIRES" => { "ExtUtils::MakeMaker" => "6.30" }, "DISTNAME" => "SRU", "EXE_FILES" => [], "LICENSE" => "perl", "NAME" => "SRU", "PREREQ_PM" => { "CQL::Parser" => "1.12", "Carp" => 0, "Class::Accessor" => 0, "URI" => 0, "XML::LibXML" => 0, "XML::Simple" => 0 }, "TEST_REQUIRES" => { "Test::Exception" => 0, "Test::More" => 0 }, "VERSION" => "1.01", "test" => { "TESTS" => "t/*.t" } ); unless ( eval { ExtUtils::MakeMaker->VERSION(6.63_03) } ) { my $tr = delete $WriteMakefileArgs{TEST_REQUIRES}; my $br = $WriteMakefileArgs{BUILD_REQUIRES}; for my $mod ( keys %$tr ) { if ( exists $br->{$mod} ) { $br->{$mod} = $tr->{$mod} if $tr->{$mod} > $br->{$mod}; } else { $br->{$mod} = $tr->{$mod}; } } } unless ( eval { ExtUtils::MakeMaker->VERSION(6.56) } ) { my $br = delete $WriteMakefileArgs{BUILD_REQUIRES}; my $pp = $WriteMakefileArgs{PREREQ_PM}; for my $mod ( keys %$br ) { if ( exists $pp->{$mod} ) { $pp->{$mod} = $br->{$mod} if $br->{$mod} > $pp->{$mod}; } else { $pp->{$mod} = $br->{$mod}; } } } delete $WriteMakefileArgs{CONFIGURE_REQUIRES} unless eval { ExtUtils::MakeMaker->VERSION(6.52) }; WriteMakefile(%WriteMakefileArgs); SRU-1.01/META.yml0000644000175000017500000000140412230305477012647 0ustar bricasbricas--- abstract: 'Search and Retrieval by URL' author: - 'Ed Summers ' - 'Brian Cassidy ' - 'Jakob Voß ' build_requires: Test::Exception: 0 Test::More: 0 configure_requires: ExtUtils::MakeMaker: 6.30 dynamic_config: 0 generated_by: 'Dist::Zilla version 4.300039, CPAN::Meta::Converter version 2.132830' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 name: SRU requires: CQL::Parser: 1.12 Carp: 0 Class::Accessor: 0 URI: 0 XML::LibXML: 0 XML::Simple: 0 perl: v5.10.1 resources: bugtracker: https://github.com/bricas/sru-perl/issues homepage: https://github.com/bricas/sru-perl repository: https://github.com/bricas/sru-perl.git version: 1.01 SRU-1.01/README0000644000175000017500000000043112230305477012255 0ustar bricasbricas This archive contains the distribution SRU, version 1.01: Search and Retrieval by URL This software is copyright (c) 2013 by Ed Summers. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. SRU-1.01/t/0000775000175000017500000000000012230305477011644 5ustar bricasbricasSRU-1.01/t/cgi.t0000644000175000017500000000142312230305477012571 0ustar bricasbricasuse strict; use warnings; use Test::More qw( no_plan ); use CGI; $ENV{ SCRIPT_NAME } = '/cgi-bin/sru.cgi'; $ENV{ SERVER_NAME } = 'www.inkdroid.org'; $ENV{ SCRIPT_FILENAME } = '/usr/local/inkdroid/apache/cgi-bin/sru.cgi'; $ENV{ QUERY_STRING } = 'operation=scan&version=1.1'; $ENV{ SERVER_PORT } = '80'; $ENV{ SERVER_PROTOCOL } = 'HTTP/1.1'; $ENV{ REQUEST_URI } = '/cgi-bin/sru.cgi?operation=scan&version=1.1'; $ENV{ HTTP_HOST } = 'www.inkdroid.org'; $ENV{ REQUEST_METHOD } = 'GET'; my $cgi = CGI->new(); isa_ok( $cgi, 'CGI', 'CGI mock object' ); use_ok( 'SRU::Request' ); ok( ! $SRU::Error, 'no error' ); my $request = SRU::Request->newFromCGI( $cgi ); ok( ! $SRU::Error, 'no error' ); isa_ok( $request, 'SRU::Request::Scan' ); is( $request->version(), '1.1', 'got version' ); 1; SRU-1.01/t/changes.t0000644000175000017500000000020312230305477013432 0ustar bricasbricasuse Test::More; eval 'use Test::CPAN::Changes'; plan skip_all => 'Test::CPAN::Changes required for this test' if $@; changes_ok(); SRU-1.01/t/term.t0000644000175000017500000000214212230305477012775 0ustar bricasbricasuse strict; use warnings; use Test::More qw( no_plan ); use SRU::Utils::XMLTest qw( wellFormedXML ); use_ok( 'SRU::Response::Term' ); MISSING_TERM: { ok( ! $SRU::Error, 'error undefined' ); my $t = SRU::Response::Term->new(); ok( !$t, 'constructor returned undef when missing value attribute' ); is( $SRU::Error,'must supply value parameter in call to new()','error msg'); } OK: { my $t = SRU::Response::Term->new( value => 'Foo Fighter', numberOfRecords => 42, displayTerm => 'Le Fighters de Foo', whereInList => 'inner', extraTermData => 'foo' ); isa_ok( $t, 'SRU::Response::Term' ); is( $t->value(), 'Foo Fighter', 'value()' ); is( $t->numberOfRecords(), 42, 'numberOfRecords()' ); is( $t->displayTerm(), 'Le Fighters de Foo', 'displayTerm()' ); is( $t->whereInList(), 'inner', 'whereInList()' ); is( $t->extraTermData(), 'foo', 'extraTermData()' ); my $xml = $t->asXML(); ok( wellFormedXML($xml), 'asXML() well formed XML' ); } SRU-1.01/t/request.t0000644000175000017500000000223312230305477013517 0ustar bricasbricasuse strict; use warnings; use Test::More; use SRU::Request; my @queries = ( 'operation=scan&version=1.1&scanClause=%2fdc.title%3d%22cat%22&responsePosition=3&maximumTerms=50&stylesheet=http://myserver.com/myStyle', 'operation=explain&version=1.0&recordPacking=xml&stylesheet=http://www.example.com/style.xsl&extraRequestData=123', 'operation=searchRetrieve&version=1.1&query=dc.identifier+%3d%220-8212-1623-6%22&recordSchema=dc&recordPacking=XML&stylesheet=http://myserver.com/myStyle', ); sub normalize_url { my $url = URI->new(shift); my %query = $url->query_form; my @sorted = map { $_ => $query{$_} } sort keys %query; $url->query_form( \@sorted, '&' ); return $url; } sub is_same_url { is normalize_url($_[0]), normalize_url($_[1]), $_[2]; } foreach my $query (@queries) { my $request = SRU::Request->new( { QUERY_STRING => $query } ); my $uri = URI->new( "http://myserver.com/myurl?$query" ); my $base = "http://myserver.com/myurl"; is_same_url( $request->asURI($base), $uri, 'asURI with base'); $uri->host('localhost'); $uri->path('/'); is_same_url( $request->asURI, $uri, 'asURI without base'); } done_testing; SRU-1.01/t/release-pod_coverage.t0000644000175000017500000000047712230305477016112 0ustar bricasbricas BEGIN { unless ($ENV{RELEASE_TESTING}) { require Test::More; Test::More::plan(skip_all => 'these tests are for release candidate testing'); } } use Test::More; eval "use Test::Pod::Coverage 1.00"; plan skip_all => "Test::Pod::Coverage 1.00 required for testing POD coverage" if $@; all_pod_coverage_ok(); SRU-1.01/t/request_searchRetrieve.t0000644000175000017500000000527112230305477016557 0ustar bricasbricasuse strict; use warnings; use Test::More qw( no_plan ); use URI; use XML::Simple; use_ok( 'SRU::Request::SearchRetrieve' ); my $url = 'http://myserver.com/myurl?operation=searchRetrieve&version=1.1&query=dc.identifier+%3d%220-8212-1623-6%22&recordSchema=dc&recordPacking=XML&stylesheet=http://myserver.com/myStyle'; CONSTRUCTOR: { my $request = SRU::Request::SearchRetrieve->new( version => '1.1', query => 'dc.identifier ="0-8212-1623-6"', recordSchema => 'dc', recordPacking => 'XML', stylesheet => 'http://myserver.com/myStyle' ); is( $request->version(), '1.1', 'version()' ); is( $request->query(), 'dc.identifier ="0-8212-1623-6"', 'query()' ); is( $request->recordSchema(), 'dc', 'recordSchema()' ); is( $request->recordPacking(), 'XML', 'recordPacking()' ); is( $request->stylesheet(), 'http://myserver.com/myStyle', 'stylesheet()' ); is( $request->type(), 'searchRetrieve', 'type()' ); } CQL: { my $request = SRU::Request::SearchRetrieve->newFromURI( $url ); my $node = $request->cql(); isa_ok( $node, 'CQL::TermNode', 'got CQL node' ); is( $node->toCQL(), 'dc.identifier = 0-8212-1623-6', 'correct CQL' ); } FROM_URI: { my $uri = URI->new( $url ); my $request = SRU::Request->newFromURI( $uri ); isa_ok( $request, 'SRU::Request::SearchRetrieve' ); is( $request->version(), '1.1', 'version()' ); is( $request->query(), 'dc.identifier ="0-8212-1623-6"', 'query()' ); is( $request->recordSchema(), 'dc', 'recordSchema()' ); is( $request->recordPacking(), 'XML', 'recordPacking()' ); is( $request->stylesheet(), 'http://myserver.com/myStyle', 'stylesheet()' ); } FROM_STRING: { my $request = SRU::Request->newFromURI( $url ); isa_ok( $request, 'SRU::Request::SearchRetrieve' ); is( $request->version(), '1.1', 'version()' ); is( $request->query(), 'dc.identifier ="0-8212-1623-6"', 'query()' ); is( $request->recordSchema(), 'dc', 'recordSchema()' ); is( $request->recordPacking(), 'XML', 'recordPacking()' ); is( $request->stylesheet(), 'http://myserver.com/myStyle', 'stylesheet()' ); } AS_XML: { my $request = SRU::Request->newFromURI( $url ); my $xml = XMLin( $request->asXML(), KeepRoot => 1 ); is( $xml->{echoedSearchRetrieveRequest}{version}, '1.1', 'found version in XML' ); is( $xml->{echoedSearchRetrieveRequest}{query}, 'dc.identifier ="0-8212-1623-6"', 'found query in XML' ); is( $xml->{echoedSearchRetrieveRequest}{recordPacking}, 'XML', 'found recordPacking in XML' ); is( $xml->{echoedSearchRetrieveRequest}{stylesheet}, 'http://myserver.com/myStyle', 'found stylesheet in XML' ); } SRU-1.01/t/request_scan.t0000644000175000017500000000457012230305477014531 0ustar bricasbricasuse strict; use warnings; use Test::More qw( no_plan ); use URI; use XML::Simple; use_ok( "SRU::Request" ); use_ok( "SRU::Request::Scan" ); my $url = 'http://myserver.com/myurl?operation=scan&version=1.1&scanClause=%2fdc.title%3d%22cat%22&responsePosition=3&maximumTerms=50&stylesheet=http://myserver.com/myStyle'; CONSTRUCTOR: { my $request = SRU::Request::Scan->new( version => '1.1', scanClause => '/dc.title="cat"', responsePosition => 3, maximumTerms => 50, stylesheet => 'http://myserver.com/myStyle' ); isa_ok( $request, 'SRU::Request::Scan' ); is( $request->scanClause(), '/dc.title="cat"', 'scanClause()' ); is( $request->responsePosition(), 3, 'responsePosition()' ); is( $request->maximumTerms(), 50, 'maximumTerms()' ); is( $request->stylesheet(), 'http://myserver.com/myStyle', 'stylesheet()' ); is( $request->type(), 'scan', 'type()' ); } FROM_URI: { my $uri = URI->new( $url ); my $request = SRU::Request->newFromURI( $uri ); isa_ok( $request, 'SRU::Request::Scan' ); is( $request->scanClause(), '/dc.title="cat"', 'scanClause()' ); is( $request->responsePosition(), 3, 'responsePosition()' ); is( $request->maximumTerms(), 50, 'maximumTerms()' ); is( $request->stylesheet(), 'http://myserver.com/myStyle', 'stylesheet()' ); } FROM_STRING: { my $request = SRU::Request->newFromURI( $url ); isa_ok( $request, 'SRU::Request::Scan' ); is( $request->scanClause(), '/dc.title="cat"', 'scanClause()' ); is( $request->responsePosition(), 3, 'responsePosition()' ); is( $request->maximumTerms(), 50, 'maximumTerms()' ); is( $request->stylesheet(), 'http://myserver.com/myStyle', 'stylesheet()' ); } AS_XML: { my $request = SRU::Request::Scan->newFromURI( $url ); my $xml = XMLin( $request->asXML(), KeepRoot => 1 ); is( $xml->{echoedScanRequest}{version}, '1.1', 'found version in XML' ); is( $xml->{echoedScanRequest}{scanClause}, '/dc.title="cat"', 'scanClause found in XML' ); is( $xml->{echoedScanRequest}{responsePosition}, '3', 'responsePosition found in XML' ); is( $xml->{echoedScanRequest}{maximumTerms}, '50', 'maximum terms found in XML' ); is( $xml->{echoedScanRequest}{stylesheet}, 'http://myserver.com/myStyle', 'styleSheet found in XML' ); } SRU-1.01/t/record.t0000644000175000017500000000231412230305477013305 0ustar bricasbricasuse strict; use warnings; use Test::More tests => 9; use Test::Exception; use SRU::Utils::XMLTest; use_ok( 'SRU::Response::Record' ); BAD_CONSTRUCT: { ## missing recordSchema and recordData throws_ok { SRU::Response::Record->new() } qr/must supply recordSchema/, 'must supply recordData and recordSchema'; ## missing recordData throws_ok { SRU::Response::Record->new( recordSchema => 'foo' ) } qr/must supply recordData/, 'must supply recordData'; ## missing recordSchema throws_ok { SRU::Response::Record->new( recordData => 'foo' ) } qr/must supply recordSchema/, 'must supply recordSchema'; } OK_CONSTRUCT: { my $xml = "Huckleberry Finn"; my $r = SRU::Response::Record->new( recordSchema => 'info:srw/schema/1/dc-v1.1', recordData => $xml ); isa_ok( $r, 'SRU::Response::Record' ); is( $r->recordData(), $xml, 'recordData()' ); is( $r->recordSchema(), 'info:srw/schema/1/dc-v1.1', 'recordSchema()' ); is( $r->recordPacking(), 'xml', 'default recordPacking is xml' ); $xml = $r->asXML(); ok( wellFormedXML($xml), 'asXML() well formed' ); } SRU-1.01/t/response_scan.t0000644000175000017500000000352412230305477014675 0ustar bricasbricasuse strict; use warnings; use Test::More qw( no_plan ); use SRU::Utils::XMLTest; use_ok( 'SRU::Request' ); use_ok( 'SRU::Response' ); use_ok( 'SRU::Response::Term' ); MISSING_VERSION: { my $url = 'http://myserver.com/myurl?operation=scan&scanClause=%2fdc.title%3d%22cat%22&responsePosition=3&maximumTerms=50&stylesheet=http://myserver.com/myStyle'; my $request = SRU::Request->newFromURI( $url ); isa_ok( $request, 'SRU::Request::Scan' ); my $response = SRU::Response->newFromRequest( $request ); isa_ok( $response, 'SRU::Response::Scan' ); is( $response->type(), 'scan', 'type()' ); my $diags = $response->diagnostics(); is( @$diags, 1, 'got one diagnostic' ); is( $diags->[0]->details(), 'version', 'got expected error' ); } OK: { my $url = 'http://myserver.com/myurl/?operation=scan&version=1.1&scanClause=%2fdc.title%3d%22cat%22&responsePosition=3&maximumTerms=50&stylesheet=http://myserver.com/myStyle'; my $request = SRU::Request->newFromURI( $url ); isa_ok( $request, 'SRU::Request::Scan' ); my $response = SRU::Response->newFromRequest( $request ); isa_ok( $response, 'SRU::Response::Scan' ); my $diags = $response->diagnostics(); is( @$diags, 0, 'no diagnostic messages' ); ## add a few terms to the response $response->addTerm( SRU::Response::Term->new( value => 'Apollo Creed' ) ); $response->addTerm( SRU::Response::Term->new( value => 'Rocky Balboa' ) ); ## check the xml my $xml = $response->asXML(); ok( wellFormedXML( $xml ), 'asXML() well formed XML' ); ## rudimentary check for the terms like( $xml, qr{Apollo Creed}, 'found term 1' ); like( $xml, qr{Rocky Balboa}, 'found term 2' ); like( $xml, qr{\Q\E}, 'found stylsheet in XML' ); } SRU-1.01/t/release-pod.t0000644000175000017500000000043712230305477014233 0ustar bricasbricas BEGIN { unless ($ENV{RELEASE_TESTING}) { require Test::More; Test::More::plan(skip_all => 'these tests are for release candidate testing'); } } use Test::More; eval "use Test::Pod 1.00"; plan skip_all => "Test::Pod 1.00 required for testing POD" if $@; all_pod_files_ok(); SRU-1.01/t/diagnostic.t0000644000175000017500000000122412230305477014152 0ustar bricasbricasuse strict; use warnings; use Test::More qw( no_plan ); use SRU::Utils::XMLTest; use_ok( 'SRU::Response::Diagnostic' ); my $d = SRU::Response::Diagnostic->new( uri => 'info:srw/diagnostic/1/7', details => 'version', message => 'Version parameter missing. When you explicitly specify an explain, searchRetrieve, or scan operation you are suppose to send along a version parameter.' ); isa_ok( $d, 'SRU::Response::Diagnostic' ); is( $d->uri(), 'info:srw/diagnostic/1/7', 'uri()' ); is( $d->details(), 'version', 'details()' ); like( $d->message(), qr/Version parameter missing/, 'message()' ); ok( wellFormedXML( $d->asXML() ), 'asXML()' ); SRU-1.01/t/cgi_app.t0000644000175000017500000000321312230305477013430 0ustar bricasbricasuse strict; use warnings; use Test::More; use CGI; use lib qw( t/lib ); eval "use CGI::Application;"; plan skip_all => "install CGI::Application if you want to use SRU::Server" if $@; ## flag to CGI::Application so that run() returns output ## rather than printing it. $ENV{ CGI_APP_RETURN_ONLY } = 1; plan tests => 10; INHERITANCE: { require MyApp; my $app = MyApp->new(); isa_ok( $app, 'MyApp' ); isa_ok( $app, 'CGI::Application' ); } DEFAULT_RESPONSE: { my $app = MyApp->new(); $app->query( CGI->new() ); my $content = $app->run(); like( $content, qr|^Content-Type: text/xml|, 'content-type' ); like( $content, qr|bar|, 'contains record' ); like( $app->run(), qr/new(); $app->query( CGI->new( 'operation=explain' ) ); like( $app->run(), qr/new(); $app->query( CGI->new( 'operation=scan&version=1' ) ); like( $app->run(), qr/new(); $app->query( CGI->new( 'operation=searchRetrieve&version=1' ) ); like( $app->run(), qr/new(); $app->query( CGI->new( 'operation=searchRetrieve&version=1&query=dc.title > ""' ) ); my $content = $app->run(); like( $content, qr/info:srw/diagnostic/1/27|, 'contains proper cql error' ); } SRU-1.01/t/request_explain.t0000644000175000017500000000353312230305477015243 0ustar bricasbricasuse strict; use warnings; use Test::More qw( no_plan ); use URI; use XML::Simple; use_ok( 'SRU::Request::Explain' ); my $url = 'http://myserver.com/myurl?operation=explain&version=1.0&recordPacking=xml&stylesheet=http://www.example.com/style.xsl&extraRequestData=123'; CONSTRUCTOR: { my $request = SRU::Request::Explain->new( version => '1.0', recordPacking => 'xml', stylesheet => 'http://www.example.com/style.xsl' ); is( $request->version(), '1.0', 'version()' ); is( $request->recordPacking(), 'xml', 'recordPacking()' ); is( $request->stylesheet(), 'http://www.example.com/style.xsl', 'stylesheet()'); is( $request->type(), 'explain', 'type()' ); } FROM_URI: { my $uri = URI->new( $url ); my $request = SRU::Request->newFromURI( $uri ); is( $request->version(), '1.0', 'version()' ); is( $request->recordPacking(), 'xml', 'recordPacking()' ); is( $request->stylesheet(), 'http://www.example.com/style.xsl', 'stylesheet()'); } DEFAULT_RESPONSE: { my $request = SRU::Request->newFromURI( 'http://myserver.com/myurl' ); isa_ok( $request, 'SRU::Request::Explain' ); } FROM_STRING: { my $request = SRU::Request->newFromURI( $url ); is( $request->version(), '1.0', 'version()' ); is( $request->recordPacking(), 'xml', 'recordPacking()' ); is( $request->stylesheet(), 'http://www.example.com/style.xsl', 'stylesheet()'); } XML: { my $request = SRU::Request->newFromURI( $url ); my $xml = XMLin( $request->asXML(), KeepRoot => 1 ); is( $xml->{echoedExplainRequest}{version}, '1.0', 'got version in XML' ); is( $xml->{echoedExplainRequest}{recordPacking}, 'xml', 'got recordPacking in XML' ); is( $xml->{echoedExplainRequest}{stylesheet}, 'http://www.example.com/style.xsl', 'got stylesheet in XML' ); } SRU-1.01/t/response_searchRetrieve.t0000644000175000017500000000655212230305477016730 0ustar bricasbricasuse strict; use warnings; use Test::More qw( no_plan ); use URI; use SRU::Utils::XMLTest qw( wellFormedXML ); use_ok( 'SRU::Request::SearchRetrieve' ); use_ok( 'SRU::Response' ); OK: { my $url = "http://myserver.com/myurl/?operation=searchRetrieve&version=1.1&query=dc.identifier+%3d%220-8212-1623-6%22&recordSchema=dc&recordPacking=XML&stylesheet=http://myserver.com/myStyle"; my $request = SRU::Request->newFromURI( $url ); isa_ok( $request, 'SRU::Request::SearchRetrieve' ); my $response = SRU::Response->newFromRequest( $request ); isa_ok( $response, 'SRU::Response::SearchRetrieve' ); is( $response->type(), 'searchRetrieve', 'type()' ); my $xml = $response->asXML(); ok( wellFormedXML($xml), "asXML()" ); is( $response->numberOfRecords(), 0, 'numberOfRecords is 0' ); ## add record #1 $response->addRecord( SRU::Response::Record->new( recordSchema => 'info:srw/schema/1/dc-v1.1', recordData => 'Huckleberry Finn' ) ); is( $response->numberOfRecords(), 1, 'numberOfRecords is 1' ); ## add record #2 $response->addRecord( SRU::Response::Record->new( recordSchema => 'info:srw/schema/1/dc-v1.1&', recordData => 'Huckle & berry & Finn' ) ); is( $response->numberOfRecords(), 2, 'numberOfRecords is 2' ); $xml = $response->asXML(); like( $xml, qr{21}, 'recordPosition() 1' ); like( $xml, qr{2}, 'recordPosition() 2' ); ok( wellFormedXML($xml), 'asXML() w/ records well formed' ); like( $xml, qr{\Q\E}, 'found stylsheet in XML' ); ## look for xCQL like( $xml, qr//, 'found xQuery tag' ); } SET_NUMBER_OF_RECORDS: { my $url = "http://myserver.com/myurl/?operation=searchRetrieve&version=1.1&query=dc.identifier+%3d%220-8212-1623-6%22&recordSchema=dc&recordPacking=XML&stylesheet=http://myserver.com/myStyle"; my $request = SRU::Request->newFromURI( $url ); isa_ok( $request, 'SRU::Request::SearchRetrieve' ); my $response = SRU::Response->newFromRequest( $request ); isa_ok( $response, 'SRU::Response::SearchRetrieve' ); is( $response->type(), 'searchRetrieve', 'type()' ); is( $response->numberOfRecords(), 0, 'numberOfRecords is 0' ); ## add record #1 $response->addRecord( SRU::Response::Record->new( recordSchema => 'info:srw/schema/1/dc-v1.1', recordData => 'Huckleberry Finn' ) ); is( $response->numberOfRecords(), 1, 'numberOfRecords is 1' ); ## add record #2 $response->addRecord( SRU::Response::Record->new( recordSchema => 'info:srw/schema/1/dc-v1.1&', recordData => 'Huckle & berry & Finn' ) ); is( $response->numberOfRecords(), 2, 'numberOfRecords is 2' ); ## explicitly set number of records $response->numberOfRecords( 500 ); is( $response->numberOfRecords(), 500, 'explicit set of numberOfRecords' ); } SRU-1.01/t/response_explain.t0000644000175000017500000000310412230305477015403 0ustar bricasbricasuse strict; use warnings; use Test::More tests => 11; use Test::Exception; use SRU::Utils::XMLTest qw( wellFormedXML ); use_ok( 'SRU::Request::Explain' ); use_ok( 'SRU::Response' ); OK: { my $url = 'http://myserver.com/myurl?operation=explain&version=1.0&recordPacking=xml&stylesheet=http://www.example.com/style.xsl&extraRequestData=123'; my $request = SRU::Request->newFromURI( $url ); isa_ok( $request, 'SRU::Request::Explain' ); is( $request->stylesheet(), 'http://www.example.com/style.xsl', 'stylesheet()' ); my $response = SRU::Response->newFromRequest( $request ); isa_ok( $response, 'SRU::Response::Explain' ); is( $response->type(), 'explain', 'type()' ); $response->record( SRU::Response::Record->new( recordSchema => 'http://explain.z3950.org/dtd/2.0/', recordData => 'bar' ) ); my $xml = $response->asXML(); like( $xml, qr{bar}, 'found recordData' ); like( $xml, qr{\Q\E}, 'found stylsheet in XML' ); ok( wellFormedXML($xml), "asXML()" ); } INVALID_RECORD: { my $url = 'http://myserver.com/myurl?operation=explain'; my $request = SRU::Request->newFromURI( $url ); isa_ok( $request, 'SRU::Request::Explain' ); my $response = SRU::Response->newFromRequest( $request ); throws_ok { $response->record( 'Explain info here' ) } qr/must pass in a SRU::Response::Record/, "caught invalid parameter passed to record()"; } SRU-1.01/t/lib/0000775000175000017500000000000012230305477012412 5ustar bricasbricasSRU-1.01/t/lib/MyApp.pm0000644000175000017500000000064012230305477013774 0ustar bricasbricas############################ ## a harmless SRU::Server subclass package MyApp; use base qw( SRU::Server ); sub explain { my $self = shift; my $response = $self->response(); $response->record( SRU::Response::Record->new( recordSchema => 'http://explain.z3950.org/dtd/2.0/', recordData => 'bar' ) ); } sub searchRetrieve { } sub scan { } 1; SRU-1.01/MANIFEST0000644000175000017500000000134112230305477012527 0ustar bricasbricasChanges LICENSE MANIFEST META.yml Makefile.PL README lib/Catalyst/Controller/SRU.pm lib/SRU.pm lib/SRU/Request.pm lib/SRU/Request/Explain.pm lib/SRU/Request/Scan.pm lib/SRU/Request/SearchRetrieve.pm lib/SRU/Response.pm lib/SRU/Response/Diagnostic.pm lib/SRU/Response/Explain.pm lib/SRU/Response/Record.pm lib/SRU/Response/Scan.pm lib/SRU/Response/SearchRetrieve.pm lib/SRU/Response/Term.pm lib/SRU/Server.pm lib/SRU/Utils.pm lib/SRU/Utils/XML.pm lib/SRU/Utils/XMLTest.pm t/cgi.t t/cgi_app.t t/changes.t t/diagnostic.t t/lib/MyApp.pm t/record.t t/release-pod.t t/release-pod_coverage.t t/request.t t/request_explain.t t/request_scan.t t/request_searchRetrieve.t t/response_explain.t t/response_scan.t t/response_searchRetrieve.t t/term.t SRU-1.01/lib/0000775000175000017500000000000012230305477012147 5ustar bricasbricasSRU-1.01/lib/SRU.pm0000644000175000017500000001037712230305477013164 0ustar bricasbricaspackage SRU; { $SRU::VERSION = '1.01'; } #ABSTRACT: Search and Retrieval by URL use strict; use warnings; 1; __END__ =pod =head1 NAME SRU - Search and Retrieval by URL =head1 SYNOPSIS ## a simple CGI example use SRU::Request; use SRU::Response; ## create CGI object my $cgi = CGI->new(); ## create a SRU request object from the CGI object my $request = SRU::Request->newFromCGI( $cgi ); ## create a SRU response based from the request my $response = SRU::Response->newFromRequest( $request ); if ( $response->type() eq 'explain' ) { ... } elsif ( $response->type() eq 'scan' ) { ... } elsif ( $response->type() eq 'searchRetrieve' ) { ... } ## print out the response print $cgi->header( -type => 'text/xml' ); print $response->asXML(); =head1 DESCRIPTION The SRU package provides a framework for working with the Search and Retrieval by URL (SRU) protocol developed by the Library of Congress. SRU defines a web service for searching databases containing metadata and objects. SRU often goes under the name SRW which is a SOAP version of the protocol. You can think of SRU as a RESTful version of SRW, since all the requests are simple URLs instead of XML documents being sent via some sort of transport layer. You might be interested in SRU if you want to provide a generic API for searching a data repository and a mechanism for returning metadata records. SRU defines three verbs: explain, scan and searchRetrieve which define the requests and responses in a SRU interaction. This set of modules attempts to provide a framework for building an SRU service. The distribution is made up of two sets of Perl modules: modules in the SRU::Request::* namespace which represent the three types of requests; and modules in the SRU::Response::* namespace which represent the various responses. Typical usage is that a request object is created using a factory method in the SRU::Request module. The factory is given either a URI or a CGI object for the HTTP request. SRU::Request will look at the URI and build the appropriate request object: SRU::Request::Explain, SRU::Request::Scan or SRU::Request::SearchRetrieve. Once you've got a request object you can build a response object by using the factory method newFromRequest() in SRU::Request. This method will examine the request and build the corresponding result object which you can then populate with result data appropriately. When you are finished populating the response object with results you can call asXML() on it to get the full XML for your response. To understand the meaning of the various requests and their responses you'll want to read the docs at the Library of Congress. A good place to start is this simple introductory page: http://www.loc.gov/standards/sru/simple.html For more information about working with the various request and response objects in this distribution see the POD in the individual packages: =over 4 =item * L =item * L =item * L =item * L =item * L =item * L =item * L =item * L =item * L =back Questions and comments are more than welcome. This software was developed as part of a National Science Foundation grant for building distributed library systems in the Ockham Project. More about Ockham can be found at http://www.ockham.org. =head1 DEPENDENCIES To use L and L, one must install L and L, respectively. In a future release L might be moved to an independent module. =head1 TODO =over 4 =item * create a client (SRU::Client) =item * allow searchRetrieve responses to be retrieved as RSS =item * make sure SRU::Server can function like real-world SRU interfaces =item * handle CQL parsing errors =item * better argument checking in response constructors =back =head1 AUTHORS Ed Summers =cut =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 by Ed Summers. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut SRU-1.01/lib/SRU/0000775000175000017500000000000012230305477012620 5ustar bricasbricasSRU-1.01/lib/SRU/Request/0000775000175000017500000000000012230305477014250 5ustar bricasbricasSRU-1.01/lib/SRU/Request/Scan.pm0000644000175000017500000000341312230305477015471 0ustar bricasbricaspackage SRU::Request::Scan; { $SRU::Request::Scan::VERSION = '1.01'; } #ABSTRACT: A class for representing SRU scan requests use strict; use warnings; use base qw( Class::Accessor SRU::Request ); use SRU::Utils qw( error ); sub new { my ($class,%args) = @_; return $class->SUPER::new( \%args ); } my @validParams = qw( version scanClause responsePosition maximumTerms stylesheet extraRequestData ); sub validParams { return @validParams; } SRU::Request::Scan->mk_accessors( @validParams ); sub cql { my $self = shift; my $clause = $self->scanClause(); return '' unless $clause; my $node; my $parser = CQL::Parser->new(); eval { $node = $parser->parse( $clause ) }; return $node; } 1; __END__ =pod =head1 NAME SRU::Request::Scan - A class for representing SRU scan requests =head1 SYNOPSIS ## creating a new request my $request = SRU::Request::Scan->new(); =head1 DESCRIPTION SRU::Request::Scan is a class for representing SRU 'scan' requests. =head1 METHODS =head2 new() The constructor, which you can pass the parameters: version, scanClause responsePosition, maximumTerms, stylesheet, extraRequestData. my $request = SRU::Request::Explain->new( version => '1.1', scanClause => 'horses', ); =cut =head2 version() =head2 scanClause() =head2 responsePosition() =head2 maximumTerms() =head2 stylesheet() =head2 extraRequestData() =cut =head2 validParams() =cut =head2 cql() Fetch the root node of the CQL parse tree for the scan clause. =cut =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 by Ed Summers. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut SRU-1.01/lib/SRU/Request/SearchRetrieve.pm0000644000175000017500000000401612230305477017520 0ustar bricasbricaspackage SRU::Request::SearchRetrieve; { $SRU::Request::SearchRetrieve::VERSION = '1.01'; } #ABSTRACT: A class for representing SRU searchRetrieve requests use strict; use warnings; use base qw( Class::Accessor SRU::Request ); use SRU::Utils qw( error ); use CQL::Parser; sub new { my ($class,%args) = @_; return SRU::Request::SearchRetrieve->SUPER::new( \%args ); } my @validParams = qw( version query startRecord maximumRecords recordPacking recordSchema recordXPath resultSetTTL sortKeys stylesheet extraRequestData ); sub validParams { return @validParams }; SRU::Request::SearchRetrieve->mk_accessors( @validParams ); sub cql { my $self = shift; my $query = $self->query(); return '' unless $query; my $node; my $parser = CQL::Parser->new(); eval { $node = $parser->parse( $query ) }; return $node; } 1; __END__ =pod =head1 NAME SRU::Request::SearchRetrieve - A class for representing SRU searchRetrieve requests =head1 SYNOPSIS ## creating a new request my $request = SRU::Request::SearchRetrieve->new( version => '1.1', query => 'kirk and spock' ); =head1 DESCRIPTION =head1 METHODS =head2 new() The constructor which you can pass the following parameters: version, query, startRecord, maximumRecords, recordPacking, recordSchema, recordXPath, resultSetTTL, sortKeys, stylesheet, extraRequestData. The version and query parameters are mandatory. =cut =head2 version() =head2 query() =head2 startRecord() =head2 maximumRecords() =head2 recordPacking() =head2 recordSchema() =head2 recordXPath() =head2 resultSetTTL() =head2 sortKeys() =head2 stylesheet() =head2 extraRequestData() =cut =head2 validParams() =cut =head2 cql() Fetch the root node of the CQL parse tree for the query. =cut =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 by Ed Summers. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut SRU-1.01/lib/SRU/Request/Explain.pm0000644000175000017500000000335012230305477016205 0ustar bricasbricaspackage SRU::Request::Explain; { $SRU::Request::Explain::VERSION = '1.01'; } #ABSTRACT: A class for representing SRU explain requests use strict; use warnings; use base qw( Class::Accessor SRU::Request ); use SRU::Utils qw( error ); sub new { my ($class,%args) = @_; return SRU::Request::Explain->SUPER::new( \%args ); } my @validParams = qw( version recordPacking stylesheet extraRequestData ); # no pod since this is used in SRU::Request sub validParams { return @validParams }; SRU::Request::Explain->mk_accessors( @validParams, 'missingOperator' ); 1; __END__ =pod =head1 NAME SRU::Request::Explain - A class for representing SRU explain requests =head1 SYNOPSIS ## creating a new request my $request = SRU::Request::Explain->new(); =head1 DESCRIPTION SRU::Request::Explain is a class for representing SRU 'explain' requests. Explain requests essentially ask the server to describe its services. =head1 METHODS =head2 new() The constructor, which you can pass the optional parameters parameters: version, recordPacking, stylesheet, and extraRequestData parameters. my $request = SRU::Request::Explain->new( version => '1.1', stylesheet => 'http://www.example.com/styles/mystyle.xslt' ); Normally you'll probably want to use the factory SRU::Response::newFromURI to create requests, instead of calling new() yourself. =cut =head2 version() =head2 recordPacking() =head2 stylesheet() =head2 extraRequestData() =cut =head2 validParams() =cut =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 by Ed Summers. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut SRU-1.01/lib/SRU/Request.pm0000644000175000017500000001204212230305477014603 0ustar bricasbricaspackage SRU::Request; { $SRU::Request::VERSION = '1.01'; } #ABSTRACT: Factories for creating SRU request objects. use strict; use warnings; use URI; use SRU::Request::Explain; use SRU::Request::SearchRetrieve; use SRU::Request::Scan; use SRU::Utils qw( error ); use SRU::Utils::XML qw( escape ); use Scalar::Util qw(reftype); our %PARAMETERS = ( 'explain' => [qw(version recordPacking stylesheet extraRequestData)], 'scan' => [qw(version scanClause responsePosition maximumTerms stylesheet extraRequestData)], 'searchRetrieve' => [qw(version query startRecord maximumRecords recordPacking recordSchema recordXPath resultSetTTL sortKeys stylesheet extraRequestData)] ); sub new { my $class = shift; my %query; if ( @_ % 2 ) { my $q = shift; if ( UNIVERSAL::isa( $q, 'CGI' ) ) { ## we must have ampersands between query string params, but lets ## make sure we don't screw anybody else up my $saved = $CGI::USE_PARAM_SEMICOLONS; $CGI::USE_PARAM_SEMICOLONS = 0; $q = $q->self_url; $CGI::USE_PARAM_SEMICOLONS = $saved; } elsif ( (reftype $q // '') eq 'HASH' ) { $q = "http://example.org/?" . $q->{QUERY_STRING}; } if ( ! UNIVERSAL::isa( $q, 'URI' ) ) { $q = URI->new($q); } if ( UNIVERSAL::isa( $q, 'URI' ) ) { %query = $q->query_form; } else { return error( "invalid uri: $q" ) } } else { %query = @_; } my $operation = $query{operation} || 'explain'; my $request; if ( $operation eq 'scan' ) { $request = SRU::Request::Scan->new( %query ); } elsif ( $operation eq 'searchRetrieve' ) { $request = SRU::Request::SearchRetrieve->new( %query ); } elsif ( $operation eq 'explain' ) { $request = SRU::Request::Explain->new( %query ); } else { $request = SRU::Request::Explain->new( %query ); $request->missingOperator(1); } return $request; } *newFromURI = *new; *newFromCGI = *new; sub asXML { my $self = shift; ## extract the type of request from the type of object my ($type) = ref($self) =~ /^SRU::Request::(.*)$/; $type = "echoed${type}Request"; ## build the xml my $xml = "<$type>"; ## add xml for each param if it is available foreach my $param ( $self->validParams() ) { $xml .= "<$param>" . escape($self->$param) . "" if $self->$param; } ## add XCQL if appropriate if ( $self->can( 'cql' ) ) { my $cql = $self->cql(); if ( $cql ) { my $xcql = $cql->toXCQL(0); chomp( $xcql ); $xcql =~ s/>\n *new($base // "http://localhost/"); my %query = $uri->query_form; $query{operation} = $self->type; no strict 'refs'; foreach (@{ $PARAMETERS{ $self->type } }) { $query{$_} = $self->$_ if defined $self->$_; } $uri->query_form( \%query ); return $uri; } sub type { my $self = shift; my $class = ref $self || $self; return lcfirst( ( split( '::', $class ) )[ -1 ] ); } 1; __END__ =pod =head1 NAME SRU::Request - Factories for creating SRU request objects. =head1 SYNOPSIS use SRU::Request; my $request = SRU::Request->newFromURI( $uri ); =head1 DESCRIPTION SRU::Request allows you to create the appropriate SRU request object from a URI object. This allows you to pass in a URI and get back one of SRU::Request::Explain, SRU::Request::Scan or SRU::Request::SearchRetrieve depending on the type of URI that is passed in. See the docs for those classes for more information about what they contain. =head1 METHODS =head2 new( %query | $uri | $cgi | $env ) Create a new request object which is one of: =over 4 =item * SRU::Request::Explain =item * SRU::Request::Scan =item * SRU::Request::SearchRetrieve =back One can pass query parameters as hash, as URL, as L, as L object or as L request. If the request is not formatted properly the call will return undef. The error encountered should be available in $SRU::Error. =cut =head2 newFromURI =head2 newFromCGI Deprecated aliases for C. =cut =head2 asXML() Used to generate , and elements in the response. =cut =head2 asURI( [ $base ] ) Creates a L of this request. The optional C URL, provided as string or as L, is set to C by default. =cut =head2 type() Returns 'searchRetrieve', 'scan' or 'explain' depending on what type of object it is. =cut =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 by Ed Summers. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut SRU-1.01/lib/SRU/Response.pm0000644000175000017500000000562012230305477014755 0ustar bricasbricaspackage SRU::Response; { $SRU::Response::VERSION = '1.01'; } #ABSTRACT: A factory for creating SRU response objects use strict; use warnings; use SRU::Response::Explain; use SRU::Response::Scan; use SRU::Response::SearchRetrieve; use SRU::Utils qw( error ); use SRU::Utils::XML qw( stylesheet ); sub newFromRequest { my ($class,$request) = @_; ## make sure we've got a SRU::Request object my $requestType = ref($request); return error( "must pass in valid SRU::Request object" ) if ! $requestType or ! $request->isa( 'SRU::Request' ); ## return the appropriate response object my $response; if ( $requestType eq 'SRU::Request::Explain' ) { $response = SRU::Response::Explain->new( $request ); } elsif ( $requestType eq 'SRU::Request::Scan' ) { $response = SRU::Response::Scan->new( $request ); } elsif ( $requestType eq 'SRU::Request::SearchRetrieve' ) { $response = SRU::Response::SearchRetrieve->new( $request ); } return $response; } sub type { my $self = shift; my $class = ref $self || $self; return lcfirst( ( split( '::', $class ) )[ -1 ] ); } sub addDiagnostic { my ($self,$d) = @_; push(@{ $self->{diagnostics} }, $d); } sub diagnosticsXML { my $self = shift; my $xml = ''; foreach my $d ( @{ $self->diagnostics() } ) { $xml .= $d->asXML(); } return $xml; } sub stylesheetXML { my $self = shift; if ( $self->stylesheet() ) { return stylesheet( $self->stylesheet() ); } return ''; } 1; __END__ =pod =head1 NAME SRU::Response - A factory for creating SRU response objects =head1 SYNOPSIS my $request = SRU::Request->newFromURI( $uri ); my $response = SRU::Response->newFromRequest( $request ); =head1 DESCRIPTION SRU::Response provides a mechanism for creating the appropriate response object based on a request that is passed in. For example, if you pass in a SRU::Request::Scan object you'll get back a SRU::Response::Scan object with some of the particulars filled in. =head1 METHODS =head2 newFromRequest() The factory method which you must pass in a valid request object: SRU::Request::Explain, SRU::Request::Scan or SRU::Request::SearchRetrieve. If you fail to pass in the correct object you will be returned undef, with an appropriate error stored in $SRU::Error. =cut =head1 INHERITED METHODS SRU::Resonse also serves as the base class for the three response types, and thus provides some general functionality to the child classes. =head2 type() Returns 'searchRetrieve', 'scan' or 'explain' depending on what type of object it is. =cut =head2 addDiagnostic() =cut =head2 diagnosticsXML() =cut =head2 stylesheetXML() =cut =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 by Ed Summers. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut SRU-1.01/lib/SRU/Server.pm0000644000175000017500000000725512230305477014433 0ustar bricasbricaspackage SRU::Server; { $SRU::Server::VERSION = '1.01'; } #ABSTRACT: Respond to SRU requests via CGI::Application use base qw( CGI::Application Class::Accessor ); use strict; use warnings; use SRU::Request; use SRU::Response; use SRU::Response::Diagnostic; use CQL::Parser 1.12; use constant ERROR => -1; use constant DEFAULT => 0; my @modes = qw( explain scan searchRetrieve error_mode ); my @accessors = qw( request response cql ); __PACKAGE__->mk_accessors( @accessors ); sub setup { my $self = shift; $self->run_modes( \@modes ); $self->start_mode( $modes[ DEFAULT ] ); $self->mode_param( 'operation' ); } sub cgiapp_prerun { my $self = shift; my $mode = shift; $CGI::USE_PARAM_SEMICOLONS = 0; $self->request( SRU::Request->newFromURI( $self->query->url( -query => 1 ) ) ); $self->response( SRU::Response->newFromRequest( $self->request ) ); my $cql; if ( $mode eq 'scan' ) { $cql = $self->request->scanClause; } elsif ( $mode eq 'searchRetrieve' ) { $cql = $self->request->query; } if( defined $cql ) { $cql = CQL::Parser->new->parseSafe( $cql ); if (ref $cql) { $self->cql( $cql ); } else { $self->prerun_mode( $modes[ ERROR ] ); $self->response->addDiagnostic( SRU::Response::Diagnostic->newFromCode( $cql ) ); } } unless( $self->can( $mode ) ) { $self->prerun_mode( $modes[ ERROR ] ); $self->response->addDiagnostic( SRU::Response::Diagnostic->newFromCode( 4 ) ); } } sub cgiapp_postrun { my $self = shift; my $output_ref = shift; $self->header_add( -type => 'text/xml' ); $$output_ref = $self->response->asXML; } sub error_mode { } 1; __END__ =pod =head1 NAME SRU::Server - Respond to SRU requests via CGI::Application =head1 SYNOPSIS package MySRU; use base qw( SRU::Server ); sub explain { my $self = shift; # $self->request isa SRU::Request::Explain # $self->response isa SRU::Response::Explain } sub scan { my $self = shift; # $self->request isa SRU::Request::Scan # $self->response isa SRU::Response::Scan # $self->cql is the root node of a CQL::Parser-parsed query } sub searchRetrieve { my $self = shift; # $self->request isa SRU::Request::SearchRetrieve # $self->response isa SRU::Response::SearchRetrieve # $self->cql is the root node of a CQL::Parser-parsed query } package main; MySRU->new->run; =head1 DESCRIPTION This module brings together all of the SRU verbs (explain, scan and searchRetrieve) under a sub-classable object based on CGI::Application. =cut =head1 METHODS =head2 explain This method is used to return an explain response. It is the default method. =head2 scan This method returns a scan response. =head2 searchRetrieve This method returns a searchRetrieve response. =cut =head1 CGI::APPLICATION METHODS =head2 setup Sets the C, C and the default runmode (explain). =cut =head2 cgiapp_prerun Parses the incoming SRU request and if needed, checks the CQL query. =cut =head2 cgiapp_postrun Sets the content type (text/xml) and serializes the response. =cut =head2 error_mode Stub error runmode. =cut =head1 AUTHORS =over 4 =item * Brian Cassidy Ebricas@cpan.orgE =item * Ed Summers Eehs@pobox.comE =item * Jakob Voss Evoss@gbv.deE =back =cut =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 by Ed Summers. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut SRU-1.01/lib/SRU/Utils.pm0000644000175000017500000000141612230305477014256 0ustar bricasbricaspackage SRU::Utils; { $SRU::Utils::VERSION = '1.01'; } #ABSTRACT: Utility functions for SRU use strict; use warnings; use base qw( Exporter ); our @EXPORT_OK = qw( error ); sub error { if ( $_[0] ) { $SRU::Error = $_[0]; }; return; } 1; __END__ =pod =head1 NAME SRU::Utils - Utility functions for SRU =head1 SYNOPSIS use SRU::Utils qw( error ); return error( "error!" ); =head1 DESCRIPTION This is a set of utility functions for the SRU objects. =head1 METHODS =head2 error( $message ) Sets the C<$SRU::Error> message. =cut =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 by Ed Summers. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut SRU-1.01/lib/SRU/Response/0000775000175000017500000000000012230305477014416 5ustar bricasbricasSRU-1.01/lib/SRU/Response/Diagnostic.pm0000644000175000017500000001306012230305477017036 0ustar bricasbricaspackage SRU::Response::Diagnostic; { $SRU::Response::Diagnostic::VERSION = '1.01'; } #ABSTRACT: An SRU diagnostic message use strict; use warnings; use SRU::Utils::XML qw( element elementNoEscape ); use base qw( Class::Accessor ); ## these are standard diagnostics for use in ## newFromCode() our %DIAG = ( ## general diagnostics 1 => 'General System Error', 2 => 'System temporarily unavailable', 3 => 'Authentication error', 4 => 'Unsupported operation', 5 => 'Unsupported version', 6 => 'Unsupported parameter value', 7 => 'Mandatory parameter not supplied', 8 => 'Unsupported parameter', 10 => 'Query syntax error', ## diagnostics relating to CQL 13 => 'Invalid or unsupported use of parentheses', 15 => 'Unsupported context set', 16 => 'Unsupported index', 18 => 'Unsupported combination of indexes', 19 => 'Unsupported relation', 20 => 'Unsupported relation modifier', 21 => 'Unsupported combination of relation modifiers', 22 => 'Unsupported combination of relation and index', 23 => 'Too many characters in term', 24 => 'Unsupported combination of relation and term', 26 => 'Non special character escaped in term', 27 => 'Empty term unsupported', 28 => 'Masking character not supported', 29 => 'Masked words too short', 30 => 'Too many masked characters in term', 31 => 'Anchoring character not supported', 32 => 'Anchoring character in unsupported position', 33 => 'Combination of proximity/adjacency and masking characters not supported', 34 => 'Combination of proximity/adjacency and anchoring characters not supported', 35 => 'Term contains only stopwords', 36 => 'Term ininvalid format for index or relation', 37 => 'Unsupported boolean operator', 38 => 'Too many boolean operators in query', 39 => 'Proximity not supported', 40 => 'Unsupported proximity relation', 41 => 'Unsupported proximity distance', 42 => 'Unsupported proximity unit', 43 => 'Unsupported proximity ordering', 44 => 'Unsupported combination of proximity modifiers', 46 => 'Unsupported boolean modifier', ## Diagnostics relating to result sets 50 => 'Result sets not supported', 51 => 'Result set does not exist', 52 => 'Result set temporarily unavailable', 53 => 'Result sets only supported for retrieval', 55 => 'Combination of result sets with search terms not supported', 58 => 'Result set created with unpredictable partial results available', 59 => 'Result set created with valid partial results available', 60 => 'Result set not created: too man matching records', ## Diagnostics relating to records 61 => 'First record position out of range', 64 => 'Record temporarily unavailable', 65 => 'Record does not exist', 66 => 'Unknown schema for retrieval', 67 => 'Record not available in this schema', 68 => 'Not authorized to send record', 69 => 'Not authorized to send record in this schema', 70 => 'Record too large to send', 71 => 'Unsupported record packing', 72 => 'XPath retrieval unsupported', 73 => 'XPath expression contains unsupported feature', 74 => 'Unable to evaluate XPath expression', ## Diagnostics related to sorting 80 => 'Sort not supported', 82 => 'Unsupported sort sequence', 83 => 'Too many records to sort', 86 => 'Cannot sort: incompatible record formats', 87 => 'Unsupported schema for sort', 88 => 'Unsupported path for sort', 89 => 'Path unsupported for schema', 90 => 'Unsupported direction', 91 => 'Unsupported case', 92 => 'Unsupported missing value action', ## Diagnostics relating to stylesheets 110 => 'Stylesheet not supported', 111 => 'Unsupported stylesheet', ## Diagnostics related to Scan 120 => 'Response portion out of range', ); sub new { my ($class,%args) = @_; my $self = $class->SUPER::new( \%args ); return $self; } sub newFromCode { my ($class,$code,$details) = @_; return error( "no such diagnostic code ($code)" ) if ! exists $DIAG{$code}; my $desc = $DIAG{$code}; return $class->new( uri => 'info:srw/diagnostic/1/' . $code, message => $desc, details => $details ); } SRU::Response::Diagnostic->mk_accessors( qw( uri details message ) ); sub asXML { my $self = shift; my $xml = element( 'uri', $self->uri() ); $xml .= element( 'details', $self->details() ); $xml .= element( 'message', $self->message() ); return elementNoEscape( 'diagnostics', $xml ); } 1; __END__ =pod =head1 NAME SRU::Response::Diagnostic - An SRU diagnostic message =head1 SYNOPSIS my $d = SRU::Response::Diagnostic->new( uri => '', details => '' message => '' ); print $d->asXML(); =head1 DESCRIPTION You probably won't need to use this class since it used interally to store diagnostic messages. =head1 METHOD =cut =head2 new() Pass in uri, details and message attributes as needed. You'll probably find using newFromCode() easier to work with. =cut =head2 newFromCode() Create a SRU::Response::Diagnostic object from a code. For a complete list of the codes see the SRW/SRU documentation. =cut =head2 uri() =head2 details() =head2 message() =cut =head2 asXML() =cut =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 by Ed Summers. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut SRU-1.01/lib/SRU/Response/Scan.pm0000644000175000017500000000631512230305477015643 0ustar bricasbricaspackage SRU::Response::Scan; { $SRU::Response::Scan::VERSION = '1.01'; } #ABSTRACT: A class for representing SRU scan responses use strict; use warnings; use base qw( Class::Accessor SRU::Response ); use SRU::Utils::XML qw( element elementNoEscape ); sub new { my ($class,$request) = @_; return error( "must pass in SRU::Request::Scan object to new()" ) if ! ref($request) or ! $request->isa( 'SRU::Request::Scan' ); my $self = $class->SUPER::new( { version => $request->version(), terms => [], diagnostics => [], extraResponseData => '', echoedScanRequest => $request->asXML(), stylesheet => $request->stylesheet() } ); $self->addDiagnostic( SRU::Response::Diagnostic->newFromCode(7,'version') ) if ! $self->version(); return $self; } sub addTerm { my ($self,$term) = @_; return error( "must pass in SRU::Response::Term object to addTerm()" ) if ! $term->isa( "SRU::Response::Term" ); push( @{ $self->{terms} }, $term ); } SRU::Response::Scan->mk_accessors( qw( version terms diagnostics extraResponseData echoedScanRequest stylesheet ) ); sub asXML { my $self = shift; my $xml = "\n" . $self->stylesheetXML() . "\n" . "\n" . element( 'version', $self->version() ); ## add all the terms if there are some if ( @{ $self->terms() } ) { $xml .= "\n"; foreach my $term ( @{ $self->terms() } ) { $xml .= $term->asXML(); } $xml .= "\n"; } $xml .= $self->diagnosticsXML(); $xml .= elementNoEscape( 'extraResponseData', $self->extraResponseData() ); $xml .= $self->echoedScanRequest(); $xml .= ""; return( $xml ); } 1; __END__ =pod =head1 NAME SRU::Response::Scan - A class for representing SRU scan responses =head1 SYNOPSIS SRU::Response::Scan is a class for representing SRU scan response A scan request allows SRU clients to browse the indexes of an SRU server, much like you would scan the back of a book index to look up particular terms in the body of the book. The scan response bundles up the terms that were looked up. =head1 DESCRIPTION =head1 METHODS =head2 new() The constructor which you must pass a valid SRU::Request::Scan object. =cut =head2 version() =head2 addTerm() Allows you to add terms to the response object. Terms that are passed in must be valid SRU::Response::Term objects. $response->addTerm( SRU::Response::Term->new( value => 'Foo Fighter' ) ); =cut =head2 terms() Get/set the terms associated with the response. Be carefult you must pass in an array ref of SRU::Response::Term objects, or expect an array ref back when getting the values. If you don't bad things will happen. =head2 diagnostics() =head2 extraResponseData() =head2 echoedScanRequest() =cut =head2 asXML() =cut =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 by Ed Summers. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut SRU-1.01/lib/SRU/Response/Term.pm0000644000175000017500000000531212230305477015662 0ustar bricasbricaspackage SRU::Response::Term; { $SRU::Response::Term::VERSION = '1.01'; } #ABSTRACT: A class for representing terms in a Scan response use strict; use warnings; use SRU::Utils qw( error ); use SRU::Utils::XML qw( element elementNoEscape ); use base qw( Class::Accessor ); sub new { my ($class, %args) = @_; return error( "must supply value parameter in call to new()" ) if ! exists $args{value}; return $class->SUPER::new( \%args ); } SRU::Response::Term->mk_accessors( qw( value numberOfRecords displayTerm whereInList extraTermData ) ); sub asXML { my $self = shift; return elementNoEscape( 'term', element( 'value', $self->value() ) . element( 'numberOfRecords', $self->numberOfRecords() ) . element( 'displayTerm', $self->displayTerm() ) . element( 'whereInList', $self->whereInList() ) . elementNoEscape( 'extraTermData', $self->extraTermData() ) ); } 1; __END__ =pod =head1 NAME SRU::Response::Term - A class for representing terms in a Scan response =head1 SYNOPSIS =head1 DESCRIPTION A SRU::Response::Term object bundles up information about a single term contained in a SRU::Response::Scan object. A scan object can contain multiple term objects. =head1 METHODS =head2 new() THe constructor which you must at least pass the value parameter: my $term = SRU::Response::Term->new( term => "Foo Fighter" ); In addition you can pass the numberOfRecords, displayTerm, whereInList, and extraTermData parameters, or set them separately with their accessors. =cut =head2 value() The term exactly as it appears in the index. This term should be able to be sent in a query as is to retrieve the records it derives from. =head2 numberOfRecords() The number of records which would be matched if the index in the request's scanClause was searched with the term in the 'value' field. =head2 displayTerm() A string to display to the end user in place of the term itself. For example this might add back in stopwords which do not appear in the index, or diacritics which have been normalised. =head2 whereInList() A flag to indicate the position of the term within the complete term list. It must be one of the following values: 'first' (the first term), 'last' (the last term), 'only' (the only term) or 'inner' (any other term). =head2 extraTermData() Additional profile specific information. More details are available in the extensions section. =cut =head2 asXML() =cut =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 by Ed Summers. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut SRU-1.01/lib/SRU/Response/SearchRetrieve.pm0000644000175000017500000001260412230305477017670 0ustar bricasbricaspackage SRU::Response::SearchRetrieve; { $SRU::Response::SearchRetrieve::VERSION = '1.01'; } #ABSTRACT: A class for representing SRU searchRetrieve responses use strict; use warnings; use base qw( Class::Accessor SRU::Response ); use SRU::Utils::XML qw( element ); use SRU::Utils qw( error ); use SRU::Response::Record; sub new { my ($class,$request) = @_; return error( 'must pass in a SRU::Request::SearchRetrieve object' ) if ! ref($request) or ! $request->isa( 'SRU::Request::SearchRetrieve' ); my $self = $class->SUPER::new( { version => '1.1', numberOfRecords => 0, records => [], resultSetId => undef, resultSetIdleTime => undef, nextRecordPosition => undef, diagnostics => [], extraResponseData => '', echoedSearchRetrieveRequest => $request->asXML(), stylesheet => $request->stylesheet(), } ); $self->addDiagnostic( SRU::Response::Diagnostic->newFromCode(7,'version') ) if ! $self->version(); $self->addDiagnostic( SRU::Response::Diagnostic->newFromCode(7, 'query') ) if ! $request->query(); return $self; } sub numberOfRecords { my ($self,$num) = @_; if ( $num ) { $self->{numberOfRecords} = $num; } return $self->{numberOfRecords}; } sub addRecord { my ($self,$r) = @_; return if ! $r->isa( 'SRU::Response::Record' ); ## set recordPosition if necessary if ( ! $r->recordPosition() ) { $r->recordPosition( $self->numberOfRecords() + 1 ); } $self->{numberOfRecords}++; push( @{ $self->{records} }, $r ); } SRU::Response::SearchRetrieve->mk_accessors( qw( version records resultSetId resultSetIdleTime nextRecordPosition diagnostics extraResponseData echoedSearchRetrieveRequest stylesheet ) ); sub asXML { my $self = shift; my %args = @_; my $encoding = $args{ encoding }; my $numberOfRecords = $self->numberOfRecords(); my $stylesheet = $self->stylesheetXML(); my $version = element( 'version', $self->version() ); my $diagnostics = $self->diagnosticsXML(); my $echoedSearchRetrieveRequest = $self->echoedSearchRetrieveRequest(); my $resultSetIdleTime = $self->resultSetIdleTime(); my $resultSetId = $self->resultSetId(); my $extraResponseData = '' . $self->extraResponseData() . ''; my $xmltitle; if( $encoding ) { $xmltitle = ""; } else { $xmltitle = ""; } my $xml = < $version $numberOfRecords SEARCHRETRIEVE_XML $xml .= "$resultSetId" if defined($resultSetId); $xml .= "$resultSetIdleTime\n" if defined($resultSetIdleTime); if( $numberOfRecords ) { $xml .= "\n"; ## now add each record foreach my $r ( @{ $self->{records} } ) { $xml .= $r->asXML()."\n"; } $xml .= "\n"; } $xml .= < SEARCHRETRIEVE_XML return $xml; } 1; __END__ =pod =head1 NAME SRU::Response::SearchRetrieve - A class for representing SRU searchRetrieve responses =head1 SYNOPSIS ## create response from the request object my $response = SRU::Response::SearchRetrieve->new( $request ); ## add records to the response foreach my $record ( @records ) { $response->addRecord( $record ); } ## print out the response as XML print $response->asXML(); =head1 DESCRIPTION SRU::Response::SearchRetrieve provides a framework for bundling up the response to a searchRetrieve request. You are responsible for generating the XML representation of the records, and the rest should be taken care of. =head1 METHODS =head2 new() =cut =head2 numberOfRecords() Returns the number of results associated with the object. =cut =head2 addRecord() Add a SRU::Response::Record object to the response. $response->addRecord( $r ); If you don't pass in the right sort of object you'll get back undef and $SRU::Error will be populated appropriately. =cut =head2 records() Gets or sets all the records associated with the object. Be careful with this one :) You must pass in an array ref, and expect an array ref back. =cut =head2 resultSetId() =head2 resultSetIdleTime() =head2 nextRecordPosition() =head2 diagnostics() =head2 extraResponseData() =head2 echoedSearchRetrieveRequest() =cut =head2 asXML() asXML(encoding=>"ISO-8859-1") Returns the object serialized as XML. UTF-8 and UTF-16 are default encodings if you don't pass the encoding parameter. You can define different encoding in order to parse you XML document correctly. =cut =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 by Ed Summers. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut SRU-1.01/lib/SRU/Response/Explain.pm0000644000175000017500000000511512230305477016354 0ustar bricasbricaspackage SRU::Response::Explain; { $SRU::Response::Explain::VERSION = '1.01'; } #ABSTRACT: A class for representing SRU explain responses use strict; use warnings; use base qw( Class::Accessor SRU::Response ); use SRU::Response::Diagnostic; use SRU::Utils qw( error ); use SRU::Utils::XML qw( element ); use Carp qw( croak ); sub new { my ($class,$request) = @_; return error( 'must pass in a SRU::Request::Explain object' ) if ! ref($request) or ! $request->isa( 'SRU::Request::Explain' ); my $self = $class->SUPER::new( { version => $request->version(), record => '', diagnostics => [], extraResponseData => '', echoedExplainRequest => $request->asXML(), stylesheet => $request->stylesheet(), } ); return $self; } SRU::Response::Explain->mk_accessors( qw( version diagnostics extraResponseData echoedExplainRequest stylesheet ) ); sub record { my ( $self, $record ) = @_; if ( $record ) { croak( "must pass in a SRU::Response::Record object" ) if ref($record) ne 'SRU::Response::Record'; $self->{record} = $record; } return $self->{record}; } sub asXML { my $self = shift; my $stylesheet = $self->stylesheetXML(); my $echoedExplainRequest = $self->echoedExplainRequest(); my $diagnostics = $self->diagnosticsXML(); my $record = $self->record() ? $self->record()->asXML() : ''; my $xml = <<"EXPLAIN_XML"; $stylesheet 1.1 $record $echoedExplainRequest $diagnostics EXPLAIN_XML return $xml; } 1; __END__ =pod =head1 NAME SRU::Response::Explain - A class for representing SRU explain responses =head1 SYNOPSIS use SRU::Response; my $response = SRU::Response::Explain->new( $request ); =head1 DESCRIPTION =head1 METHODS =head2 new() The constructor which requires that you pass in a SRU::Request::Explain object. =cut =head2 version() =head2 record() =head2 addDiagnostic() Add a SRU::Response::Diagnostic object to the response. =head2 diagnostics() Returns an array ref of SRU::Response::Diagnostic objects relevant for the response. =head2 extraResponseData() =head2 echoedExplainRequest() =cut =head2 asXML() =cut =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 by Ed Summers. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut SRU-1.01/lib/SRU/Response/Record.pm0000644000175000017500000000630512230305477016174 0ustar bricasbricaspackage SRU::Response::Record; { $SRU::Response::Record::VERSION = '1.01'; } #ABSTRACT: A class for representing a result record in a searchRetrieve response. use strict; use warnings; use SRU::Utils qw( error ); use SRU::Utils::XML qw( element elementNoEscape ); use Carp qw( croak ); use base qw( Class::Accessor ); sub new { my ($class,%args) = @_; ## make sure required parameters are sent croak( "must supply recordSchema in call to new()" ) if ! exists( $args{recordSchema} ); croak( "must supply recordData in call to new()" ) if ! exists( $args{recordData} ); ## set some defaults $args{recordPacking} = 'xml' if ! exists $args{recordPacking}; return $class->SUPER::new( \%args ); } SRU::Response::Record->mk_accessors( qw( recordSchema recordPacking recordData recordPosition extraRecordData ) ); sub asXML { my $self = shift; return elementNoEscape( 'record', element( 'recordSchema', $self->recordSchema() ) . element( 'recordPacking', $self->recordPacking() ) . elementNoEscape( 'recordData', $self->recordData() ) . element( 'recordPosition', $self->recordPosition() ) . element( 'extraRecordData', $self->extraRecordData() ) ); } 1; __END__ =pod =head1 NAME SRU::Response::Record - A class for representing a result record in a searchRetrieve response. =head1 SYNOPSIS my $record = SRU::Response::Record->new(); $record->recordData( 'Huck Finn' ); $response->addRecord( $record ); =head1 DESCRIPTION SRU::Response::Record is used to bundle up the information about a particular metadata record in a SRU::Response::SearchRetrieve object. Typically you'll construct a record object and add it to the SearchRetrieve response. =head1 METHODS =head2 new() You must supply the recordSchema and recordData parameters. recordPacking, recordPosition, and extraRecordData may also be supplied. my $record = SRU::Response::Record->new( recordSchema => 'info:srw/schema/1/dc-v1.1', recordData => 'Huckleberry Finn' ); =head2 recordSchema() The URI identifier of the XML schema in which the record is encoded. Although the request may use the server's assigned short name, the response must always be the full URI. =head2 recordData() The record itself, either as a string or embedded XML. If would like to pass an object in here you may do so as long as it imlements the asXML() method. =head2 recordPacking() The packing used in recordData, as requested by the client or the default: "XML". =head2 recordPosition() The position of the record within the result set. If you don't pass this in recordPosition will be automaticlly calculated for you when add or retrieve a record from a SRU::Response::SearchRetrieve object. =head2 extraRecordData() Any extra data associated with the record. See the section on extensions for more information. =cut =head2 asXML() =cut =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 by Ed Summers. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut SRU-1.01/lib/SRU/Utils/0000775000175000017500000000000012230305477013720 5ustar bricasbricasSRU-1.01/lib/SRU/Utils/XML.pm0000644000175000017500000000305412230305477014716 0ustar bricasbricaspackage SRU::Utils::XML; { $SRU::Utils::XML::VERSION = '1.01'; } #ABSTRACT: XML utility functions for SRU use strict; use warnings; use base qw( Exporter ); our @EXPORT_OK = qw( element elementNoEscape escape stylesheet ); sub element { my ($tag, $text) = @_; return '' if ! defined $text; return "<$tag>" . escape($text) . ""; } sub elementNoEscape { my ($tag, $text) = @_; return '' if ! defined $text; return "<$tag>$text"; } sub escape { my $text = shift || ''; $text =~ s//>/g; $text =~ s/&/&/g; return $text; } sub stylesheet { my $uri = shift; return qq(); } 1; __END__ =pod =head1 NAME SRU::Utils::XML - XML utility functions for SRU =head1 SYNOPSIS use SRU::Utils::XML qw( escape ); return escape( $text ); =head1 DESCRIPTION This is a set of utility functions for use with XML data. =head1 METHODS =head2 element( $tag, $text ) Creates an xml element named C<$tag> containing escaped data (C<$text>). =cut =head2 elementNoEscape( $tag, $text ) Similar to C, except that C<$text> is not escaped. =cut =head2 escape( $text ) Does minimal escaping on C<$text>. =cut =head2 stylesheet( $uri ) A shortcut method to create an xml-stylesheet declaration. =cut =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 by Ed Summers. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut SRU-1.01/lib/SRU/Utils/XMLTest.pm0000644000175000017500000000172412230305477015560 0ustar bricasbricaspackage SRU::Utils::XMLTest; { $SRU::Utils::XMLTest::VERSION = '1.01'; } #ABSTRACT: XML testing utility functions use strict; use warnings; use XML::LibXML; use base qw( Exporter ); our @EXPORT = qw( wellFormedXML ); sub wellFormedXML { my $xml_string = shift; eval { my $parser = XML::LibXML->new; $parser->parse_string($xml_string); }; return $@ ? 0 : 1; } 1; __END__ =pod =head1 NAME SRU::Utils::XMLTest - XML testing utility functions =head1 SYNOPSIS use SRU::Utils::XMLText; ok( wellFormedXML($xml), '$xml is well formed' ); =head1 DESCRIPTION This is a set of utility functions for use with testing XML data. =head1 METHODS =head2 wellFormedXML( $xml ) Checks if C<$xml> is welformed. =cut =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 by Ed Summers. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut SRU-1.01/lib/Catalyst/0000775000175000017500000000000012230305477013733 5ustar bricasbricasSRU-1.01/lib/Catalyst/Controller/0000775000175000017500000000000012230305477016056 5ustar bricasbricasSRU-1.01/lib/Catalyst/Controller/SRU.pm0000644000175000017500000000570312230305477017070 0ustar bricasbricaspackage Catalyst::Controller::SRU; { $Catalyst::Controller::SRU::VERSION = '1.01'; } #ABSTRACT: Dispatch SRU methods with Catalyst use strict; use warnings; use base qw( Catalyst::Controller ); use SRU::Request; use SRU::Response; use SRU::Response::Diagnostic; use CQL::Parser 1.12; sub index : Private { my( $self, $c ) = @_; my $sru_request = SRU::Request->newFromURI( $c->req->uri ); my $sru_response = SRU::Response->newFromRequest( $sru_request ); my @args = ( $sru_request, $sru_response ); my $cql; my $mode = $sru_request->type; if ( $mode eq 'scan' ) { $cql = $sru_request->scanClause; } elsif ( $mode eq 'searchRetrieve' ) { $cql = $sru_request->query; } if( defined $cql ) { $cql = CQL::Parser->new->parseSafe( $cql ); push @args, $cql; unless ( ref $cql ) { $sru_response->addDiagnostic( SRU::Response::Diagnostic->newFromCode( $cql ) ); } } if ( my $action = $self->can( $mode ) ) { $action->( $self, $c, @args ); } else { $sru_response->addDiagnostic( SRU::Response::Diagnostic->newFromCode( 4 ) ); $c->log->debug( qq(Couldn't find sru method "$mode") ) if $c->debug; } $c->res->content_type( 'text/xml' ); $c->res->body( $sru_response->asXML ); }; 1; __END__ =pod =head1 NAME Catalyst::Controller::SRU - Dispatch SRU methods with Catalyst =head1 SYNOPSIS package MyApp::Controller::SRU; # use it as a base controller use base qw( Catalyst::Controller::SRU ); # explain, scan and searchretrieve methods sub explain { my ( $self, $c, $sru_request, # ISA SRU::Request::Explain $sru_response, # ISA SRU::Response::Explain ) = @_; } sub scan { my ( $self, $c, $sru_request, # ISA SRU::Request::Scan $sru_response, # ISA SRU::Response::Scan $cql, # ISA CQL::Parser root node ) = @_; } sub searchRetrieve { my ( $self, $c, $sru_request, # ISA SRU::Request::SearchRetrieve $sru_response, # ISA SRU::Response::SearchRetrieve $cql, # ISA CQL::Parser root node ) = @_; } =head1 DESCRIPTION This module allows your controller class to dispatch SRU actions (C, C, and C) from its own class. =head1 METHODS =head2 index : Private This method will create an SRU request, response and possibly a CQL object based on the type of SRU request it finds. It will then pass the data over to your customized method. =cut =head1 SEE ALSO =over 4 =item * L =item * L =back =head1 AUTHORS Brian Cassidy =cut =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 by Ed Summers. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut SRU-1.01/LICENSE0000644000175000017500000004364512230305477012420 0ustar bricasbricasThis software is copyright (c) 2013 by Ed Summers. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. Terms of the Perl programming language system itself a) the GNU General Public License as published by the Free Software Foundation; either version 1, or (at your option) any later version, or b) the "Artistic License" --- The GNU General Public License, Version 1, February 1989 --- This software is Copyright (c) 2013 by Ed Summers. This is free software, licensed under: The GNU General Public License, Version 1, February 1989 GNU GENERAL PUBLIC LICENSE Version 1, February 1989 Copyright (C) 1989 Free Software Foundation, Inc. 51 Franklin St, Suite 500, Boston, MA 02110-1335 USA Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. Preamble The license agreements of most software companies try to keep users at the mercy of those companies. By contrast, our General Public License is intended to guarantee your freedom to share and change free software--to make sure the software is free for all its users. The General Public License applies to the Free Software Foundation's software and to any other program whose authors commit to using it. You can use it for your programs, too. When we speak of free software, we are referring to freedom, not price. Specifically, the General Public License is designed to make sure that you have the freedom to give away or sell copies of free software, that you receive source code or can get it if you want it, that you can change the software or use pieces of it in new free programs; and that you know you can do these things. To protect your rights, we need to make restrictions that forbid anyone to deny you these rights or to ask you to surrender the rights. These restrictions translate to certain responsibilities for you if you distribute copies of the software, or if you modify it. For example, if you distribute copies of a such a program, whether gratis or for a fee, you must give the recipients all the rights that you have. You must make sure that they, too, receive or can get the source code. And you must tell them their rights. We protect your rights with two steps: (1) copyright the software, and (2) offer you this license which gives you legal permission to copy, distribute and/or modify the software. Also, for each author's protection and ours, we want to make certain that everyone understands that there is no warranty for this free software. If the software is modified by someone else and passed on, we want its recipients to know that what they have is not the original, so that any problems introduced by others will not reflect on the original authors' reputations. The precise terms and conditions for copying, distribution and modification follow. GNU GENERAL PUBLIC LICENSE TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 0. This License Agreement applies to any program or other work which contains a notice placed by the copyright holder saying it may be distributed under the terms of this General Public License. The "Program", below, refers to any such program or work, and a "work based on the Program" means either the Program or any work containing the Program or a portion of it, either verbatim or with modifications. Each licensee is addressed as "you". 1. You may copy and distribute verbatim copies of the Program's source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice and disclaimer of warranty; keep intact all the notices that refer to this General Public License and to the absence of any warranty; and give any other recipients of the Program a copy of this General Public License along with the Program. You may charge a fee for the physical act of transferring a copy. 2. You may modify your copy or copies of the Program or any portion of it, and copy and distribute such modifications under the terms of Paragraph 1 above, provided that you also do the following: a) cause the modified files to carry prominent notices stating that you changed the files and the date of any change; and b) cause the whole of any work that you distribute or publish, that in whole or in part contains the Program or any part thereof, either with or without modifications, to be licensed at no charge to all third parties under the terms of this General Public License (except that you may choose to grant warranty protection to some or all third parties, at your option). c) If the modified program normally reads commands interactively when run, you must cause it, when started running for such interactive use in the simplest and most usual way, to print or display an announcement including an appropriate copyright notice and a notice that there is no warranty (or else, saying that you provide a warranty) and that users may redistribute the program under these conditions, and telling the user how to view a copy of this General Public License. d) You may charge a fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee. Mere aggregation of another independent work with the Program (or its derivative) on a volume of a storage or distribution medium does not bring the other work under the scope of these terms. 3. You may copy and distribute the Program (or a portion or derivative of it, under Paragraph 2) in object code or executable form under the terms of Paragraphs 1 and 2 above provided that you also do one of the following: a) accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Paragraphs 1 and 2 above; or, b) accompany it with a written offer, valid for at least three years, to give any third party free (except for a nominal charge for the cost of distribution) a complete machine-readable copy of the corresponding source code, to be distributed under the terms of Paragraphs 1 and 2 above; or, c) accompany it with the information you received as to where the corresponding source code may be obtained. (This alternative is allowed only for noncommercial distribution and only if you received the program in object code or executable form alone.) Source code for a work means the preferred form of the work for making modifications to it. For an executable file, complete source code means all the source code for all modules it contains; but, as a special exception, it need not include source code for modules which are standard libraries that accompany the operating system on which the executable file runs, or for standard header files or definitions files that accompany that operating system. 4. You may not copy, modify, sublicense, distribute or transfer the Program except as expressly provided under this General Public License. Any attempt otherwise to copy, modify, sublicense, distribute or transfer the Program is void, and will automatically terminate your rights to use the Program under this License. However, parties who have received copies, or rights to use copies, from you under this General Public License will not have their licenses terminated so long as such parties remain in full compliance. 5. By copying, distributing or modifying the Program (or any work based on the Program) you indicate your acceptance of this license to do so, and all its terms and conditions. 6. Each time you redistribute the Program (or any work based on the Program), the recipient automatically receives a license from the original licensor to copy, distribute or modify the Program subject to these terms and conditions. You may not impose any further restrictions on the recipients' exercise of the rights granted herein. 7. The Free Software Foundation may publish revised and/or new versions of the General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. Each version is given a distinguishing version number. If the Program specifies a version number of the license which applies to it and "any later version", you have the option of following the terms and conditions either of that version or of any later version published by the Free Software Foundation. If the Program does not specify a version number of the license, you may choose any version ever published by the Free Software Foundation. 8. If you wish to incorporate parts of the Program into other free programs whose distribution conditions are different, write to the author to ask for permission. For software which is copyrighted by the Free Software Foundation, write to the Free Software Foundation; we sometimes make exceptions for this. Our decision will be guided by the two goals of preserving the free status of all derivatives of our free software and of promoting the sharing and reuse of software generally. NO WARRANTY 9. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 10. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. END OF TERMS AND CONDITIONS Appendix: How to Apply These Terms to Your New Programs If you develop a new program, and you want it to be of the greatest possible use to humanity, the best way to achieve this is to make it free software which everyone can redistribute and change under these terms. To do so, attach the following notices to the program. It is safest to attach them to the start of each source file to most effectively convey the exclusion of warranty; and each file should have at least the "copyright" line and a pointer to where the full notice is found. Copyright (C) 19yy This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 1, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston MA 02110-1301 USA Also add information on how to contact you by electronic and paper mail. If the program is interactive, make it output a short notice like this when it starts in an interactive mode: Gnomovision version 69, Copyright (C) 19xx name of author Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. This is free software, and you are welcome to redistribute it under certain conditions; type `show c' for details. The hypothetical commands `show w' and `show c' should show the appropriate parts of the General Public License. Of course, the commands you use may be called something other than `show w' and `show c'; they could even be mouse-clicks or menu items--whatever suits your program. You should also get your employer (if you work as a programmer) or your school, if any, to sign a "copyright disclaimer" for the program, if necessary. Here a sample; alter the names: Yoyodyne, Inc., hereby disclaims all copyright interest in the program `Gnomovision' (a program to direct compilers to make passes at assemblers) written by James Hacker. , 1 April 1989 Ty Coon, President of Vice That's all there is to it! --- The Artistic License 1.0 --- This software is Copyright (c) 2013 by Ed Summers. This is free software, licensed under: The Artistic License 1.0 The Artistic License Preamble The intent of this document is to state the conditions under which a Package may be copied, such that the Copyright Holder maintains some semblance of artistic control over the development of the package, while giving the users of the package the right to use and distribute the Package in a more-or-less customary fashion, plus the right to make reasonable modifications. Definitions: - "Package" refers to the collection of files distributed by the Copyright Holder, and derivatives of that collection of files created through textual modification. - "Standard Version" refers to such a Package if it has not been modified, or has been modified in accordance with the wishes of the Copyright Holder. - "Copyright Holder" is whoever is named in the copyright or copyrights for the package. - "You" is you, if you're thinking about copying or distributing this Package. - "Reasonable copying fee" is whatever you can justify on the basis of media cost, duplication charges, time of people involved, and so on. (You will not be required to justify it to the Copyright Holder, but only to the computing community at large as a market that must bear the fee.) - "Freely Available" means that no fee is charged for the item itself, though there may be fees involved in handling the item. It also means that recipients of the item may redistribute it under the same conditions they received it. 1. You may make and give away verbatim copies of the source form of the Standard Version of this Package without restriction, provided that you duplicate all of the original copyright notices and associated disclaimers. 2. You may apply bug fixes, portability fixes and other modifications derived from the Public Domain or from the Copyright Holder. A Package modified in such a way shall still be considered the Standard Version. 3. You may otherwise modify your copy of this Package in any way, provided that you insert a prominent notice in each changed file stating how and when you changed that file, and provided that you do at least ONE of the following: a) place your modifications in the Public Domain or otherwise make them Freely Available, such as by posting said modifications to Usenet or an equivalent medium, or placing the modifications on a major archive site such as ftp.uu.net, or by allowing the Copyright Holder to include your modifications in the Standard Version of the Package. b) use the modified Package only within your corporation or organization. c) rename any non-standard executables so the names do not conflict with standard executables, which must also be provided, and provide a separate manual page for each non-standard executable that clearly documents how it differs from the Standard Version. d) make other distribution arrangements with the Copyright Holder. 4. You may distribute the programs of this Package in object code or executable form, provided that you do at least ONE of the following: a) distribute a Standard Version of the executables and library files, together with instructions (in the manual page or equivalent) on where to get the Standard Version. b) accompany the distribution with the machine-readable source of the Package with your modifications. c) accompany any non-standard executables with their corresponding Standard Version executables, giving the non-standard executables non-standard names, and clearly documenting the differences in manual pages (or equivalent), together with instructions on where to get the Standard Version. d) make other distribution arrangements with the Copyright Holder. 5. You may charge a reasonable copying fee for any distribution of this Package. You may charge any fee you choose for support of this Package. You may not charge a fee for this Package itself. However, you may distribute this Package in aggregate with other (possibly commercial) programs as part of a larger (possibly commercial) software distribution provided that you do not advertise this Package as a product of your own. 6. The scripts and library files supplied as input to or produced as output from the programs of this Package do not automatically fall under the copyright of this Package, but belong to whomever generated them, and may be sold commercially, and may be aggregated with this Package. 7. C or perl subroutines supplied by you and linked into this Package shall not be considered part of this Package. 8. The name of the Copyright Holder may not be used to endorse or promote products derived from this software without specific prior written permission. 9. THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. The End