2 use strict; use warnings;
4 use Digest::MD5 qw(md5_hex);
5 use RPC::XML qw/smart_encode/;
7 use Data::Dumper; # for debugging
9 die "usage: $0 <host> <location> <username> <password>\n" unless $ARGV[3];
12 # some example query params
19 $host = "http://$host/xml-rpc/";
20 my $fine_age = '1 day';
26 # --------------------------------------------------------------------
27 # Login to the system so we can get an authentication token
28 # --------------------------------------------------------------------
29 my $authkey = login( $username, $password );
34 # --------------------------------------------------------------------
35 # First get the list of users that should be placed into collections
36 # --------------------------------------------------------------------
38 'open-ils.collections',
39 'open-ils.collections.users_of_interest.retrieve',
40 $authkey, $fine_age, $fine_limit, $location );
44 # --------------------------------------------------------------------
45 # Get the Perl-ized version of the data
46 # --------------------------------------------------------------------
47 my $user_data = $resp->value;
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
55 # --------------------------------------------------------------------
56 for my $d (@$user_data) {
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 # --------------------------------------------------------------------
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];
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};
86 # --------------------------------------------------------------------
87 # Print out the user's addresses
88 # --------------------------------------------------------------------
89 for my $addr (@{$user->{addresses}}) {
90 my $a = $addr->{__data__};
97 $a->{post_code}) . "\n";
100 print_xact_details($_->{__data__}) for (@$circs, @$grocery, @$reservations);
102 print "\n" . '-'x60 . "\n";
106 # --------------------------------------------------------------------
107 # Prints details on transactions, billings, and payments
108 # --------------------------------------------------------------------
109 sub print_xact_details {
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";
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";
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";
142 # --------------------------------------------------------------------
143 # This sends an XML-RPC request and returns the RPC::XML::response
145 # $resp->value gives the Perl,
146 # $resp->as_string gives the XML
147 # --------------------------------------------------------------------
149 my( $service, $method, @args ) = @_;
150 my $connection = RPC::XML::Client->new("$host/$service");
151 my $resp = $connection->send_request($method, smart_encode(@args));
159 # --------------------------------------------------------------------
161 # --------------------------------------------------------------------
163 my( $username, $password ) = @_;
167 'open-ils.auth.authenticate.init', $username )->value;
169 die "No auth seed returned\n" unless $seed;
171 my $response = request(
173 'open-ils.auth.authenticate.complete',
175 username => $username,
176 password => md5_hex($seed . md5_hex($password)),
181 die "No login response returned\n" unless $response;
183 my $key = $response->{payload}->{authtoken};
185 die "Login failed\n" unless $key;