File Coverage

blib/lib/SRU/Request.pm

Criterion	Covered	Total	%
statement	63	82	76.8
branch	13	24	54.1
condition	5	9	55.5
subroutine	13	14	92.8
pod	4	4	100.0
total	98	133	73.6

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) . ""
            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 *
            $xml .= "$xcql";
        }
    }

    $xml .= "";
    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__