View | Details | Raw Unified | Return to bug 8216
Collapse All | Expand All

(-)a/C4/SIP/ILS/Item.pm (-12 / +13 lines)
Lines 86-92 sub new { Link Here
86
	if (! $item) {
86
	if (! $item) {
87
		syslog("LOG_DEBUG", "new ILS::Item('%s'): not found", $item_id);
87
		syslog("LOG_DEBUG", "new ILS::Item('%s'): not found", $item_id);
88
		warn "new ILS::Item($item_id) : No item '$item_id'.";
88
		warn "new ILS::Item($item_id) : No item '$item_id'.";
89
		return undef;
89
		return;
90
	}
90
	}
91
    $item->{  'itemnumber'   } = $itemnumber;
91
    $item->{  'itemnumber'   } = $itemnumber;
92
    $item->{      'id'       } = $item->{barcode};     # to SIP, the barcode IS the id.
92
    $item->{      'id'       } = $item->{barcode};     # to SIP, the barcode IS the id.
Lines 347-371 sub available { Link Here
347
	return 0;
347
	return 0;
348
}
348
}
349
349
350
sub _barcode_to_borrowernumber ($) {
350
sub _barcode_to_borrowernumber {
351
    my $known = shift;
351
    my $known = shift;
352
    (defined($known)) or return undef;
352
    return unless defined $known;
353
    my $member = GetMember(cardnumber=>$known) or return undef;
353
    my $member = GetMember(cardnumber=>$known) or return;
354
    return $member->{borrowernumber};
354
    return $member->{borrowernumber};
355
}
355
}
356
sub barcode_is_borrowernumber ($$$) {    # because hold_queue only has borrowernumber...
356
sub barcode_is_borrowernumber {    # because hold_queue only has borrowernumber...
357
    my $self = shift;   # not really used
357
    my $self = shift;   # not really used
358
    my $barcode = shift;
358
    my $barcode = shift;
359
    my $number  = shift or return undef;    # can't be zero
359
    my $number  = shift or return;    # can't be zero
360
    (defined($barcode)) or return undef;    # might be 0 or 000 or 000000
360
    return unless defined $barcode; # might be 0 or 000 or 000000
361
    my $converted = _barcode_to_borrowernumber($barcode) or return undef;
361
    my $converted = _barcode_to_borrowernumber($barcode);
362
    return ($number eq $converted); # even though both *should* be numbers, eq is safer.
362
    return unless $converted;
363
    return ($number == $converted);
363
}
364
}
364
sub fill_reserve ($$) {
365
sub fill_reserve {
365
    my $self = shift;
366
    my $self = shift;
366
    my $hold = shift or return undef;
367
    my $hold = shift or return;
367
    foreach (qw(biblionumber borrowernumber reservedate)) {
368
    foreach (qw(biblionumber borrowernumber reservedate)) {
368
        $hold->{$_} or return undef;
369
        $hold->{$_} or return;
369
    }
370
    }
370
    return ModReserveFill($hold);
371
    return ModReserveFill($hold);
371
}
372
}
(-)a/C4/SIP/ILS/Patron.pm (-3 / +6 lines)
Lines 41-47 sub new { Link Here
41
	$debug and warn "new Patron (GetMember): " . Dumper($kp);
41
	$debug and warn "new Patron (GetMember): " . Dumper($kp);
42
    unless (defined $kp) {
42
    unless (defined $kp) {
43
		syslog("LOG_DEBUG", "new ILS::Patron(%s): no such patron", $patron_id);
43
		syslog("LOG_DEBUG", "new ILS::Patron(%s): no such patron", $patron_id);
44
		return undef;
44
		return;
45
	}
45
	}
46
	$kp = GetMemberDetails(undef,$patron_id);
46
	$kp = GetMemberDetails(undef,$patron_id);
47
	$debug and warn "new Patron (GetMemberDetails): " . Dumper($kp);
47
	$debug and warn "new Patron (GetMemberDetails): " . Dumper($kp);
Lines 207-213 sub check_password { Link Here
207
# A few special cases, not in AUTOLOADed %fields
207
# A few special cases, not in AUTOLOADed %fields
208
sub fee_amount {
208
sub fee_amount {
209
    my $self = shift;
209
    my $self = shift;
210
    return $self->{fines} || undef;
210
    if ( $self->{fines} ) {
211
        return $self->{fines};
212
    }
213
    return;
211
}
214
}
212
215
213
sub fines_amount {
216
sub fines_amount {
Lines 231-237 sub expired { Link Here
231
# 
234
# 
232
sub drop_hold {
235
sub drop_hold {
233
    my ($self, $item_id) = @_;
236
    my ($self, $item_id) = @_;
234
	$item_id or return undef;
237
	return if !$item_id;
235
	my $result = 0;
238
	my $result = 0;
236
	foreach (qw(hold_items unavail_holds)) {
239
	foreach (qw(hold_items unavail_holds)) {
237
		$self->{$_} or next;
240
		$self->{$_} or next;
(-)a/C4/SIP/ILS/Transaction/Checkout.pm (-2 / +1 lines)
Lines 38-45 my %fields = ( Link Here
38
sub new {
38
sub new {
39
    my $class = shift;;
39
    my $class = shift;;
40
    my $self = $class->SUPER::new();
40
    my $self = $class->SUPER::new();
41
    my $element;
41
    foreach my $element (keys %fields) {
42
    foreach $element (keys %fields) {
43
		$self->{_permitted}->{$element} = $fields{$element};
42
		$self->{_permitted}->{$element} = $fields{$element};
44
    }
43
    }
45
    @{$self}{keys %fields} = values %fields;
44
    @{$self}{keys %fields} = values %fields;
(-)a/C4/SIP/ILS/Transaction/Hold.pm (-2 / +1 lines)
Lines 29-36 my %fields = ( Link Here
29
sub new {
29
sub new {
30
	my $class = shift;
30
	my $class = shift;
31
	my $self = $class->SUPER::new();
31
	my $self = $class->SUPER::new();
32
	my $element;
32
	foreach my $element (keys %fields) {
33
	foreach $element (keys %fields) {
34
		$self->{_permitted}->{$element} = $fields{$element};
33
		$self->{_permitted}->{$element} = $fields{$element};
35
	}
34
	}
36
	@{$self}{keys %fields} = values %fields;
35
	@{$self}{keys %fields} = values %fields;
(-)a/C4/SIP/ILS/Transaction/Renew.pm (-3 / +2 lines)
Lines 22-30 my %fields = ( Link Here
22
sub new {
22
sub new {
23
	my $class = shift;
23
	my $class = shift;
24
	my $self = $class->SUPER::new();
24
	my $self = $class->SUPER::new();
25
	my $element;
26
25
27
	foreach $element (keys %fields) {
26
	foreach my $element (keys %fields) {
28
		$self->{_permitted}->{$element} = $fields{$element};
27
		$self->{_permitted}->{$element} = $fields{$element};
29
	}
28
	}
30
29
Lines 32-38 sub new { Link Here
32
	return bless $self, $class;
31
	return bless $self, $class;
33
}
32
}
34
33
35
sub do_renew_for ($$) {
34
sub do_renew_for  {
36
	my $self = shift;
35
	my $self = shift;
37
	my $borrower = shift;
36
	my $borrower = shift;
38
	my ($renewokay,$renewerror) = CanBookBeRenewed($borrower->{borrowernumber},$self->{item}->{itemnumber});
37
	my ($renewokay,$renewerror) = CanBookBeRenewed($borrower->{borrowernumber},$self->{item}->{itemnumber});
(-)a/C4/SIP/ILS/Transaction/RenewAll.pm (-2 / +1 lines)
Lines 23-31 my %fields = ( Link Here
23
sub new {
23
sub new {
24
	my $class = shift;
24
	my $class = shift;
25
	my $self = $class->SUPER::new();
25
	my $self = $class->SUPER::new();
26
	my $element;
27
26
28
	foreach $element (keys %fields) {
27
	foreach my $element (keys %fields) {
29
		$self->{_permitted}->{$element} = $fields{$element};
28
		$self->{_permitted}->{$element} = $fields{$element};
30
	}
29
	}
31
30
(-)a/C4/SIP/SIPServer.pm (-1 / +1 lines)
Lines 161-167 sub raw_transport { Link Here
161
    syslog("LOG_INFO", "raw_transport: shutting down");
161
    syslog("LOG_INFO", "raw_transport: shutting down");
162
}
162
}
163
163
164
sub get_clean_string ($) {
164
sub get_clean_string {
165
	my $string = shift;
165
	my $string = shift;
166
	if (defined $string) {
166
	if (defined $string) {
167
		syslog("LOG_DEBUG", "get_clean_string  pre-clean(length %s): %s", length($string), $string);
167
		syslog("LOG_DEBUG", "get_clean_string  pre-clean(length %s): %s", length($string), $string);
(-)a/C4/SIP/Sip/Checksum.pm (-6 lines)
Lines 36-47 sub verify_cksum { Link Here
36
    return (($cksum + $shortsum) & 0xFFFF) == 0;
36
    return (($cksum + $shortsum) & 0xFFFF) == 0;
37
}
37
}
38
38
39
{
40
    no warnings qw(once);
41
    eval join('',<main::DATA>) || die $@ unless caller();
42
	# FIXME: what the heck is this?
43
}
44
45
1;
39
1;
46
__END__
40
__END__
47
41
(-)a/C4/SIP/Sip/Configuration.pm (-9 lines)
Lines 80-94 sub find_service { Link Here
80
    return $self->{listeners}->{$portstr};
80
    return $self->{listeners}->{$portstr};
81
}
81
}
82
82
83
#
84
# Testing
85
#
86
87
{
88
    no warnings qw(once);
89
    eval join('',<main::DATA>) || die $@ unless caller();
90
}
91
92
1;
83
1;
93
__END__
84
__END__
94
85
(-)a/C4/SIP/Sip/MsgType.pm (-5 / +5 lines)
Lines 293-303 sub new { Link Here
293
    if (!exists($handlers{$msgtag})) {
293
    if (!exists($handlers{$msgtag})) {
294
		syslog("LOG_WARNING", "new Sip::MsgType: Skipping message of unknown type '%s' in '%s'",
294
		syslog("LOG_WARNING", "new Sip::MsgType: Skipping message of unknown type '%s' in '%s'",
295
	       $msgtag, $msg);
295
	       $msgtag, $msg);
296
		return(undef);
296
		return;
297
    } elsif (!exists($handlers{$msgtag}->{protocol}->{$protocol_version})) {
297
    } elsif (!exists($handlers{$msgtag}->{protocol}->{$protocol_version})) {
298
		syslog("LOG_WARNING", "new Sip::MsgType: Skipping message '%s' unsupported by protocol rev. '%d'",
298
		syslog("LOG_WARNING", "new Sip::MsgType: Skipping message '%s' unsupported by protocol rev. '%d'",
299
	       $msgtag, $protocol_version);
299
	       $msgtag, $protocol_version);
300
		return(undef);
300
		return;
301
    }
301
    }
302
302
303
    bless $self, $class;
303
    bless $self, $class;
Lines 405-411 sub handle { Link Here
405
	}
405
	}
406
	unless ($self->{handler}) {
406
	unless ($self->{handler}) {
407
		syslog("LOG_WARNING", "No handler defined for '%s'", $msg);
407
		syslog("LOG_WARNING", "No handler defined for '%s'", $msg);
408
		return undef;
408
		return;
409
	}
409
	}
410
    return($self->{handler}->($self, $server));  # FIXME
410
    return($self->{handler}->($self, $server));  # FIXME
411
	# FIXME: Use of uninitialized value in subroutine entry
411
	# FIXME: Use of uninitialized value in subroutine entry
Lines 794-801 sub handle_request_acs_resend { Link Here
794
    return REQUEST_ACS_RESEND;
794
    return REQUEST_ACS_RESEND;
795
}
795
}
796
796
797
sub login_core ($$$) {
797
sub login_core  {
798
	my $server = shift or return undef;
798
	my $server = shift or return;
799
	my $uid = shift;
799
	my $uid = shift;
800
	my $pwd = shift;
800
	my $pwd = shift;
801
    my $status = 1;		# Assume it all works
801
    my $status = 1;		# Assume it all works
(-)a/C4/SIP/t/SIPtest.pm (-12 / +8 lines)
Lines 14-35 BEGIN { Link Here
14
		auth  => [qw(&api_auth)],
14
		auth  => [qw(&api_auth)],
15
		basic => [qw($datepat $textpat $login_test $sc_status_test
15
		basic => [qw($datepat $textpat $login_test $sc_status_test
16
						$instid $instid2 $currency $server $username $password)],
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
17
		user1 => [qw($user_barcode  $user_pin  $user_fullname  $user_homeaddr  $user_email
19
		user1 => [qw($user_barcode  $user_pin  $user_fullname  $user_homeaddr  $user_email
18
						$user_phone  $user_birthday  $user_ptype  $user_inet)],
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)],
19
		item1 => [qw($item_barcode  $item_title  $item_owner )],
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 )],
20
		diacritic => [qw($item_diacritic_barcode $item_diacritic_title $item_diacritic_owner)],
27
		diacritic => [qw($item_diacritic_barcode $item_diacritic_title $item_diacritic_owner)],
21
	);
28
	);
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;
27
	}
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;
32
	}
33
	# From perldoc Exporter
29
	# From perldoc Exporter
34
	# Add all the other ":class" tags to the ":all" class, deleting duplicates
30
	# Add all the other ":class" tags to the ":all" class, deleting duplicates
35
	my %seen;
31
	my %seen;
Lines 241-247 sub one_msg { Link Here
241
    return;
237
    return;
242
}
238
}
243
239
244
sub api_auth() {
240
sub api_auth {
245
	# AUTH
241
	# AUTH
246
	$ENV{REMOTE_USER} = $username;
242
	$ENV{REMOTE_USER} = $username;
247
	my $query = CGI->new();
243
	my $query = CGI->new();
(-)a/t/00-testcritic.t (-2 / +1 lines)
Lines 17-23 labels members misc offline_circ opac patroncards reports reserve reviews rotati Link Here
17
serials sms suggestion t tags test tools virtualshelves Koha);
17
serials sms suggestion t tags test tools virtualshelves Koha);
18
18
19
my @dirs = qw( acqui admin authorities basket catalogue cataloguing circ debian errors labels
19
my @dirs = qw( acqui admin authorities basket catalogue cataloguing circ debian errors labels
20
    members offline_circ reserve reviews rotating_collections serials sms virtualshelves Koha);
20
    members offline_circ reserve reviews rotating_collections serials sms virtualshelves Koha C4/SIP);
21
21
22
if ( not $ENV{TEST_QA} ) {
22
if ( not $ENV{TEST_QA} ) {
23
    my $msg = 'Author test. Set $ENV{TEST_QA} to a true value to run';
23
    my $msg = 'Author test. Set $ENV{TEST_QA} to a true value to run';
24
- 

Return to bug 8216