PICA::SOAPClient - L<PICA::Store> via SOAP access (aka 'webcat')

  use PICA::SOAPClient;

  # connect to store via SOAP API
  $server = PICA::SOAPClient->new( 
      $baseurl, 
      userkey => $userkey, password => $password, dbsid => $dbsid 
  );

  # get connection details from config file
  $server = PICA::SOAPClient->new( config => "myconf.conf" );
  $server = PICA::SOAPClient->new( config => undef ); # autodetect (!)

  # CRUD operations
  %result = $server->get( $id );
  %result = $server->create( $record );
  %result = $server->update( $id, $record, $version );
  %result = $server->delete( $id );

  # set additional access parameters
  $store->access(
      userkey => $userkey, password => $password, dbsid => $dbsid
  );

package PICA::SOAPClient;

use strict;
use warnings;

our $VERSION = "0.46";

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 ref($record) eq '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->to_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->to_string );
        $record->ppn($id);
    } else {
        croak('update needs an ID and a PICA::Record object')
          unless ref($record) eq 'PICA::Record';
        $recorddata = encode_utf8( $record->to_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;