use warnings;
use Exporter;
-
-our @ISA = qw(Exporter);
-
-our @EXPORT_OK = qw(run_sip_tests no_tagged_fields
- $datepat $textpat
- $login_test $sc_status_test
- %field_specs
-
- $instid $currency $server $username $password
- $user_barcode $user_pin $user_fullname $user_homeaddr
- $user_email $user_phone $user_birthday $user_ptype
- $user_inet
- $item_barcode $item_title $item_owner
- $item2_barcode $item2_title $item2_owner
- $item_diacritic_barcode $item_diacritic_title
- $item_diacritic_owner);
-#use Data::Dumper;
+use vars qw(@ISA $VERSION @EXPORT @EXPORT_OK %EXPORT_TAGS);
+
+use Data::Dumper;
+
+BEGIN {
+ @ISA = qw(Exporter);
+ %EXPORT_TAGS = (
+ auth => [qw(&api_auth)],
+ basic => [qw($datepat $textpat $login_test $sc_status_test
+ $instid $instid2 $currency $server $username $password)],
+ # duplicate user1 and item1 as user2 and item2
+ # w/ tags like $user2_pin instead of $user_pin
+ user1 => [qw($user_barcode $user_pin $user_fullname $user_homeaddr $user_email
+ $user_phone $user_birthday $user_ptype $user_inet)],
+ user2 => [qw($user2_barcode $user._pin $user2_fullname $user2_homeaddr $user2_email
+ $user2_phone $user2_birthday $user2_ptype $user2_inet)],
+ item1 => [qw($item_barcode $item_title $item_owner )],
+ item2 => [qw($item2_barcode $item2_title $item2_owner )],
+ # we've got item3_* also
+ item3 => [qw($item3_barcode $item3_title $item3_owner )],
+ diacritic => [qw($item_diacritic_barcode $item_diacritic_title $item_diacritic_owner)],
+ );
+ # From perldoc Exporter
+ # Add all the other ":class" tags to the ":all" class, deleting duplicates
+ my %seen;
+ push @{$EXPORT_TAGS{all}},
+ grep {!$seen{$_}++} @{$EXPORT_TAGS{$_}} foreach keys %EXPORT_TAGS;
+ Exporter::export_ok_tags('all'); # Anything in a tag is in OK_EXPORT
+ # print Dumper(\%EXPORT_TAGS); # Uncomment if you want to see the results of these tricks.
+}
# The number of tests is set in run_sip_tests() below, based
# on the size of the array of tests.
use Test::More;
+use CGI;
use IO::Socket::INET;
use Sip qw(:all);
use Sip::Checksum qw(verify_cksum);
use Sip::Constants qw(:all);
+use C4::Auth qw(&check_api_auth);
+use C4::Context;
+
+# TODO: just read SIPconfig.xml and extract what we can....
#
# Configuration parameters to run the test suite
#
-our $instid = 'kohalibrary';
-our $currency = 'USD';
-#our $instid = 'UWOLS';
-#our $currency = 'CAD';
-our $server = 'localhost:6001'; # Address of the SIP server
+our $instid = 'CPL'; # branchcode
+our $instid2 = 'FPL'; # branchcode
+our $currency = 'USD'; # 'CAD';
+our $server = 'localhost:6001'; # Address of the SIP server
-# SIP username and password to connect to the server. See the
-# SIP config.xml for the correct values.
-our $username = 'koha';
-our $password = 'koha';
+# SIP username and password to connect to the server.
+# See SIPconfig.xml for the correct values.
+our $username = 'term1';
+our $password = 'term1';
# ILS Information
+# NOTE: make sure to escape the data for use in RegExp.
# Valid user barcode and corresponding user password/pin and full name
-our $user_barcode = 'djfiander';
-our $user_pin = '6789';
-our $user_fullname= 'David J\. Fiander';
-our $user_homeaddr= '2 Meadowvale Dr\. St Thomas, ON';
-our $user_email = 'djfiander\@hotmail\.com';
-our $user_phone = '\(519\) 555 1234';
-our $user_birthday= '19640925';
-our $user_ptype = 'A';
+our $user_barcode = '23529001000463';
+our $user_pin = 'fn5zS';
+our $user_fullname= 'Edna Acosta';
+our $user_homeaddr= '7896 Library Rd\.';
+our $user_email = 'patron\@liblime\.com';
+our $user_phone = '\(212\) 555-1212';
+our $user_birthday= '19800424'; # YYYYMMDD, ANSI X3.30
+our $user_ptype = 'PT';
our $user_inet = 'Y';
+# Another valid user
+our $user2_barcode = '23529000240482';
+our $user2_pin = 'jw937';
+our $user2_fullname= 'Jamie White';
+our $user2_homeaddr= '937 Library Rd\.';
+our $user2_email = 'patron\@liblime\.com';
+our $user2_phone = '\(212\) 555-1212';
+our $user2_birthday= '19500422'; # YYYYMMDD, ANSI X3.30
+our $user2_ptype = 'T';
+our $user2_inet = 'Y';
+
# Valid item barcode and corresponding title
-our $item_barcode = '1565921879';
-our $item_title = 'Perl 5 desktop reference';
-our $item_owner = 'kohalibrary';
+our $item_barcode = '502326000005';
+our $item_title = 'How I became a pirate /';
+our $item_owner = 'CPL';
# Another valid item
-our $item2_barcode = '0440242746';
-our $item2_title = 'The deep blue alibi';
-our $item2_owner = 'kohalibrary';
+our $item2_barcode = '502326000011';
+our $item2_title = 'The biggest, smallest, fastest, tallest things you\'ve ever heard of /';
+our $item2_owner = 'CPL';
+
+# A third valid item
+our $item3_barcode = '502326000240';
+our $item3_title = 'The girl who owned a city /';
+our $item3_owner = 'FPL';
# An item with a diacritical in the title
-our $item_diacritic_barcode = '660';
-our $item_diacritic_title = 'Harry Potter y el cáliz de fuego';
-our $item_diacritic_owner = 'kohalibrary';
+our $item_diacritic_barcode = '502326001030';
+our $item_diacritic_titlea = 'Hari Poṭer u-geviʻa ha-esh /';
+our $item_diacritic_owner = 'CPL';
# End configuration
our $textpat = qr/^[^|]*$/;
our %field_specs = (
- (FID_SCREEN_MSG) => { field => FID_SCREEN_MSG,
- pat => $textpat,
- required => 0, },
- (FID_PRINT_LINE) => { field => FID_PRINT_LINE,
- pat => $textpat,
- required => 0, },
- (FID_INST_ID) => { field => FID_INST_ID,
- pat => qr/^$instid$/o,
- required => 1, },
- (FID_HOLD_ITEMS_LMT)=> { field => FID_HOLD_ITEMS_LMT,
- pat => qr/^\d{4}$/,
- required => 0, },
- (FID_OVERDUE_ITEMS_LMT)=> { field => FID_OVERDUE_ITEMS_LMT,
- pat => qr/^\d{4}$/,
- required => 0, },
- (FID_CHARGED_ITEMS_LMT)=> { field => FID_CHARGED_ITEMS_LMT,
- pat => qr/^\d{4}$/,
- required => 0, },
- (FID_VALID_PATRON) => { field => FID_VALID_PATRON,
- pat => qr/^[NY]$/,
- required => 0, },
- (FID_VALID_PATRON_PWD)=> { field => FID_VALID_PATRON_PWD,
- pat => qr/^[NY]$/,
- required => 0, },
- (FID_CURRENCY) => { field => FID_CURRENCY,
- pat => qr/^$currency$/io,
- required => 0, },
- );
+ (FID_SCREEN_MSG) => { field => FID_SCREEN_MSG,
+ pat => $textpat,
+ required => 0, },
+ (FID_PRINT_LINE) => { field => FID_PRINT_LINE,
+ pat => $textpat,
+ required => 0, },
+ (FID_INST_ID) => { field => FID_INST_ID,
+ pat => qr/^$instid$/o,
+ required => 1, },
+ (FID_HOLD_ITEMS_LMT)=> { field => FID_HOLD_ITEMS_LMT,
+ pat => qr/^\d{4}$/,
+ required => 0, },
+ (FID_OVERDUE_ITEMS_LMT)=> { field => FID_OVERDUE_ITEMS_LMT,
+ pat => qr/^\d{4}$/,
+ required => 0, },
+ (FID_CHARGED_ITEMS_LMT)=> { field => FID_CHARGED_ITEMS_LMT,
+ pat => qr/^\d{4}$/,
+ required => 0, },
+ (FID_VALID_PATRON) => { field => FID_VALID_PATRON,
+ pat => qr/^[NY]$/,
+ required => 0, },
+ (FID_VALID_PATRON_PWD)=> { field => FID_VALID_PATRON_PWD,
+ pat => qr/^[NY]$/,
+ required => 0, },
+ (FID_CURRENCY) => { field => FID_CURRENCY,
+ pat => qr/^$currency$/io,
+ required => 0, },
+ );
# Login and SC Status are always the first two messages that
# the terminal sends to the server, so just create the test
# If reading or writing fails, then the server's dead,
# so there's no point in continuing.
- if (!write_msg({seqno => $seqno}, $test->{msg}, $sock)) {
- BAIL_OUT("Write failure in $test->{id}");
- } elsif (!($resp = <$sock>)) {
- BAIL_OUT("Read failure in $test->{id}");
+ if ( !write_msg( { seqno => $seqno }, $test->{msg}, $sock ) ) {
+ BAIL_OUT("Write failure in $test->{id}");
}
- chomp($resp);
+ my $rv = sysread( $sock, $resp, 10000000 ); # 10000000 is a big number
- if (!verify_cksum($resp)) {
- fail("checksum $test->{id}");
- return;
- }
- if ($resp !~ $test->{pat}) {
- fail("match leader $test->{id}");
- diag("Response '$resp' doesn't match pattern '$test->{pat}'");
- return;
+ if ( !$rv ) {
+ BAIL_OUT("Read failure in $test->{id}");
}
- # Split the tagged fields of the response into (name, value)
- # pairs and stuff them into the hash.
- $resp =~ $test->{pat};
- %fields = substr($resp, $+[0]) =~ /(..)([^|]*)\|/go;
+ chomp($resp);
+ $resp =~ tr/\cM//d;
+ $resp =~ s/\015?\012$//;
+ chomp($resp);
+
+ if (!verify_cksum($resp)) {
+ fail("$test->{id} checksum($resp)");
+ return;
+ }
+ if ($resp !~ $test->{pat}) {
+ fail("match leader $test->{id}");
+ diag("Response '$resp' doesn't match pattern '$test->{pat}'");
+ return;
+ }
+
+ # Split the tagged fields of the response into (name, value)
+ # pairs and stuff them into the hash.
+ $resp =~ $test->{pat};
+ %fields = substr($resp, $+[0]) =~ /(..)([^|]*)\|/go;
-# print STDERR Dumper($test);
-# print STDERR Dumper(\%fields);
- if (!defined($test->{fields})) {
- diag("TODO: $test->{id} field tests not written yet");
- } else {
+ # print STDERR "one_msg ( test ) : " . Dumper($test) . "\n" .
+ # "one_msg (fields) : " . Dumper(\%fields);
+ if (!defined($test->{fields})) {
+ diag("TODO: $test->{id} field tests not written yet");
+ } else {
# If there are no tagged fields, then 'fields' should be an
# empty list which will automatically skip this loop
foreach my $ftest (@{$test->{fields}}) {
my $field = $ftest->{field};
if ($ftest->{required} && !exists($fields{$field})) {
- fail("$test->{id} required field '$field' exists in '$resp'");
+ fail("$test->{id}: required field '$field' not found in '$resp'");
return;
}
if (exists($fields{$field}) && ($fields{$field} !~ $ftest->{pat})) {
-
fail("$test->{id} field test $field");
- diag("Field pattern '$ftest->{pat}' for '$field' doesn't match in '$resp'");
+ diag("Field '$field' pattern '$ftest->{pat}' fails to match value '$fields{$field}' in message '$resp'");
return;
}
}
return;
}
-#
-# _count_tests: Count the number of tests in a test array
-sub _count_tests {
- return scalar @_;
+sub api_auth {
+ # AUTH
+ $ENV{REMOTE_USER} = $username;
+ my $query = CGI->new();
+ $query->param(userid => $username);
+ $query->param(password => $password);
+ my ($status, $cookie, $sessionID) = check_api_auth($query, {circulate=>1}, "intranet");
+ print STDERR "check_api_auth returns " . ($status || 'undef') . "\n";
+ # print STDERR "api_auth userenv = " . &dump_userenv;
+ return $status;
+}
+
+sub dump_userenv {
+ my $userenv = C4::Context->userenv;
+ return "# userenv: EMPTY\n" unless ($userenv);
+ my $userbranch = $userenv->{branch};
+ return "# userenv: " . Dumper($userenv)
+ . ($userbranch ? "BRANCH FOUND: $userbranch\n" : "NO BRANCH FOUND\n");
}
sub run_sip_tests {
my ($sock, $seqno);
$Sip::error_detection = 1;
- $/ = "\r";
+ $/ = "\015\012"; # must use correct record separator
$sock = new IO::Socket::INET(PeerAddr => $server,
Type => SOCK_STREAM);
BAIL_OUT('failed to create connection to server') unless $sock;
$seqno = 1;
-
- plan tests => _count_tests(@_);
-
+ # print STDERR "Number of tests : ", scalar (@_), "\n";
+ plan tests => scalar(@_);
foreach my $test (@_) {
- one_msg($sock, $test, $seqno++);
- $seqno %= 10; # sequence number is one digit
+ # print STDERR "Test $seqno:" . Dumper($test);
+ one_msg($sock, $test, $seqno++);
+ $seqno %= 10; # sequence number is one digit
}
}
projects / koha.git / blobdiff