|
Lines 1-281
Link Here
|
| 1 |
package SIPtest; |
|
|
| 2 |
|
| 3 |
use strict; |
| 4 |
use warnings; |
| 5 |
|
| 6 |
use Exporter; |
| 7 |
use vars qw(@ISA @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 Poṭ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 = IO::Socket::INET->new(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; |
| 282 |
- |