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