7 use vars qw(@ISA $VERSION @EXPORT @EXPORT_OK %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)],
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;
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;
33 # From perldoc Exporter
34 # Add all the other ":class" tags to the ":all" class, deleting duplicates
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.
42 # The number of tests is set in run_sip_tests() below, based
43 # on the size of the array of tests.
49 use Sip::Checksum qw(verify_cksum);
50 use Sip::Constants qw(:all);
52 use C4::Auth qw(&check_api_auth);
55 # TODO: just read SIPconfig.xml and extract what we can....
57 # Configuration parameters to run the test suite
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
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';
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';
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';
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';
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';
105 our $item3_barcode = '502326000240';
106 our $item3_title = 'The girl who owned a city /';
107 our $item3_owner = 'FPL';
109 # An item with a diacritical in the title
110 our $item_diacritic_barcode = '502326001030';
111 our $item_diacritic_titlea = 'Hari Poṭer u-geviʻa ha-esh /';
112 our $item_diacritic_owner = 'CPL';
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}';
120 # Pattern for a random text field (may be empty)
121 our $textpat = qr/^[^|]*$/;
124 (FID_SCREEN_MSG) => { field => FID_SCREEN_MSG,
127 (FID_PRINT_LINE) => { field => FID_PRINT_LINE,
130 (FID_INST_ID) => { field => FID_INST_ID,
131 pat => qr/^$instid$/o,
133 (FID_HOLD_ITEMS_LMT)=> { field => FID_HOLD_ITEMS_LMT,
136 (FID_OVERDUE_ITEMS_LMT)=> { field => FID_OVERDUE_ITEMS_LMT,
139 (FID_CHARGED_ITEMS_LMT)=> { field => FID_CHARGED_ITEMS_LMT,
142 (FID_VALID_PATRON) => { field => FID_VALID_PATRON,
145 (FID_VALID_PATRON_PWD)=> { field => FID_VALID_PATRON_PWD,
148 (FID_CURRENCY) => { field => FID_CURRENCY,
149 pat => qr/^$currency$/io,
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.
157 our $login_test = { id => 'login',
158 msg => "9300CN$username|CO$password|CPThe floor|",
162 our $sc_status_test = { id => 'SC status',
164 pat => qr/^98[YN]{6}\d{3}\d{3}$datepat(2\.00|1\.00)/,
166 $field_specs{(FID_SCREEN_MSG)},
167 $field_specs{(FID_PRINT_LINE)},
168 $field_specs{(FID_INST_ID)},
173 pat => qr/^[YN]{16}$/,
182 my ($sock, $test, $seqno) = @_;
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}");
192 my $rv = sysread( $sock, $resp, 10000000 ); # 10000000 is a big number
195 BAIL_OUT("Read failure in $test->{id}");
200 $resp =~ s/\015?\012$//;
203 if (!verify_cksum($resp)) {
204 fail("$test->{id} checksum($resp)");
207 if ($resp !~ $test->{pat}) {
208 fail("match leader $test->{id}");
209 diag("Response '$resp' doesn't match pattern '$test->{pat}'");
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;
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");
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};
228 if ($ftest->{required} && !exists($fields{$field})) {
229 fail("$test->{id}: required field '$field' not found in '$resp'");
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'");
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;
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");
267 $Sip::error_detection = 1;
268 $/ = "\015\012"; # must use correct record separator
270 $sock = new IO::Socket::INET(PeerAddr => $server,
271 Type => SOCK_STREAM);
273 BAIL_OUT('failed to create connection to server') unless $sock;
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