LP#1993754: fix XML-RPC gateway's handling of Fieldmapper objects

This patch improves the handling of Fieldmapper objects by the
XML-RPC gateway by:

- enabling support for the XML-RPC nil extension, thereby allowing
  null values to be correcty passed back and forth rather than
  converting them to empty strings
- fixing the de-serialization of Fieldmapper objects; this allows
  a Fieldmapper object returned by one XML-RPC call to be modified
  and consumed by a second one

To test
-------
[1] Apply the patch but do not restart Apache.
[2] Run the new test script test-xml-rpc-patron-update.pl to
    try update a patron record; note that the update fails.
[3] Restart or reload Apache and repeat step 2; this time, the
    patron update should succeed.

Note that the test script may need minor modification to work on your
local testing environment.

Signed-off-by: Galen Charlton <gmc@equinoxOLI.org>

diff --git a/Open-ILS/src/perlmods/lib/OpenILS/WWW/XMLRPCGateway.pm b/Open-ILS/src/perlmods/lib/OpenILS/WWW/XMLRPCGateway.pm
index 43e99e4..3190869 100644 (file)
--- a/Open-ILS/src/perlmods/lib/OpenILS/WWW/XMLRPCGateway.pm
+++ b/Open-ILS/src/perlmods/lib/OpenILS/WWW/XMLRPCGateway.pm
@@ -48,6 +48,7 @@ sub child_init {
     OpenILS::Utils::Fieldmapper->require;
     Fieldmapper->import(IDL => $idl);
     OpenSRF::AppSession->ingress('apache');
+    $RPC::XML::ALLOW_NIL = 1;
     return Apache2::Const::OK;
 }
 
@@ -152,8 +153,7 @@ sub unwrap_perl {
       if( defined($obj->{$CLASS_KEY})) {
          my $class = $obj->{$CLASS_KEY};
          if( $obj = unwrap_perl($obj->{$PAYLOAD_KEY}) ) {
-            return bless(\$obj, $class) unless ref($obj);
-            return bless( $obj, $class );
+            return Fieldmapper::class_for_hint($class)->from_bare_hash($obj);
          }
          return undef;
       }

diff --git a/Open-ILS/src/support-scripts/test-scripts/test-xml-rpc-patron-update.pl b/Open-ILS/src/support-scripts/test-scripts/test-xml-rpc-patron-update.pl
new file mode 100755 (executable)
index 0000000..a086f3c
--- /dev/null
+++ b/Open-ILS/src/support-scripts/test-scripts/test-xml-rpc-patron-update.pl
@@ -0,0 +1,116 @@
+#!/usr/bin/perl
+use strict; use warnings;
+
+use Digest::MD5 qw(md5_hex);
+use RPC::XML qw/smart_encode/;
+use RPC::XML::Client;
+use Data::Dumper; # for debugging
+$RPC::XML::ALLOW_NIL = 1;
+
+die "usage: $0 <host> <location> <username> <password> <patron_barcode>\n" unless $ARGV[4];
+
+
+# some example query params
+my $host                       = shift;
+my $location   = shift;
+my $username   = shift;
+my $password   = shift;
+my $barcode     = shift;
+
+
+$host                          = "http://$host/xml-rpc";
+
+# --------------------------------------------------------------------
+# Login to the system so we can get an authentication token
+# --------------------------------------------------------------------
+my $authkey = login( $username, $password );
+
+# --------------------------------------------------------------------
+# Grab a patron by barcode
+# --------------------------------------------------------------------
+my $resp = request(
+       'open-ils.actor',
+       'open__ils.actor.user.fleshed.retrieve_by_barcode',
+       $authkey, $barcode);
+
+
+
+# --------------------------------------------------------------------
+# Get the Perl-ized version of the data
+# --------------------------------------------------------------------
+my $user_data = $resp->value;
+
+# bump up the expiration date by a year
+my $expire_date = $user_data->{__data__}->{expire_date};
+print "Original expire date: $expire_date\n";
+
+my $expire_year = substr($expire_date, 0, 4);
+$expire_year = sprintf('%-04.4d', int($expire_year) + 1);
+substr($expire_date, 0, 4) = $expire_year;
+print "New expire date: $expire_date\n";
+
+$user_data->{__data__}->{expire_date} = $expire_date;
+$user_data->{__data__}->{ischanged} = 't';
+
+# and manipulate any addresses...
+foreach my $addr (@{ $user_data->{__data__}->{addresses} }) {
+    $addr->{__data__}->{street1} .= 'Z';
+    $addr->{__data__}->{ischanged} = 't';
+}
+
+my $update_resp = request(
+    'open-ils.actor',
+    'open__ils.actor.patron.update',
+    $authkey, $user_data);
+
+# --------------------------------------------------------------------
+# This sends an XML-RPC request and returns the RPC::XML::response
+# object.  
+# $resp->value gives the Perl, 
+# $resp->as_string gives the XML
+# --------------------------------------------------------------------
+sub request {
+       my( $service, $method, @args ) = @_;
+       my $connection = RPC::XML::Client->new("$host/$service", useragent => [ssl_opts => {verify_hostname => 0}]);
+       my $resp = $connection->send_request($method, smart_encode(@args));
+       return $resp;
+}
+
+
+
+
+
+# --------------------------------------------------------------------
+# Login 
+# --------------------------------------------------------------------
+sub login {
+       my( $username, $password ) = @_;
+
+       my $seed = request( 
+               'open-ils.auth',
+               'open__ils.auth.authenticate.init', $username )->value;
+
+       die "No auth seed returned\n" unless $seed;
+
+       my $response = request(
+               'open-ils.auth', 
+               'open__ils.auth.authenticate.complete', 
+               {       
+                       username => $username, 
+                       password => md5_hex($seed . md5_hex($password)), 
+                       type            => 'opac',
+               }
+       )->value;
+
+       die "No login response returned\n" unless $response;
+
+       my $key = $response->{payload}->{authtoken};
+
+       die "Login failed\n" unless $key;
+
+    warn $key;
+
+       return $key;
+}
+
+