Open-ILS/src/support-scripts/test-scripts/collections.pl

   1 #!/usr/bin/perl
   2 use strict; use warnings;
   3
   4 use Digest::MD5 qw(md5_hex);
   5 use RPC::XML qw/smart_encode/;
   6 use RPC::XML::Client;
   7 use Data::Dumper; # for debugging
   8
   9 die "usage: $0 <host> <location> <username> <password>\n" unless $ARGV[3];
  10
  11
  12 # some example query params
  13 my $host                        = shift;
  14 my $location    = shift;
  15 my $username    = shift;
  16 my $password    = shift;
  17
  18
  19 $host                           = "http://$host/xml-rpc/";
  20 my $fine_age    = '1 day';
  21 my $fine_limit  = 10;
  22
  23
  24
  25
  26 # --------------------------------------------------------------------
  27 # Login to the system so we can get an authentication token
  28 # --------------------------------------------------------------------
  29 my $authkey = login( $username, $password );
  30
  31
  32
  33
  34 # --------------------------------------------------------------------
  35 # First get the list of users that should be placed into collections
  36 # --------------------------------------------------------------------
  37 my $resp = request(
  38         'open-ils.collections',
  39         'open-ils.collections.users_of_interest.retrieve',
  40         $authkey, $fine_age, $fine_limit, $location );
  41
  42
  43
  44 # --------------------------------------------------------------------
  45 # Get the Perl-ized version of the data
  46 # --------------------------------------------------------------------
  47 my $user_data = $resp->value;
  48
  49
  50
  51 # --------------------------------------------------------------------
  52 # For each user in the response, print some preliminary info on the
  53 # user, then fetch the full user/transaction details and print
  54 # info on those
  55 # --------------------------------------------------------------------
  56 for my $d (@$user_data) {
  57
  58
  59         # --------------------------------------------------------------------
  60         # Print some basic info about the user
  61         # --------------------------------------------------------------------
  62         print "user id = " .                            $d->{usr}->{id} . "\n";
  63         print "user dob = " .                   $d->{usr}->{dob} . "\n";
  64         print "user profile = " .               $d->{usr}->{profile} . "\n";
  65         print "additional groups = ". join(', ', @{$d->{usr}->{groups}}) . "\n";
  66         print "last billing = " .               $d->{last_pertinent_billing} . "\n";
  67         print "threshold_amount = " . $d->{threshold_amount} . "\n";
  68         # --------------------------------------------------------------------
  69
  70
  71         # --------------------------------------------------------------------
  72         # Now "flesh" the user object and grab all of the transaction details
  73         # --------------------------------------------------------------------
  74         my $xact_data = request(
  75                 'open-ils.collections',
  76                 'open-ils.collections.user_transaction_details.retrieve',
  77                 $authkey, '2006-01-01', '2006-12-12', $location, [ $d->{usr}->{id} ] );
  78         $xact_data = $xact_data->value->[0];
  79
  80         my $user                = $xact_data->{usr}->{__data__};
  81         my $circs       = $xact_data->{transactions}->{circulations};
  82         my $grocery = $xact_data->{transactions}->{grocery};
  83         my $reservations = $xact_data->{transactions}->{reservations};
  84
  85
  86         # --------------------------------------------------------------------
  87         # Print out the user's addresses
  88         # --------------------------------------------------------------------
  89         for my $addr (@{$user->{addresses}}) {
  90                 my $a = $addr->{__data__};
  91
  92                 print join(' ',
  93                         $a->{street1},
  94                         $a->{street2},
  95                         $a->{city},
  96                         $a->{state},
  97                         $a->{post_code}) . "\n";
  98         }
  99
 100         print_xact_details($_->{__data__}) for (@$circs, @$grocery, @$reservations);
 101
 102         print "\n" . '-'x60 . "\n";
 103 }
 104
 105
 106 # --------------------------------------------------------------------
 107 # Prints details on transactions, billings, and payments
 108 # --------------------------------------------------------------------
 109 sub print_xact_details {
 110         my $xact = shift;
 111
 112         my $loc = ($xact->{circ_lib}) ? $xact->{circ_lib} : $xact->{billing_location};
 113         print " - transaction ".$xact->{id}. " started at " .
 114                 $xact->{xact_start} . " at " . $loc->{__data__}->{shortname} ."\n";
 115
 116         # --------------------------------------------------------------------
 117         # Print some info on any bills attached to this transaction
 118         # --------------------------------------------------------------------
 119         for my $bill (@{$xact->{billings}}) {
 120                 my $b = $bill->{__data__};
 121                 print "\tbill ".$b->{id}. " created on " . $b->{billing_ts} . "\n";
 122                 print "\tamount = ".$b->{amount} . "\n";
 123                 print "\ttype = ".$b->{billing_type} . "\n";
 124                 print "\t" . '-'x30 . "\n";
 125         }
 126
 127         # --------------------------------------------------------------------
 128         # Print some info on any payments made on this transaction
 129         # --------------------------------------------------------------------
 130         for my $payment (@{$xact->{payments}}) {
 131                 my $p = $payment->{__data__};
 132                 print "\tpayment ".$p->{id}. " made on " . $p->{payment_ts} . "\n";
 133                 print "\tamount = ".$p->{amount} . "\n";
 134                 print "\t" . '-'x30 . "\n";
 135
 136         }
 137 }
 138
 139
 140
 141
 142 # --------------------------------------------------------------------
 143 # This sends an XML-RPC request and returns the RPC::XML::response
 144 # object.
 145 # $resp->value gives the Perl,
 146 # $resp->as_string gives the XML
 147 # --------------------------------------------------------------------
 148 sub request {
 149         my( $service, $method, @args ) = @_;
 150         my $connection = RPC::XML::Client->new("$host/$service");
 151         my $resp = $connection->send_request($method, smart_encode(@args));
 152         return $resp;
 153 }
 154
 155
 156
 157
 158
 159 # --------------------------------------------------------------------
 160 # Login
 161 # --------------------------------------------------------------------
 162 sub login {
 163         my( $username, $password ) = @_;
 164
 165         my $seed = request(
 166                 'open-ils.auth',
 167                 'open-ils.auth.authenticate.init', $username )->value;
 168
 169         die "No auth seed returned\n" unless $seed;
 170
 171         my $response = request(
 172                 'open-ils.auth',
 173                 'open-ils.auth.authenticate.complete',
 174                 {
 175                         username => $username,
 176                         password => md5_hex($seed . md5_hex($password)),
 177                         type            => 'opac',
 178                 }
 179         )->value;
 180
 181         die "No login response returned\n" unless $response;
 182
 183         my $key = $response->{payload}->{authtoken};
 184
 185         die "Login failed\n" unless $key;
 186
 187         return $key;
 188 }
 189
 190