C4/SIP/t/SIPtest.pm

   1 package SIPtest;
   2
   3 use strict;
   4 use warnings;
   5
   6 use Exporter;
   7 use vars qw(@ISA $VERSION @EXPORT @EXPORT_OK %EXPORT_TAGS);
   8
   9 use Data::Dumper;
  10
  11 BEGIN {
  12         @ISA = qw(Exporter);
  13         %EXPORT_TAGS = (
  14                 auth  => [qw(&api_auth)],
  15                 basic => [qw($datepat $textpat $login_test $sc_status_test
  16                                                 $instid $currency $server $username $password)],
  17                 user1 => [qw($user_barcode  $user_pin  $user_fullname  $user_homeaddr  $user_email
  18                                                 $user_phone  $user_birthday  $user_ptype  $user_inet)],
  19                 item1 => [qw($item_barcode  $item_title  $item_owner )],
  20                 diacritic => [qw($item_diacritic_barcode $item_diacritic_title $item_diacritic_owner)],
  21         );
  22         # duplicate user1 and item1 as user2 and item2
  23         # w/ tags like $user2_pin instead of $user_pin
  24         foreach my $tag (qw(user item)) {
  25                 my @tags = @{$EXPORT_TAGS{$tag.'1'}};   # fresh array avoids side affect in map
  26                 push @{$EXPORT_TAGS{$tag.'2'}}, map {s/($tag)\_/${1}2_/;$_} @tags;
  27         }
  28         # From perldoc Exporter
  29         # Add all the other ":class" tags to the ":all" class, deleting duplicates
  30         my %seen;
  31         push @{$EXPORT_TAGS{all}},
  32                 grep {!$seen{$_}++} @{$EXPORT_TAGS{$_}} foreach keys %EXPORT_TAGS;
  33         Exporter::export_ok_tags('all');        # Anything in a tag is in OK_EXPORT
  34         # print Dumper(\%EXPORT_TAGS);          # Uncomment if you want to see the results of these tricks.
  35 }
  36
  37 # The number of tests is set in run_sip_tests() below, based
  38 # on the size of the array of tests.
  39 use Test::More;
  40 use CGI;
  41
  42 use IO::Socket::INET;
  43 use Sip qw(:all);
  44 use Sip::Checksum qw(verify_cksum);
  45 use Sip::Constants qw(:all);
  46
  47 use C4::Auth qw(&check_api_auth);
  48 use C4::Context;
  49
  50 #
  51 # Configuration parameters to run the test suite
  52 #
  53 our $instid   = 'CPL';  # 'UWOLS';
  54 our $currency = 'USD';  # 'CAD';
  55 our $server   = 'localhost:6001';       # Address of the SIP server
  56
  57 # SIP username and password to connect to the server.  See the
  58 # SIP config.xml for the correct values.
  59 our $username = 'term1';
  60 our $password = 'term1';
  61
  62 # ILS Information
  63
  64 # NOTE: make sure to escape the data for use in RegExp.
  65 # Valid user barcode and corresponding user password/pin and full name
  66 our $user_barcode = '23529001000463';
  67 our $user_pin     = 'fn5zS';
  68 our $user_fullname= 'Edna Acosta';
  69 our $user_homeaddr= '7896 Library Rd\.';
  70 our $user_email   = 'patron\@liblime\.com';
  71 our $user_phone   = '\(212\) 555-1212';
  72 our $user_birthday= '1980-04-24';
  73 our $user_ptype   = 'PT';
  74 our $user_inet    = 'Y';
  75
  76 # Another valid user
  77 our $user2_barcode = '23529000240482';
  78 our $user2_pin     = 'jw937';
  79 our $user2_fullname= 'Jamie White';
  80 our $user2_homeaddr= '937 Library Rd\.';
  81 our $user2_email   = 'patron\@liblime\.com';
  82 our $user2_phone   = '\(212\) 555-1212';
  83 our $user2_birthday= '1950-04-22';
  84 our $user2_ptype   = 'T';
  85 our $user2_inet    = 'Y';
  86
  87 # Valid item barcode and corresponding title
  88 our $item_barcode = '502326000005';
  89 our $item_title   = 'How I became a pirate /';
  90 our $item_owner   = 'CPL';
  91
  92 # Another valid item
  93 our $item2_barcode = '502326000011';
  94 our $item2_title   = 'The biggest, smallest, fastest, tallest things you\'ve ever heard of /';
  95 our $item2_owner   = 'CPL';
  96
  97 # An item with a diacritical in the title
  98 our $item_diacritic_barcode = '502326001030';
  99 our $item_diacritic_titlea  = 'Hari Poṭer u-geviʻa ha-esh /';
 100 our $item_diacritic_owner   = 'CPL';
 101
 102 # End configuration
 103
 104 # Pattern for a SIP datestamp, to be used by individual tests to
 105 # match timestamp fields (duh).
 106 our $datepat = '\d{8} {4}\d{6}';
 107
 108 # Pattern for a random text field (may be empty)
 109 our $textpat = qr/^[^|]*$/;
 110
 111 our %field_specs = (
 112             (FID_SCREEN_MSG) => { field    => FID_SCREEN_MSG,
 113                                         pat      => $textpat,
 114                                         required => 0, },
 115             (FID_PRINT_LINE) => { field    => FID_PRINT_LINE,
 116                                         pat      => $textpat,
 117                                         required => 0, },
 118             (FID_INST_ID)    => { field    => FID_INST_ID,
 119                                         pat      => qr/^$instid$/o,
 120                                         required => 1, },
 121             (FID_HOLD_ITEMS_LMT)=> { field    => FID_HOLD_ITEMS_LMT,
 122                                         pat      => qr/^\d{4}$/,
 123                                         required => 0, },
 124             (FID_OVERDUE_ITEMS_LMT)=> { field    => FID_OVERDUE_ITEMS_LMT,
 125                                         pat      => qr/^\d{4}$/,
 126                                         required => 0, },
 127             (FID_CHARGED_ITEMS_LMT)=> { field    => FID_CHARGED_ITEMS_LMT,
 128                                         pat      => qr/^\d{4}$/,
 129                                         required => 0, },
 130             (FID_VALID_PATRON) => { field    => FID_VALID_PATRON,
 131                                     pat      => qr/^[NY]$/,
 132                                     required => 0, },
 133             (FID_VALID_PATRON_PWD)=> { field    => FID_VALID_PATRON_PWD,
 134                                         pat      => qr/^[NY]$/,
 135                                         required => 0, },
 136             (FID_CURRENCY)   => { field    => FID_CURRENCY,
 137                                         pat      => qr/^$currency$/io,
 138                                         required => 0, },
 139         );
 140
 141 # Login and SC Status are always the first two messages that
 142 # the terminal sends to the server, so just create the test
 143 # cases here and reference them in the individual test files.
 144
 145 our $login_test = { id => 'login',
 146                     msg => "9300CN$username|CO$password|CPThe floor|",
 147                     pat => qr/^941/,
 148                     fields => [], };
 149
 150 our $sc_status_test = { id => 'SC status',
 151                         msg => '9910302.00',
 152                         pat => qr/^98[YN]{6}\d{3}\d{3}$datepat(2\.00|1\.00)/,
 153                         fields => [
 154                                    $field_specs{(FID_SCREEN_MSG)},
 155                                    $field_specs{(FID_PRINT_LINE)},
 156                                    $field_specs{(FID_INST_ID)},
 157                                    { field    => 'AM',
 158                                      pat      => $textpat,
 159                                      required => 0, },
 160                                    { field    => 'BX',
 161                                      pat      => qr/^[YN]{16}$/,
 162                                      required => 1, },
 163                                    { field    => 'AN',
 164                                      pat      => $textpat,
 165                                      required => 0, },
 166                                    ],
 167                         };
 168
 169 sub one_msg {
 170     my ($sock, $test, $seqno) = @_;
 171     my $resp;
 172     my %fields;
 173
 174     # If reading or writing fails, then the server's dead,
 175     # so there's no point in continuing.
 176     if (!write_msg({seqno => $seqno}, $test->{msg}, $sock)) {
 177                 BAIL_OUT("Write failure in $test->{id}");
 178     } elsif (!($resp = <$sock>)) {
 179                 BAIL_OUT("Read failure in $test->{id}");
 180     }
 181
 182         chomp($resp);
 183         $resp =~ tr/\cM//d;
 184         chomp($resp);
 185
 186         if (!verify_cksum($resp)) {
 187                 fail("$test->{id} checksum($resp)");
 188                 return;
 189         }
 190         if ($resp !~ $test->{pat}) {
 191                 fail("match leader $test->{id}");
 192                 diag("Response '$resp' doesn't match pattern '$test->{pat}'");
 193                 return;
 194         }
 195
 196         # Split the tagged fields of the response into (name, value)
 197         # pairs and stuff them into the hash.
 198         $resp =~ $test->{pat};
 199         %fields = substr($resp, $+[0]) =~ /(..)([^|]*)\|/go;
 200
 201     # print STDERR      "one_msg ( test ) : " . Dumper($test) . "\n" .
 202     #                           "one_msg (fields) : " . Dumper(\%fields);
 203         if (!defined($test->{fields})) {
 204                 diag("TODO: $test->{id} field tests not written yet");
 205         } else {
 206         # If there are no tagged fields, then 'fields' should be an
 207         # empty list which will automatically skip this loop
 208         foreach my $ftest (@{$test->{fields}}) {
 209             my $field = $ftest->{field};
 210
 211             if ($ftest->{required} && !exists($fields{$field})) {
 212                 fail("$test->{id}: required field '$field' not found in '$resp'");
 213                 return;
 214             }
 215
 216             if (exists($fields{$field}) && ($fields{$field} !~ $ftest->{pat})) {
 217                 fail("$test->{id} field test $field");
 218                 diag("Field '$field' pattern '$ftest->{pat}' fails to match value '$fields{$field}' in message '$resp'");
 219                 return;
 220             }
 221         }
 222     }
 223     pass("$test->{id}");
 224     return;
 225 }
 226
 227 sub api_auth() {
 228         # AUTH
 229         $ENV{REMOTE_USER} = $username;
 230         my $query = CGI->new();
 231         $query->param(userid   => $username);
 232         $query->param(password => $password);
 233         my ($status, $cookie, $sessionID) = check_api_auth($query, {circulate=>1}, "intranet");
 234         print STDERR "check_api_auth returns " . ($status || 'undef') . "\n";
 235         # print STDERR "api_auth userenv = " . &dump_userenv;
 236         return $status;
 237 }
 238
 239 sub dump_userenv {
 240         my $userenv = C4::Context->userenv;
 241         return "# userenv: EMPTY\n" unless ($userenv);
 242         my $userbranch = $userenv->{branch};
 243         return "# userenv: " . Dumper($userenv)
 244                 . ($userbranch ? "BRANCH FOUND: $userbranch\n" : "NO BRANCH FOUND\n");
 245 }
 246
 247 sub run_sip_tests {
 248     my ($sock, $seqno);
 249
 250     $Sip::error_detection = 1;
 251     $/ = "\r";
 252
 253     $sock = new IO::Socket::INET(PeerAddr => $server,
 254                                  Type     => SOCK_STREAM);
 255
 256     BAIL_OUT('failed to create connection to server') unless $sock;
 257
 258     $seqno = 1;
 259         # print STDERR "Number of tests : ",  scalar (@_), "\n";
 260     plan tests => scalar(@_);
 261     foreach my $test (@_) {
 262                 # print STDERR "Test $seqno:" . Dumper($test);
 263                 one_msg($sock, $test, $seqno++);
 264                 $seqno %= 10;           # sequence number is one digit
 265     }
 266 }
 267
 268 1;