File Coverage

blib/lib/PICA/SOAPClient.pm

Criterion	Covered	Total	%
statement	13	15	86.6
branch			n/a
condition			n/a
subroutine	5	5	100.0
pod			n/a
total	18	20	90.0

package PICA::SOAPClient;
{
  $PICA::SOAPClient::VERSION = '0.585';
}
#ABSTRACT: PICA::Store via SOAP access (aka 'webcat')
use strict;
use warnings;

use PICA::Record;
use PICA::Store;
use SOAP::Lite; # +trace => 'debug';
use SOAP::Lite;
use Carp qw(croak);
use Cwd qw(cwd);
use Encode qw(encode_utf8);

our @ISA=qw(PICA::Store);


sub new {
    my ($class) = shift;
    my ($soap, %params) = (@_ % 2) ? (@_) : (undef, @_);
    $params{SOAP} = $soap if defined $soap;

    PICA::Store::readconfigfile( \%params, $ENV{PICASTORE} )
        if exists $params{config} or exists $params{conf} ;

    croak "Missing SOAP base url (webcat)" unless defined $params{webcat};
    $params{dbsid} = "" unless defined $params{dbsid};
    $params{userkey} = "" unless defined $params{userkey};
    $params{language} = "en" unless defined $params{language};
    $params{password} = "" unless defined $params{password};

    $soap = SOAP::Lite->uri('http://www.gbv.de/schema/webcat-1.0')
                      ->proxy($params{webcat});
    # ->encoding('utf-8')
    # ->on_fault(sub{})

    my $self = bless {
        'soap' => $soap,
        'format' => SOAP::Data->name( "format" )->type( string => "pp" ),
        'rectype_title' => SOAP::Data->name( "rectype" )->type( string => "title" ),
        'rectype_entry' => SOAP::Data->name( "rectype" )->type( string => "entry" ),
        'baseurl' => $params{webcat},
    }, $class;

    return $self->access( %params );
}


sub get {
    my ($self, $id) = @_;
    my %result = $self->_soap_query( "get",
        SOAP::Data->name( "ppn" )->type( string => $id )
    );
    $result{record} = PICA::Record->new($result{record}) if $result{record};
    return %result;
}


sub create {
    my ($self, $record) = @_;
    croak('create needs a PICA::Record object')
        unless UNIVERSAL::isa($record,'PICA::Record');
    my $rectype = $self->{"rectype_title"};

    my $sf = $record->subfield('002@$0');
    $rectype = $self->{"rectype_entry"} if ($sf && $sf =~ /^T/); # authority record

    my $recorddata = encode_utf8( $record->string );

    return $self->_soap_query( "create",
        SOAP::Data->name( "record" )->type( string => $recorddata ),
        $rectype
    );
}


sub update {
    my ($self, $id, $record, $version) = @_;
    my $recorddata;
    if ( UNIVERSAL::isa( $id, 'PICA::Record' ) ) { # TODO: Test this
        $version = $record;
        $record = $id;
        $id = $id->ppn;
        $record->ppn( undef );
        $recorddata = encode_utf8( $record->string );
        $record->ppn($id);
    } else {
        croak('update needs an ID and a PICA::Record object')
            unless UNIVERSAL::isa ($record,'PICA::Record');
        $recorddata = encode_utf8( $record->string );
    }

    if (not defined $version) {
        my %current = $self->get( $id );
        return %current unless $current{version};
        $version = $current{version};
    }

    return $self->_soap_query( "update",
        SOAP::Data->name("ppn")->type( string => $id ),
        SOAP::Data->name("record")->type( string => $recorddata ),
        SOAP::Data->name("version")->type( string => $version )
    );
}


sub delete {
    my ($self, $id) = @_;
    return $self->_soap_query( "delete",
        SOAP::Data->name( "ppn" )->type( string  => $id )
    );
}


sub access {
    my ($self, %params) = @_;

    for my $key (qw(userkey password dbsid language)) {
        $self->{$key} =
            SOAP::Data->name( $key => $params{$key} )->type('string')
            if defined $params{$key};
    }

    return $self;
}


sub about {
    my $self = shift;
    return "CWS Webcat: " . $self->{baseurl};
}



sub _soap_query {
    my ($self, $operation, @params) = @_;

    push @params, $self->{"format"} unless $operation eq "delete";
    push @params, ($self->{dbsid}, $self->{userkey}, $self->{language});
    push @params, $self->{password} if defined $self->{password};

    my $response = $self->{soap}->$operation( @params );

    my %result;
    if (!$response) {
        $result{errorcode}    = "1";
        $result{errormessage} = "No response to SOAP operation '$operation'.";
    } elsif ($response->fault) {
        $result{errorcode}    = $response->faultcode;
        $result{errormessage} = $response->faultstring;
        chomp $result{errormessage};
    } else {
        $result{id} = $response->valueof("//ppn") if defined $response->valueof("//ppn");
        $result{record} = PICA::Record->new( $response->valueof("//record") )
            if defined $response->valueof("//record");
        $result{version} = $response->valueof("//version")
            if defined $response->valueof("//version");
    }

    return %result;
}

1;

__END__