C4/SIP/koha_test/SIPtest.pm

   1 package SIPtest;
   2
   3 use strict;
   4 use warnings;
   5
   6 use Exporter;
   7
   8 our @ISA = qw(Exporter);
   9
  10 our @EXPORT_OK = qw(run_sip_tests no_tagged_fields
  11                     $datepat $textpat
  12                     $login_test $sc_status_test
  13                     %field_specs
  14
  15                     $instid $currency $server $username $password
  16                     $user_barcode $user_pin $user_fullname $user_homeaddr
  17                     $user_email $user_phone $user_birthday $user_ptype
  18                     $user_inet
  19                     $item_barcode $item_title $item_owner
  20                     $item2_barcode $item2_title $item2_owner
  21                     $item_diacritic_barcode $item_diacritic_title
  22                     $item_diacritic_owner);
  23 #use Data::Dumper;
  24
  25 # The number of tests is set in run_sip_tests() below, based
  26 # on the size of the array of tests.
  27 use Test::More;
  28
  29 use IO::Socket::INET;
  30 use Sip qw(:all);
  31 use Sip::Checksum qw(verify_cksum);
  32 use Sip::Constants qw(:all);
  33
  34 #
  35 # Configuration parameters to run the test suite
  36 #
  37 our $instid = 'kohalibrary';
  38 our $currency = 'USD';
  39 #our $instid = 'UWOLS';
  40 #our $currency = 'CAD';
  41 our $server   = 'localhost:6001'; # Address of the SIP server
  42
  43 # SIP username and password to connect to the server.  See the
  44 # SIP config.xml for the correct values.
  45 our $username = 'koha';
  46 our $password = 'koha';
  47
  48 # ILS Information
  49
  50 # Valid user barcode and corresponding user password/pin and full name
  51 our $user_barcode = '900002';
  52 our $user_pin     = 'sip test';
  53 our $user_fullname= 'Firstname SURNAME';
  54 our $user_homeaddr= '35 address';
  55 our $user_email   = 'patron@liblime.com';
  56 our $user_phone   = '555-1212';
  57 our $user_birthday= '1983-10-06';
  58 our $user_ptype   = 'A';
  59 our $user_inet    = 'N';
  60
  61 # Valid item barcode and corresponding title
  62 our $item_barcode = '37000000012023';
  63 our $item_title   = 'The not-just-anybody family.';
  64 our $item_owner   = 'kohalibrary';
  65
  66 # Another valid item
  67 our $item2_barcode = '26000548';
  68 our $item2_title   = 'Witch baby /';
  69 our $item2_owner   = 'kohalibrary';
  70
  71 # An item with a diacritical in the title
  72 our $item_diacritic_barcode = '26000216';
  73 our $item_diacritic_title = 'Z : Zäch ';
  74 our $item_diacritic_owner = 'kohalibrary';
  75
  76 # End configuration
  77
  78 # Pattern for a SIP datestamp, to be used by individual tests to
  79 # match timestamp fields (duh).
  80 our $datepat = '\d{8} {4}\d{6}';
  81
  82 # Pattern for a random text field (may be empty)
  83 our $textpat = qr/^[^|]*$/;
  84
  85 our %field_specs = (
  86                     (FID_SCREEN_MSG) => { field    => FID_SCREEN_MSG,
  87                                           pat      => $textpat,
  88                                           required => 0, },
  89                     (FID_PRINT_LINE) => { field    => FID_PRINT_LINE,
  90                                           pat      => $textpat,
  91                                           required => 0, },
  92                     (FID_INST_ID)    => { field    => FID_INST_ID,
  93                                           pat      => qr/^$instid$/o,
  94                                           required => 1, },
  95                     (FID_HOLD_ITEMS_LMT)=> { field    => FID_HOLD_ITEMS_LMT,
  96                                              pat      => qr/^\d{4}$/,
  97                                              required => 0, },
  98                     (FID_OVERDUE_ITEMS_LMT)=> { field    => FID_OVERDUE_ITEMS_LMT,
  99                                                 pat      => qr/^\d{4}$/,
 100                                                 required => 0, },
 101                     (FID_CHARGED_ITEMS_LMT)=> { field    => FID_CHARGED_ITEMS_LMT,
 102                                                 pat      => qr/^\d{4}$/,
 103                                                 required => 0, },
 104                     (FID_VALID_PATRON) => { field    => FID_VALID_PATRON,
 105                                             pat      => qr/^[NY]$/,
 106                                             required => 0, },
 107                     (FID_VALID_PATRON_PWD)=> { field    => FID_VALID_PATRON_PWD,
 108                                                pat      => qr/^[NY]$/,
 109                                                required => 0, },
 110                     (FID_CURRENCY)   => { field    => FID_CURRENCY,
 111                                           pat      => qr/^$currency$/io,
 112                                           required => 0, },
 113                     );
 114
 115 # Login and SC Status are always the first two messages that
 116 # the terminal sends to the server, so just create the test
 117 # cases here and reference them in the individual test files.
 118
 119 our $login_test = { id => 'login',
 120                     msg => "9300CN$username|CO$password|CPThe floor|",
 121                     pat => qr/^941/,
 122                     fields => [], };
 123
 124 our $sc_status_test = { id => 'SC status',
 125                         msg => '9910302.00',
 126                         pat => qr/^98[YN]{6}\d{3}\d{3}$datepat(2\.00|1\.00)/,
 127                         fields => [
 128                                    $field_specs{(FID_SCREEN_MSG)},
 129                                    $field_specs{(FID_PRINT_LINE)},
 130                                    $field_specs{(FID_INST_ID)},
 131                                    { field    => 'AM',
 132                                      pat      => $textpat,
 133                                      required => 0, },
 134                                    { field    => 'BX',
 135                                      pat      => qr/^[YN]{16}$/,
 136                                      required => 1, },
 137                                    { field    => 'AN',
 138                                      pat      => $textpat,
 139                                      required => 0, },
 140                                    ],
 141                         };
 142
 143 sub one_msg {
 144     my ($sock, $test, $seqno) = @_;
 145     my $resp;
 146     my %fields;
 147
 148     # If reading or writing fails, then the server's dead,
 149     # so there's no point in continuing.
 150     if (!write_msg({seqno => $seqno}, $test->{msg}, $sock)) {
 151         BAIL_OUT("Write failure in $test->{id}");
 152     } elsif (!($resp = <$sock>)) {
 153         BAIL_OUT("Read failure in $test->{id}");
 154     }
 155
 156     chomp($resp);
 157
 158     if (!verify_cksum($resp)) {
 159         fail("checksum $test->{id}");
 160         return;
 161     }
 162     if ($resp !~ $test->{pat}) {
 163         fail("match leader $test->{id}");
 164         diag("Response '$resp' doesn't match pattern '$test->{pat}'");
 165         return;
 166     }
 167
 168     # Split the tagged fields of the response into (name, value)
 169     # pairs and stuff them into the hash.
 170     $resp =~ $test->{pat};
 171     %fields = substr($resp, $+[0]) =~ /(..)([^|]*)\|/go;
 172
 173 #    print STDERR Dumper($test);
 174 #    print STDERR Dumper(\%fields);
 175     if (!defined($test->{fields})) {
 176         diag("TODO: $test->{id} field tests not written yet");
 177     } else {
 178         # If there are no tagged fields, then 'fields' should be an
 179         # empty list which will automatically skip this loop
 180         foreach my $ftest (@{$test->{fields}}) {
 181             my $field = $ftest->{field};
 182
 183             if ($ftest->{required} && !exists($fields{$field})) {
 184                 fail("$test->{id} required field '$field' exists in '$resp'");
 185                 return;
 186             }
 187
 188             if (exists($fields{$field}) && ($fields{$field} !~ $ftest->{pat})) {
 189
 190                 fail("$test->{id} field test $field");
 191                 diag("Field pattern '$ftest->{pat}' for '$field' doesn't match in '$resp'");
 192                 return;
 193             }
 194         }
 195     }
 196     pass("$test->{id}");
 197     return;
 198 }
 199
 200 #
 201 # _count_tests: Count the number of tests in a test array
 202 sub _count_tests {
 203     return scalar @_;
 204 }
 205
 206 sub run_sip_tests {
 207     my ($sock, $seqno);
 208
 209     $Sip::error_detection = 1;
 210     $/ = "\r";
 211
 212     $sock = new IO::Socket::INET(PeerAddr => $server,
 213                                  Type     => SOCK_STREAM);
 214
 215     BAIL_OUT('failed to create connection to server') unless $sock;
 216
 217     $seqno = 1;
 218
 219     plan tests => _count_tests(@_);
 220
 221     foreach my $test (@_) {
 222         one_msg($sock, $test, $seqno++);
 223         $seqno %= 10;           # sequence number is one digit
 224     }
 225 }
 226
 227 1;