Open-ILS/src/edi_translator/test_client.pl

   1 #!/usr/bin/perl
   2 #
   3
   4 use warnings;
   5 use strict;
   6
   7 use Getopt::Long;
   8 use RPC::XML::Client;
   9 use JSON::XS;
  10 use Data::Dumper;
  11
  12 # DEFAULTS
  13 $Data::Dumper::Indent = 1;
  14 my $host = 'http://localhost';
  15 my $verbose = 0;
  16
  17 GetOptions(
  18     'host=s'  => \$host,
  19     'verbose' => \$verbose,
  20 );
  21
  22 # CLEANUP
  23 $host =~ /^\S+:\/\// or $host  = 'http://' . $host;
  24 $host =~ /:\d+$/     or $host .= ':9191';
  25 $host .= '/EDI';
  26
  27 sub get_in {
  28     print STDERR "Getting " . (shift) . " from input\n";
  29     my $json = join("", <STDIN>);
  30     $json or return;
  31     print $json, "\n";
  32     chomp $json;
  33     return $json;
  34 }
  35
  36 sub nice_string {
  37     my $string = shift or return '';
  38     my $head   = @_ ? shift : 100;
  39     my $tail   = @_ ? shift : 25;
  40     (length($string) < $head + $tail) and return $string;
  41     return substr($string,0,$head) . " ...\n... " . substr($string, -1*$tail);
  42 }
  43
  44 sub JSONObject2Perl {
  45     my $obj = shift;
  46     if ( ref $obj eq 'HASH' ) { # is a hash w/o class marker; simply revivify innards
  47         for my $k (keys %$obj) {
  48             $obj->{$k} = JSONObject2Perl($obj->{$k}) unless ref $obj->{$k} eq 'JSON::XS::Boolean';
  49         }
  50     } elsif ( ref $obj eq 'ARRAY' ) {
  51         for my $i (0..scalar(@$obj) - 1) {
  52             $obj->[$i] = JSONObject2Perl($obj->[$i]) unless ref $obj->[$i] eq 'JSON::XS::Boolean';
  53         }
  54     }
  55     # ELSE: return vivified non-class hashes, all arrays, and anything that isn't a hash or array ref
  56     return $obj;
  57 }
  58
  59 # MAIN
  60 print "Trying host: $host\n";
  61
  62 my $parser;
  63
  64 my $client = new RPC::XML::Client($host);
  65 $client->request->header('Content-Type' => 'text/xml;charset=utf-8');
  66
  67 if ($verbose) {
  68     print "User-agent: ", Dumper($client->useragent);
  69     print "Request: ", Dumper($client->request);
  70     print "Headers: \n";
  71     foreach ($client->request->header_field_names) {
  72         print "\t$_ =>", $client->request->header($_), "\n";
  73     }
  74 }
  75
  76 my @commands = @ARGV ? @ARGV : 'system.listMethods';
  77 my $command  = lc $commands[0];
  78 if ($command eq 'json2edi' or $command eq 'edi2json' or $command eq 'edi2perl') {
  79     shift;
  80     @commands > 1 and print STDERR "Ignoring commands after $command\n";
  81     my $string;
  82     my $type = $command eq 'json2edi' ? 'JSON' : 'EDI';
  83     while ($string = get_in($type)) {  # assignment
  84         my $resp;
  85         if ($command eq 'json2edi') {
  86             $resp = $client->send_request('json2edi', $string);
  87             print "# $command Response: \n", Dumper($resp);
  88         } else {
  89             $string =~ s/ORDRSP:0(:...:UN::)/ORDRSP:D$1/ and print STDERR "Corrected broken data 'ORDRSP:0' ==> 'ORDRSP:D'\n";
  90             $resp = $client->send_request('edi2json', $string);
  91             $parser ||= JSON::XS->new()->pretty(1)->ascii(1)->allow_nonref(1)->space_before(0);    # get it once
  92             my $parsed = $parser->decode($resp->value) or warn "Failed to decode response payload value";
  93             my $perl   = JSONObject2Perl($parsed) or warn "Failed to decode and create perl object from JSON";
  94             if ($perl) {
  95                 print STDERR "\n########## We were able to decode and perl-ify the JSON\n";
  96             } else {
  97                 print STDERR "\n########## ERROR: Failed to decode and perl-ify the JSON\n";
  98             }
  99             print "# $command Response: \n", $command eq 'edi2perl' ? Dumper($perl) : $parser->encode($parsed);
 100         }
 101
 102         $resp or next;
 103         if ($resp->is_fault) {
 104             print "\n\nERROR code ", $resp->code, " received:\n", nice_string($resp->string) . "\n...\n";
 105             next;
 106         }
 107     }
 108     exit;
 109 }
 110
 111 print STDERR "Sending request: \n    ", join("\n    ", @commands), "\n\n";
 112 my $resp = $client->send_request(@commands);
 113
 114 print Dumper($resp);
 115 exit;
 116
 117 if (ref $resp) {
 118     print STDERR "Return is " . ref($resp), "\n";
 119     # print "Code: ", ($resp->{code}->as_string || 'UNKNOWN'), "\n";
 120     foreach (@$resp) {
 121         print Dumper ($_), "\n";
 122     }
 123     foreach (qw(code faultcode)) {
 124         my $code = $resp->{$_};
 125         if ($code) {
 126             print "    ", ucfirst($_), ": ";
 127             print $code ? $code->value : 'UNKNOWN';
 128         }
 129         print "\n";
 130     }
 131 } else {
 132     print STDERR "ERROR: unrecognized response:\n\n", Dumper($resp), "\n";
 133 }
 134 $verbose and print Dumper($resp);
 135 $verbose and print "\nKEYS (level 1):\n",
 136     map {sprintf "%12s: %s\n", $_, scalar $resp->{$_}->value} sort keys %$resp;
 137
 138 # print "spooled_filename: ", $resp->{spooled_filename}->value, "\n";
 139