libsru-perl 1.01-1 / usr / share / perl5 / SRU / Request.pm

package 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) . "</$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 *</></g; # collapse whitespace
            $xml .= "<xQuery>$xcql</xQuery>";
        }
    }

    $xml .= "</$type>";
    return $xml;
}


sub asURI {
    my ($self, $base) = @_;

    my $uri = URI->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<URI>, as L<CGI> object or
as L<PSGI> 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<new>.

=cut

=head2 asXML()

Used to generate <echoedExplainRequest>, <echoedSearchRetrieveRequest> and
<echoedScanRequest> elements in the response.

=cut

=head2 asURI( [ $base ] )

Creates a L<URI> of this request. The optional C<base> URL, provided as
string or as L<URI>, is set to C<http://localhost/> 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