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