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

(-)a/C4/Circulation.pm (-173 / +250 lines)
Lines 60-114 use Date::Calc qw( Link Here
60
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
60
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
61
61
62
BEGIN {
62
BEGIN {
63
	require Exporter;
63
    require Exporter;
64
    $VERSION = 3.07.00.049;	# for version checking
64
    $VERSION = 3.07.00.049;	# for version checking
65
	@ISA    = qw(Exporter);
65
    @ISA    = qw(Exporter);
66
66
67
	# FIXME subs that should probably be elsewhere
67
    # FIXME subs that should probably be elsewhere
68
	push @EXPORT, qw(
68
    push @EXPORT, qw(
69
		&barcodedecode
69
        &barcodedecode
70
        &LostItem
70
        &LostItem
71
        &ReturnLostItem
71
        &ReturnLostItem
72
	);
72
    );
73
73
74
	# subs to deal with issuing a book
74
    # subs to deal with issuing a book
75
	push @EXPORT, qw(
75
    push @EXPORT, qw(
76
		&CanBookBeIssued
76
        &CanBookBeIssued
77
		&CanBookBeRenewed
77
        &CanBookBeRenewed
78
		&AddIssue
78
        &AddIssue
79
		&AddRenewal
79
        &AddRenewal
80
		&GetRenewCount
80
        &GetRenewCount
81
		&GetItemIssue
81
        &GetItemIssue
82
		&GetItemIssues
82
        &GetItemIssues
83
		&GetIssuingCharges
83
        &GetIssuingCharges
84
		&GetIssuingRule
84
        &GetIssuingRule
85
        &GetBranchBorrowerCircRule
85
        &GetBranchBorrowerCircRule
86
        &GetBranchItemRule
86
        &GetBranchItemRule
87
		&GetBiblioIssues
87
        &GetBiblioIssues
88
		&GetOpenIssue
88
        &GetOpenIssue
89
		&AnonymiseIssueHistory
89
        &AnonymiseIssueHistory
90
        &CheckIfIssuedToPatron
90
        &CheckIfIssuedToPatron
91
        &IsItemIssued
91
        &IsItemIssued
92
	);
92
    );
93
93
94
	# subs to deal with returns
94
    # subs to deal with returns
95
	push @EXPORT, qw(
95
    push @EXPORT, qw(
96
		&AddReturn
96
        &AddReturn
97
        &MarkIssueReturned
97
        &MarkIssueReturned
98
	);
98
    );
99
99
100
	# subs to deal with transfers
100
    # subs to deal with transfers
101
	push @EXPORT, qw(
101
    push @EXPORT, qw(
102
		&transferbook
102
        &transferbook
103
		&GetTransfers
103
        &GetTransfers
104
		&GetTransfersFromTo
104
        &GetTransfersFromTo
105
		&updateWrongTransfer
105
        &updateWrongTransfer
106
		&DeleteTransfer
106
        &DeleteTransfer
107
                &CanItemBeTransferred
107
                &IsBranchTransferAllowed
108
                &IsBranchTransferAllowed
108
                &CreateBranchTransferLimit
109
                &CreateBranchTransferLimit
109
                &DeleteBranchTransferLimits
110
                &DeleteBranchTransferLimits
110
        &TransferSlip
111
        &TransferSlip
111
	);
112
    );
112
113
113
    # subs to deal with offline circulation
114
    # subs to deal with offline circulation
114
    push @EXPORT, qw(
115
    push @EXPORT, qw(
Lines 161-190 sub barcodedecode { Link Here
161
    my $branch = C4::Branch::mybranch();
162
    my $branch = C4::Branch::mybranch();
162
    $filter = C4::Context->preference('itemBarcodeInputFilter') unless $filter;
163
    $filter = C4::Context->preference('itemBarcodeInputFilter') unless $filter;
163
    $filter or return $barcode;     # ensure filter is defined, else return untouched barcode
164
    $filter or return $barcode;     # ensure filter is defined, else return untouched barcode
164
	if ($filter eq 'whitespace') {
165
    if ($filter eq 'whitespace') {
165
		$barcode =~ s/\s//g;
166
        $barcode =~ s/\s//g;
166
	} elsif ($filter eq 'cuecat') {
167
    } elsif ($filter eq 'cuecat') {
167
		chomp($barcode);
168
        chomp($barcode);
168
	    my @fields = split( /\./, $barcode );
169
        my @fields = split( /\./, $barcode );
169
	    my @results = map( decode($_), @fields[ 1 .. $#fields ] );
170
        my @results = map( decode($_), @fields[ 1 .. $#fields ] );
170
	    ($#results == 2) and return $results[2];
171
        ($#results == 2) and return $results[2];
171
	} elsif ($filter eq 'T-prefix') {
172
    } elsif ($filter eq 'T-prefix') {
172
		if ($barcode =~ /^[Tt](\d)/) {
173
        if ($barcode =~ /^[Tt](\d)/) {
173
			(defined($1) and $1 eq '0') and return $barcode;
174
            (defined($1) and $1 eq '0') and return $barcode;
174
            $barcode = substr($barcode, 2) + 0;     # FIXME: probably should be substr($barcode, 1)
175
            $barcode = substr($barcode, 2) + 0;     # FIXME: probably should be substr($barcode, 1)
175
		}
176
        }
176
        return sprintf("T%07d", $barcode);
177
        return sprintf("T%07d", $barcode);
177
        # FIXME: $barcode could be "T1", causing warning: substr outside of string
178
        # FIXME: $barcode could be "T1", causing warning: substr outside of string
178
        # Why drop the nonzero digit after the T?
179
        # Why drop the nonzero digit after the T?
179
        # Why pass non-digits (or empty string) to "T%07d"?
180
        # Why pass non-digits (or empty string) to "T%07d"?
180
	} elsif ($filter eq 'libsuite8') {
181
    } elsif ($filter eq 'libsuite8') {
181
		unless($barcode =~ m/^($branch)-/i){	#if barcode starts with branch code its in Koha style. Skip it.
182
        unless($barcode =~ m/^($branch)-/i){	#if barcode starts with branch code its in Koha style. Skip it.
182
			if($barcode =~ m/^(\d)/i){	#Some barcodes even start with 0's & numbers and are assumed to have b as the item type in the libsuite8 software
183
            if($barcode =~ m/^(\d)/i){	#Some barcodes even start with 0's & numbers and are assumed to have b as the item type in the libsuite8 software
183
                                $barcode =~ s/^[0]*(\d+)$/$branch-b-$1/i;
184
                                $barcode =~ s/^[0]*(\d+)$/$branch-b-$1/i;
184
                        }else{
185
                        }else{
185
				$barcode =~ s/^(\D+)[0]*(\d+)$/$branch-$1-$2/i;
186
                $barcode =~ s/^(\D+)[0]*(\d+)$/$branch-$1-$2/i;
186
			}
187
            }
187
		}
188
        }
188
    } elsif ($filter eq 'EAN13') {
189
    } elsif ($filter eq 'EAN13') {
189
        my $ean = CheckDigits('ean');
190
        my $ean = CheckDigits('ean');
190
        if ( $ean->is_valid($barcode) ) {
191
        if ( $ean->is_valid($barcode) ) {
Lines 193-199 sub barcodedecode { Link Here
193
        } else {
194
        } else {
194
            warn "# [$barcode] not valid EAN-13/UPC-A\n";
195
            warn "# [$barcode] not valid EAN-13/UPC-A\n";
195
        }
196
        }
196
	}
197
    }
197
    return $barcode;    # return barcode, modified or not
198
    return $barcode;    # return barcode, modified or not
198
}
199
}
199
200
Lines 299-305 sub transferbook { Link Here
299
    my $messages;
300
    my $messages;
300
    my $dotransfer      = 1;
301
    my $dotransfer      = 1;
301
    my $branches        = GetBranches();
302
    my $branches        = GetBranches();
302
    my $itemnumber = GetItemnumberFromBarcode( $barcode );
303
    my $item = GetItem(undef,$barcode,undef);
304
    my $itemnumber = $item->{itemnumber};
303
    my $issue      = GetItemIssue($itemnumber);
305
    my $issue      = GetItemIssue($itemnumber);
304
    my $biblio = GetBiblioFromItemNumber($itemnumber);
306
    my $biblio = GetBiblioFromItemNumber($itemnumber);
305
307
Lines 314-329 sub transferbook { Link Here
314
    my $fbr = $biblio->{'holdingbranch'};
316
    my $fbr = $biblio->{'holdingbranch'};
315
317
316
    # if using Branch Transfer Limits
318
    # if using Branch Transfer Limits
317
    if ( C4::Context->preference("UseBranchTransferLimits") == 1 ) {
319
    my $errMsg;
318
        if ( C4::Context->preference("item-level_itypes") && C4::Context->preference("BranchTransferLimitsType") eq 'itemtype' ) {
320
    ($dotransfer, $errMsg) = CanItemBeTransferred( $tbr, $fbr, $item, $biblio );
319
            if ( ! IsBranchTransferAllowed( $tbr, $fbr, $biblio->{'itype'} ) ) {
321
    if ( ! $dotransfer ) {
320
                $messages->{'NotAllowed'} = $tbr . "::" . $biblio->{'itype'};
322
        $messages->{'NotAllowed'} = $errMsg;
321
                $dotransfer = 0;
322
            }
323
        } elsif ( ! IsBranchTransferAllowed( $tbr, $fbr, $biblio->{ C4::Context->preference("BranchTransferLimitsType") } ) ) {
324
            $messages->{'NotAllowed'} = $tbr . "::" . $biblio->{ C4::Context->preference("BranchTransferLimitsType") };
325
            $dotransfer = 0;
326
    	}
327
    }
323
    }
328
324
329
    # if is permanent...
325
    # if is permanent...
Lines 371-385 sub transferbook { Link Here
371
sub TooMany {
367
sub TooMany {
372
    my $borrower        = shift;
368
    my $borrower        = shift;
373
    my $biblionumber = shift;
369
    my $biblionumber = shift;
374
	my $item		= shift;
370
    my $item		= shift;
375
    my $cat_borrower    = $borrower->{'categorycode'};
371
    my $cat_borrower    = $borrower->{'categorycode'};
376
    my $dbh             = C4::Context->dbh;
372
    my $dbh             = C4::Context->dbh;
377
	my $branch;
373
    my $branch;
378
	# Get which branchcode we need
374
    # Get which branchcode we need
379
	$branch = _GetCircControlBranch($item,$borrower);
375
    $branch = _GetCircControlBranch($item,$borrower);
380
	my $type = (C4::Context->preference('item-level_itypes')) 
376
    my $type = (C4::Context->preference('item-level_itypes')) 
381
  			? $item->{'itype'}         # item-level
377
            ? $item->{'itype'}         # item-level
382
			: $item->{'itemtype'};     # biblio-level
378
            : $item->{'itemtype'};     # biblio-level
383
 
379
 
384
    # given branch, patron category, and item type, determine
380
    # given branch, patron category, and item type, determine
385
    # applicable issuing rule
381
    # applicable issuing rule
Lines 696-710 sub CanBookBeIssued { Link Here
696
692
697
    my $item = GetItem(GetItemnumberFromBarcode( $barcode ));
693
    my $item = GetItem(GetItemnumberFromBarcode( $barcode ));
698
    my $issue = GetItemIssue($item->{itemnumber});
694
    my $issue = GetItemIssue($item->{itemnumber});
699
	my $biblioitem = GetBiblioItemData($item->{biblioitemnumber});
695
    my $biblioitem = GetBiblioItemData($item->{biblioitemnumber});
700
	$item->{'itemtype'}=$item->{'itype'}; 
696
    $item->{'itemtype'}=$item->{'itype'}; 
701
    my $dbh             = C4::Context->dbh;
697
    my $dbh             = C4::Context->dbh;
702
698
703
    # MANDATORY CHECKS - unless item exists, nothing else matters
699
    # MANDATORY CHECKS - unless item exists, nothing else matters
704
    unless ( $item->{barcode} ) {
700
    unless ( $item->{barcode} ) {
705
        $issuingimpossible{UNKNOWN_BARCODE} = 1;
701
        $issuingimpossible{UNKNOWN_BARCODE} = 1;
706
    }
702
    }
707
	return ( \%issuingimpossible, \%needsconfirmation ) if %issuingimpossible;
703
    return ( \%issuingimpossible, \%needsconfirmation ) if %issuingimpossible;
708
704
709
    #
705
    #
710
    # DUE DATE is OK ? -- should already have checked.
706
    # DUE DATE is OK ? -- should already have checked.
Lines 737-743 sub CanBookBeIssued { Link Here
737
    # BORROWER STATUS
733
    # BORROWER STATUS
738
    #
734
    #
739
    if ( $borrower->{'category_type'} eq 'X' && (  $item->{barcode}  )) { 
735
    if ( $borrower->{'category_type'} eq 'X' && (  $item->{barcode}  )) { 
740
    	# stats only borrower -- add entry to statistics table, and return issuingimpossible{STATS} = 1  .
736
        # stats only borrower -- add entry to statistics table, and return issuingimpossible{STATS} = 1  .
741
        &UpdateStats(C4::Context->userenv->{'branch'},'localuse','','',$item->{'itemnumber'},$item->{'itemtype'},$borrower->{'borrowernumber'}, undef, $item->{'ccode'});
737
        &UpdateStats(C4::Context->userenv->{'branch'},'localuse','','',$item->{'itemnumber'},$item->{'itemtype'},$borrower->{'borrowernumber'}, undef, $item->{'ccode'});
742
        ModDateLastSeen( $item->{'itemnumber'} );
738
        ModDateLastSeen( $item->{'itemnumber'} );
743
        return( { STATS => 1 }, {});
739
        return( { STATS => 1 }, {});
Lines 807-818 sub CanBookBeIssued { Link Here
807
    my ($blocktype, $count) = C4::Members::IsMemberBlocked($borrower->{'borrowernumber'});
803
    my ($blocktype, $count) = C4::Members::IsMemberBlocked($borrower->{'borrowernumber'});
808
    if ($blocktype == -1) {
804
    if ($blocktype == -1) {
809
        ## patron has outstanding overdue loans
805
        ## patron has outstanding overdue loans
810
	    if ( C4::Context->preference("OverduesBlockCirc") eq 'block'){
806
        if ( C4::Context->preference("OverduesBlockCirc") eq 'block'){
811
	        $issuingimpossible{USERBLOCKEDOVERDUE} = $count;
807
            $issuingimpossible{USERBLOCKEDOVERDUE} = $count;
812
	    }
808
        }
813
	    elsif ( C4::Context->preference("OverduesBlockCirc") eq 'confirmation'){
809
        elsif ( C4::Context->preference("OverduesBlockCirc") eq 'confirmation'){
814
	        $needsconfirmation{USERBLOCKEDOVERDUE} = $count;
810
            $needsconfirmation{USERBLOCKEDOVERDUE} = $count;
815
	    }
811
        }
816
    } elsif($blocktype == 1) {
812
    } elsif($blocktype == 1) {
817
        # patron has accrued fine days
813
        # patron has accrued fine days
818
        $issuingimpossible{USERBLOCKEDREMAINING} = $count;
814
        $issuingimpossible{USERBLOCKEDREMAINING} = $count;
Lines 821-827 sub CanBookBeIssued { Link Here
821
#
817
#
822
    # JB34 CHECKS IF BORROWERS DONT HAVE ISSUE TOO MANY BOOKS
818
    # JB34 CHECKS IF BORROWERS DONT HAVE ISSUE TOO MANY BOOKS
823
    #
819
    #
824
	my ($current_loan_count, $max_loans_allowed) = TooMany( $borrower, $item->{biblionumber}, $item );
820
    my ($current_loan_count, $max_loans_allowed) = TooMany( $borrower, $item->{biblionumber}, $item );
825
    # if TooMany max_loans_allowed returns 0 the user doesn't have permission to check out this book
821
    # if TooMany max_loans_allowed returns 0 the user doesn't have permission to check out this book
826
    if (defined $max_loans_allowed && $max_loans_allowed == 0) {
822
    if (defined $max_loans_allowed && $max_loans_allowed == 0) {
827
        $needsconfirmation{PATRON_CANT} = 1;
823
        $needsconfirmation{PATRON_CANT} = 1;
Lines 1179-1185 AddIssue does the following things : Link Here
1179
sub AddIssue {
1175
sub AddIssue {
1180
    my ( $borrower, $barcode, $datedue, $cancelreserve, $issuedate, $sipmode) = @_;
1176
    my ( $borrower, $barcode, $datedue, $cancelreserve, $issuedate, $sipmode) = @_;
1181
    my $dbh = C4::Context->dbh;
1177
    my $dbh = C4::Context->dbh;
1182
	my $barcodecheck=CheckValidBarcode($barcode);
1178
    my $barcodecheck=CheckValidBarcode($barcode);
1183
    if ($datedue && ref $datedue ne 'DateTime') {
1179
    if ($datedue && ref $datedue ne 'DateTime') {
1184
        $datedue = dt_from_string($datedue);
1180
        $datedue = dt_from_string($datedue);
1185
    }
1181
    }
Lines 1193-1234 sub AddIssue { Link Here
1193
1189
1194
        }
1190
        }
1195
    }
1191
    }
1196
	if ($borrower and $barcode and $barcodecheck ne '0'){#??? wtf
1192
    if ($borrower and $barcode and $barcodecheck ne '0'){#??? wtf
1197
		# find which item we issue
1193
        # find which item we issue
1198
		my $item = GetItem('', $barcode) or return;	# if we don't get an Item, abort.
1194
        my $item = GetItem('', $barcode) or return;	# if we don't get an Item, abort.
1199
		my $branch = _GetCircControlBranch($item,$borrower);
1195
        my $branch = _GetCircControlBranch($item,$borrower);
1200
		
1196
        
1201
		# get actual issuing if there is one
1197
        # get actual issuing if there is one
1202
		my $actualissue = GetItemIssue( $item->{itemnumber});
1198
        my $actualissue = GetItemIssue( $item->{itemnumber});
1203
		
1199
        
1204
		# get biblioinformation for this item
1200
        # get biblioinformation for this item
1205
		my $biblio = GetBiblioFromItemNumber($item->{itemnumber});
1201
        my $biblio = GetBiblioFromItemNumber($item->{itemnumber});
1206
		
1202
        
1207
		#
1203
        #
1208
		# check if we just renew the issue.
1204
        # check if we just renew the issue.
1209
		#
1205
        #
1210
		if ($actualissue->{borrowernumber} eq $borrower->{'borrowernumber'}) {
1206
        if ($actualissue->{borrowernumber} eq $borrower->{'borrowernumber'}) {
1211
		    $datedue = AddRenewal(
1207
            $datedue = AddRenewal(
1212
			$borrower->{'borrowernumber'},
1208
            $borrower->{'borrowernumber'},
1213
			$item->{'itemnumber'},
1209
            $item->{'itemnumber'},
1214
			$branch,
1210
            $branch,
1215
			$datedue,
1211
            $datedue,
1216
			$issuedate, # here interpreted as the renewal date
1212
            $issuedate, # here interpreted as the renewal date
1217
			);
1213
            );
1218
		}
1214
        }
1219
		else {
1215
        else {
1220
        # it's NOT a renewal
1216
        # it's NOT a renewal
1221
			if ( $actualissue->{borrowernumber}) {
1217
            if ( $actualissue->{borrowernumber}) {
1222
				# This book is currently on loan, but not to the person
1218
                # This book is currently on loan, but not to the person
1223
				# who wants to borrow it now. mark it returned before issuing to the new borrower
1219
                # who wants to borrow it now. mark it returned before issuing to the new borrower
1224
				AddReturn(
1220
                AddReturn(
1225
					$item->{'barcode'},
1221
                    $item->{'barcode'},
1226
					C4::Context->userenv->{'branch'}
1222
                    C4::Context->userenv->{'branch'}
1227
				);
1223
                );
1228
			}
1224
            }
1229
1225
1230
            MoveReserve( $item->{'itemnumber'}, $borrower->{'borrowernumber'}, $cancelreserve );
1226
            MoveReserve( $item->{'itemnumber'}, $borrower->{'borrowernumber'}, $cancelreserve );
1231
			# Starting process for transfer job (checking transfert and validate it if we have one)
1227
            # Starting process for transfer job (checking transfert and validate it if we have one)
1232
            my ($datesent) = GetTransfers($item->{'itemnumber'});
1228
            my ($datesent) = GetTransfers($item->{'itemnumber'});
1233
            if ($datesent) {
1229
            if ($datesent) {
1234
        # 	updating line of branchtranfert to finish it, and changing the to branch value, implement a comment for visibility of this case (maybe for stats ....)
1230
        # 	updating line of branchtranfert to finish it, and changing the to branch value, implement a comment for visibility of this case (maybe for stats ....)
Lines 1445-1451 sub GetIssuingRule { Link Here
1445
    my $sth =  $dbh->prepare( "select * from issuingrules where categorycode=? and itemtype=? and branchcode=? and issuelength is not null"  );
1441
    my $sth =  $dbh->prepare( "select * from issuingrules where categorycode=? and itemtype=? and branchcode=? and issuelength is not null"  );
1446
    my $irule;
1442
    my $irule;
1447
1443
1448
	$sth->execute( $borrowertype, $itemtype, $branchcode );
1444
    $sth->execute( $borrowertype, $itemtype, $branchcode );
1449
    $irule = $sth->fetchrow_hashref;
1445
    $irule = $sth->fetchrow_hashref;
1450
    return $irule if defined($irule) ;
1446
    return $irule if defined($irule) ;
1451
1447
Lines 1782-1788 sub AddReturn { Link Here
1782
    if ($doreturn) {
1778
    if ($doreturn) {
1783
    my $datedue = $issue->{date_due};
1779
    my $datedue = $issue->{date_due};
1784
        $borrower or warn "AddReturn without current borrower";
1780
        $borrower or warn "AddReturn without current borrower";
1785
		my $circControlBranch;
1781
        my $circControlBranch;
1786
        if ($dropbox) {
1782
        if ($dropbox) {
1787
            # define circControlBranch only if dropbox mode is set
1783
            # define circControlBranch only if dropbox mode is set
1788
            # don't allow dropbox mode to create an invalid entry in issues (issuedate > today)
1784
            # don't allow dropbox mode to create an invalid entry in issues (issuedate > today)
Lines 2596-2622 sub AddRenewal { Link Here
2596
2592
2597
    # Send a renewal slip according to checkout alert preferencei
2593
    # Send a renewal slip according to checkout alert preferencei
2598
    if ( C4::Context->preference('RenewalSendNotice') eq '1') {
2594
    if ( C4::Context->preference('RenewalSendNotice') eq '1') {
2599
	my $borrower = C4::Members::GetMemberDetails( $borrowernumber, 0 );
2595
    my $borrower = C4::Members::GetMemberDetails( $borrowernumber, 0 );
2600
	my $circulation_alert = 'C4::ItemCirculationAlertPreference';
2596
    my $circulation_alert = 'C4::ItemCirculationAlertPreference';
2601
	my %conditions = (
2597
    my %conditions = (
2602
		branchcode   => $branch,
2598
        branchcode   => $branch,
2603
		categorycode => $borrower->{categorycode},
2599
        categorycode => $borrower->{categorycode},
2604
		item_type    => $item->{itype},
2600
        item_type    => $item->{itype},
2605
		notification => 'CHECKOUT',
2601
        notification => 'CHECKOUT',
2606
	);
2602
    );
2607
	if ($circulation_alert->is_enabled_for(\%conditions)) {
2603
    if ($circulation_alert->is_enabled_for(\%conditions)) {
2608
		SendCirculationAlert({
2604
        SendCirculationAlert({
2609
			type     => 'RENEWAL',
2605
            type     => 'RENEWAL',
2610
			item     => $item,
2606
            item     => $item,
2611
		borrower => $borrower,
2607
        borrower => $borrower,
2612
		branch   => $branch,
2608
        branch   => $branch,
2613
		});
2609
        });
2614
	}
2610
    }
2615
    }
2611
    }
2616
2612
2617
    # Log the renewal
2613
    # Log the renewal
2618
    UpdateStats( $branch, 'renew', $charge, '', $itemnumber, $item->{itype}, $borrowernumber, undef, $item->{'ccode'});
2614
    UpdateStats( $branch, 'renew', $charge, '', $itemnumber, $item->{itype}, $borrowernumber, undef, $item->{'ccode'});
2619
	return $datedue;
2615
    return $datedue;
2620
}
2616
}
2621
2617
2622
sub GetRenewCount {
2618
sub GetRenewCount {
Lines 2931-2937 sub SendCirculationAlert { Link Here
2931
    my %message_name = (
2927
    my %message_name = (
2932
        CHECKIN  => 'Item_Check_in',
2928
        CHECKIN  => 'Item_Check_in',
2933
        CHECKOUT => 'Item_Checkout',
2929
        CHECKOUT => 'Item_Checkout',
2934
	RENEWAL  => 'Item_Checkout',
2930
    RENEWAL  => 'Item_Checkout',
2935
    );
2931
    );
2936
    my $borrower_preferences = C4::Members::Messaging::GetMessagingPreferences({
2932
    my $borrower_preferences = C4::Members::Messaging::GetMessagingPreferences({
2937
        borrowernumber => $borrower->{borrowernumber},
2933
        borrowernumber => $borrower->{borrowernumber},
Lines 2979-2998 This function validate the line of brachtransfer but with the wrong destination Link Here
2979
=cut
2975
=cut
2980
2976
2981
sub updateWrongTransfer {
2977
sub updateWrongTransfer {
2982
	my ( $itemNumber,$waitingAtLibrary,$FromLibrary ) = @_;
2978
    my ( $itemNumber,$waitingAtLibrary,$FromLibrary ) = @_;
2983
	my $dbh = C4::Context->dbh;	
2979
    my $dbh = C4::Context->dbh;	
2984
# first step validate the actual line of transfert .
2980
# first step validate the actual line of transfert .
2985
	my $sth =
2981
    my $sth =
2986
        	$dbh->prepare(
2982
            $dbh->prepare(
2987
			"update branchtransfers set datearrived = now(),tobranch=?,comments='wrongtransfer' where itemnumber= ? AND datearrived IS NULL"
2983
            "update branchtransfers set datearrived = now(),tobranch=?,comments='wrongtransfer' where itemnumber= ? AND datearrived IS NULL"
2988
          	);
2984
            );
2989
        	$sth->execute($FromLibrary,$itemNumber);
2985
            $sth->execute($FromLibrary,$itemNumber);
2990
2986
2991
# second step create a new line of branchtransfer to the right location .
2987
# second step create a new line of branchtransfer to the right location .
2992
	ModItemTransfer($itemNumber, $FromLibrary, $waitingAtLibrary);
2988
    ModItemTransfer($itemNumber, $FromLibrary, $waitingAtLibrary);
2993
2989
2994
#third step changing holdingbranch of item
2990
#third step changing holdingbranch of item
2995
	UpdateHoldingbranch($FromLibrary,$itemNumber);
2991
    UpdateHoldingbranch($FromLibrary,$itemNumber);
2996
}
2992
}
2997
2993
2998
=head2 UpdateHoldingbranch
2994
=head2 UpdateHoldingbranch
Lines 3004-3010 Simple methode for updating hodlingbranch in items BDD line Link Here
3004
=cut
3000
=cut
3005
3001
3006
sub UpdateHoldingbranch {
3002
sub UpdateHoldingbranch {
3007
	my ( $branch,$itemnumber ) = @_;
3003
    my ( $branch,$itemnumber ) = @_;
3008
    ModItem({ holdingbranch => $branch }, undef, $itemnumber);
3004
    ModItem({ holdingbranch => $branch }, undef, $itemnumber);
3009
}
3005
}
3010
3006
Lines 3124-3132 sub CheckRepeatableHolidays{ Link Here
3124
my($itemnumber,$week_day,$branchcode)=@_;
3120
my($itemnumber,$week_day,$branchcode)=@_;
3125
my $dbh = C4::Context->dbh;
3121
my $dbh = C4::Context->dbh;
3126
my $query = qq|SELECT count(*)  
3122
my $query = qq|SELECT count(*)  
3127
	FROM repeatable_holidays 
3123
    FROM repeatable_holidays 
3128
	WHERE branchcode=?
3124
    WHERE branchcode=?
3129
	AND weekday=?|;
3125
    AND weekday=?|;
3130
my $sth = $dbh->prepare($query);
3126
my $sth = $dbh->prepare($query);
3131
$sth->execute($branchcode,$week_day);
3127
$sth->execute($branchcode,$week_day);
3132
my $result=$sth->fetchrow;
3128
my $result=$sth->fetchrow;
Lines 3152-3163 sub CheckSpecialHolidays{ Link Here
3152
my ($years,$month,$day,$itemnumber,$branchcode) = @_;
3148
my ($years,$month,$day,$itemnumber,$branchcode) = @_;
3153
my $dbh = C4::Context->dbh;
3149
my $dbh = C4::Context->dbh;
3154
my $query=qq|SELECT count(*) 
3150
my $query=qq|SELECT count(*) 
3155
	     FROM `special_holidays`
3151
         FROM `special_holidays`
3156
	     WHERE year=?
3152
         WHERE year=?
3157
	     AND month=?
3153
         AND month=?
3158
	     AND day=?
3154
         AND day=?
3159
             AND branchcode=?
3155
             AND branchcode=?
3160
	    |;
3156
        |;
3161
my $sth = $dbh->prepare($query);
3157
my $sth = $dbh->prepare($query);
3162
$sth->execute($years,$month,$day,$branchcode);
3158
$sth->execute($years,$month,$day,$branchcode);
3163
my $countspecial=$sth->fetchrow ;
3159
my $countspecial=$sth->fetchrow ;
Lines 3181-3191 sub CheckRepeatableSpecialHolidays{ Link Here
3181
my ($month,$day,$itemnumber,$branchcode) = @_;
3177
my ($month,$day,$itemnumber,$branchcode) = @_;
3182
my $dbh = C4::Context->dbh;
3178
my $dbh = C4::Context->dbh;
3183
my $query=qq|SELECT count(*) 
3179
my $query=qq|SELECT count(*) 
3184
	     FROM `repeatable_holidays`
3180
         FROM `repeatable_holidays`
3185
	     WHERE month=?
3181
         WHERE month=?
3186
	     AND day=?
3182
         AND day=?
3187
             AND branchcode=?
3183
             AND branchcode=?
3188
	    |;
3184
        |;
3189
my $sth = $dbh->prepare($query);
3185
my $sth = $dbh->prepare($query);
3190
$sth->execute($month,$day,$branchcode);
3186
$sth->execute($month,$day,$branchcode);
3191
my $countspecial=$sth->fetchrow ;
3187
my $countspecial=$sth->fetchrow ;
Lines 3198-3212 sub CheckValidBarcode{ Link Here
3198
my ($barcode) = @_;
3194
my ($barcode) = @_;
3199
my $dbh = C4::Context->dbh;
3195
my $dbh = C4::Context->dbh;
3200
my $query=qq|SELECT count(*) 
3196
my $query=qq|SELECT count(*) 
3201
	     FROM items 
3197
         FROM items 
3202
             WHERE barcode=?
3198
             WHERE barcode=?
3203
	    |;
3199
        |;
3204
my $sth = $dbh->prepare($query);
3200
my $sth = $dbh->prepare($query);
3205
$sth->execute($barcode);
3201
$sth->execute($barcode);
3206
my $exist=$sth->fetchrow ;
3202
my $exist=$sth->fetchrow ;
3207
return $exist;
3203
return $exist;
3208
}
3204
}
3209
3205
3206
3207
=head2 CanItemBeTransferred
3208
3209
A convenience function to easily check item transfer limits.
3210
3211
   ($allowed, $errorMessage) = CanItemBeTransferred( $toBranch, $fromBranch, $item, $biblioitem );
3212
   ($allowed, $errorMessage) = CanItemBeTransferred( $toBranch, undef, $item, undef] );
3213
3214
Checks if UseBranchTransferLimits global preference is in use.
3215
Checks if the given item can be transferred from $fromBranch to $toBranch.
3216
This is dependant on the global setting:
3217
* UseBranchTransferLimits
3218
and "Administration" -> "Library transfer limits"
3219
3220
C<$toBranch>   = the transfer destination library's code
3221
C<$fromBranch>     = OPTIONAL, the transfer departure library's code
3222
                     DEFAULT: using the item's holdingbranch
3223
C<$item>  = item-object from items-table
3224
C<$biblioitem>  = OPTIONAL, biblioitem-object, is needed when using CCODE instead if
3225
              using itemtype to limit branch transfers.
3226
              If biblioitem-object is available, it should be provided for performance reasons.
3227
C<returns> if transfer is not allowed: (0, "$fromBranch->$toBranch->transfer limit code")
3228
           (1) if transfer allowed.
3229
=cut
3230
3231
sub CanItemBeTransferred {
3232
3233
    #When we check for BranchTransferLimit global settings centrally, it makes
3234
    #  using this functionality much easier.
3235
    unless ( C4::Context->preference("UseBranchTransferLimits") == 1 ) {
3236
           return 1;
3237
    }
3238
3239
    #Init parameter variables
3240
    my ( $toBranch, $fromBranch, $item, $biblioitem ) = @_;
3241
3242
    #Check the $fromBranch and set the DEFAULT value
3243
    $fromBranch = $item->{holdingbranch} if ! defined $fromBranch;
3244
3245
    if ( $toBranch eq $fromBranch ) { return 1; } ## Short circuit for speed.
3246
3247
    #This is the CCode or itemtype value used to find the correct transfer rule for this item.
3248
    my $code;
3249
3250
    ## Figure out the $code!
3251
    ## First we need to figure out are we using CCODE or itemtype, this limits do we need $biblioitem or not.
3252
    ## Since $biblioitem can be optional, we cannot count that it is defined.
3253
    if ( C4::Context->preference("BranchTransferLimitsType") eq 'itemtype' ) {
3254
            if (C4::Context->preference("item-level_itypes") && defined $item->{'itype'}) {
3255
                    $code = $item->{'itype'}; #Easiest way to get the $code is from the item.
3256
            }
3257
            elsif (defined $biblioitem->{itemtype}) {
3258
                    $code = $biblioitem->{itemtype}
3259
            }
3260
            #If code cannot be resolved from $item or $biblioitem, we need to escalate to the DB
3261
            else {
3262
                    $biblioitem = C4::Biblio::GetBiblioFromItemNumber( $item->{itemnumber} );
3263
                    $code = $biblioitem->{itemtype}
3264
            }
3265
3266
    } else {
3267
            my $limitType = C4::Context->preference("BranchTransferLimitsType");
3268
            if (defined $item->{ $limitType }) {
3269
                    $code = $item->{ $limitType };
3270
            }
3271
            else {
3272
                    #collection code (ccode) is not present in the Biblio, so no point looking there.
3273
                    #  If the Item doesn't have a itemtype, then give up and let the transfer pass.
3274
            }
3275
    }
3276
    ## Phew we finally got the $code, now it's time to rumble!
3277
3278
    if (! IsBranchTransferAllowed($toBranch, $fromBranch, $code)) {
3279
            return 0, "$fromBranch->$toBranch->$code";
3280
    }
3281
    else {
3282
            return 1;
3283
    }
3284
}
3285
3286
3210
=head2 IsBranchTransferAllowed
3287
=head2 IsBranchTransferAllowed
3211
3288
3212
  $allowed = IsBranchTransferAllowed( $toBranch, $fromBranch, $code );
3289
  $allowed = IsBranchTransferAllowed( $toBranch, $fromBranch, $code );
Lines 3216-3238 Code is either an itemtype or collection doe depending on the pref BranchTransfe Link Here
3216
=cut
3293
=cut
3217
3294
3218
sub IsBranchTransferAllowed {
3295
sub IsBranchTransferAllowed {
3219
	my ( $toBranch, $fromBranch, $code ) = @_;
3296
    my ( $toBranch, $fromBranch, $code ) = @_;
3220
3297
3221
	if ( $toBranch eq $fromBranch ) { return 1; } ## Short circuit for speed.
3298
    if ( $toBranch eq $fromBranch ) { return 1; } ## Short circuit for speed.
3222
        
3299
        
3223
	my $limitType = C4::Context->preference("BranchTransferLimitsType");   
3300
    my $limitType = C4::Context->preference("BranchTransferLimitsType");   
3224
	my $dbh = C4::Context->dbh;
3301
    my $dbh = C4::Context->dbh;
3225
            
3302
            
3226
	my $sth = $dbh->prepare("SELECT * FROM branch_transfer_limits WHERE toBranch = ? AND fromBranch = ? AND $limitType = ?");
3303
    my $sth = $dbh->prepare("SELECT * FROM branch_transfer_limits WHERE toBranch = ? AND fromBranch = ? AND $limitType = ?");
3227
	$sth->execute( $toBranch, $fromBranch, $code );
3304
    $sth->execute( $toBranch, $fromBranch, $code );
3228
	my $limit = $sth->fetchrow_hashref();
3305
    my $limit = $sth->fetchrow_hashref();
3229
                        
3306
                        
3230
	## If a row is found, then that combination is not allowed, if no matching row is found, then the combination *is allowed*
3307
    ## If a row is found, then that combination is not allowed, if no matching row is found, then the combination *is allowed*
3231
	if ( $limit->{'limitId'} ) {
3308
    if ( $limit->{'limitId'} ) {
3232
		return 0;
3309
        return 0;
3233
	} else {
3310
    } else {
3234
		return 1;
3311
        return 1;
3235
	}
3312
    }
3236
}                                                        
3313
}                                                        
3237
3314
3238
=head2 CreateBranchTransferLimit
3315
=head2 CreateBranchTransferLimit
(-)a/circ/branchtransfers.pl (-2 / +3 lines)
Lines 206-215 foreach my $code ( keys %$messages ) { Link Here
206
            $err{errbadcode} = 1;
206
            $err{errbadcode} = 1;
207
        }
207
        }
208
        elsif ( $code eq "NotAllowed" ) {
208
        elsif ( $code eq "NotAllowed" ) {
209
            warn "NotAllowed: $messages->{'NotAllowed'} to  " . $branches->{ $messages->{'NotAllowed'} }->{'branchname'};
209
            warn "NotAllowed: $messages->{'NotAllowed'} to  " . $branches->{ $messages->{'NotAllowed'} }->{'branchname'} if $ENV{DEBUG};
210
210
            # Do we really want a error log message here? --atz
211
            # Do we really want a error log message here? --atz
211
            $err{errnotallowed} =  1;
212
            $err{errnotallowed} =  1;
212
            my ( $tbr, $typecode ) = split( /::/,  $messages->{'NotAllowed'} );
213
            my ( $fbr, $tbr, $typecode ) = split( '->',  $messages->{'NotAllowed'} );
213
            $err{tbr}      = $branches->{ $tbr }->{'branchname'};
214
            $err{tbr}      = $branches->{ $tbr }->{'branchname'};
214
            $err{code}     = $typecode;
215
            $err{code}     = $typecode;
215
            $err{codeType} = $codeTypeDescription;
216
            $err{codeType} = $codeTypeDescription;
(-)a/t/db_dependent/Circulation/CanItemBeTransferred.t (-1 / +262 lines)
Line 0 Link Here
0
- 
1
use Modern::Perl;
2
use Test::More tests => 20;
3
4
use C4::Circulation;
5
use C4::Context;
6
use C4::Record;
7
8
my $dbh = C4::Context->dbh;
9
$dbh->{AutoCommit} = 0;
10
$dbh->{RaiseError} = 1;
11
12
my $originalBranchTransferLimitsType = C4::Context->preference('BranchTransferLimitsType');
13
14
### Preparing our tests we want to run ###
15
sub runTestsForCCode {
16
    my ($itemCPLFull, $itemCPLLite, $biblioitem) = @_;
17
18
    print 'Running tests for '.C4::Context->preference("BranchTransferLimitsType")."\n";
19
20
    #howto use:               CanItemBeTransferred( $toBranch, $fromBranch, $item, $biblioitem] );
21
    my $result = C4::Circulation::CanItemBeTransferred( 'CPL', 'IPT', $itemCPLFull, $biblioitem );
22
    is ( $result, 1, "Successful branch transfer, full parameters" );
23
24
    $result = C4::Circulation::CanItemBeTransferred( 'IPT', 'CPL', $itemCPLFull, $biblioitem );
25
    is ( $result, 'CPL->IPT->FANTASY', "Failing branch transfer, full parameters" );
26
27
    $result = C4::Circulation::CanItemBeTransferred( 'CPL', 'IPT', $itemCPLFull, undef );
28
    is ( $result, 1, "Successful branch transfer, full parameters, no Biblio defined" );
29
30
    $result = C4::Circulation::CanItemBeTransferred( 'IPT', 'CPL', $itemCPLFull, undef );
31
    is ( $result, 'CPL->IPT->FANTASY', "Failing branch transfer, full parameters, no Biblio defined" );
32
33
    $result = C4::Circulation::CanItemBeTransferred( 'FFL', undef, $itemCPLFull, $biblioitem );
34
    is ( $result, 1, "Successful branch transfer, using defaults for \$fromBranch" );
35
36
    $result = C4::Circulation::CanItemBeTransferred( 'IPT', undef, $itemCPLFull, $biblioitem );
37
    is ( $result, 'CPL->IPT->FANTASY', "Failing branch transfer, using defaults for \$fromBranch" );
38
39
    $result = C4::Circulation::CanItemBeTransferred( 'FFL', undef, $itemCPLFull, undef );
40
    is ( $result, 1, "Successful branch transfer, using minimum parameters" );
41
42
    $result = C4::Circulation::CanItemBeTransferred( 'IPT', undef, $itemCPLFull, undef );
43
    is ( $result, 'CPL->IPT->FANTASY', "Failing branch transfer, using minimum parameters" );
44
45
    $result = C4::Circulation::CanItemBeTransferred( 'FFL', undef, $itemCPLLite, undef );
46
    is ( $result, 1, "Successful branch transfer, using minimum parameters" );
47
48
    $result = C4::Circulation::CanItemBeTransferred( 'IPT', undef, $itemCPLLite, undef );
49
    is ( $result, 1, "Not failing branch transfer, because CCODE cannot be found from the item and it is not a part of the biblio." );
50
}
51
52
53
sub runTestsForItype {
54
    my ($itemCPLFull, $itemCPLLite, $biblioitem) = @_;
55
56
    print 'Running tests for '.C4::Context->preference("BranchTransferLimitsType")."\n";
57
58
    #howto use:               CanItemBeTransferred( $toBranch, $fromBranch, $item, $biblioitem] );
59
    my $result = C4::Circulation::CanItemBeTransferred( 'CPL', 'IPT', $itemCPLFull, $biblioitem );
60
    is ( $result, 1, "Successful branch transfer, full parameters" );
61
62
    $result = C4::Circulation::CanItemBeTransferred( 'IPT', 'CPL', $itemCPLFull, $biblioitem );
63
    is ( $result, 'CPL->IPT->BK', "Failing branch transfer, full parameters" );
64
65
    $result = C4::Circulation::CanItemBeTransferred( 'CPL', 'IPT', $itemCPLFull, undef );
66
    is ( $result, 1, "Successful branch transfer, full parameters, no Biblio defined" );
67
68
    $result = C4::Circulation::CanItemBeTransferred( 'IPT', 'CPL', $itemCPLFull, undef );
69
    is ( $result, 'CPL->IPT->BK', "Failing branch transfer, full parameters, no Biblio defined" );
70
71
    $result = C4::Circulation::CanItemBeTransferred( 'FFL', undef, $itemCPLFull, $biblioitem );
72
    is ( $result, 1, "Successful branch transfer, using defaults for \$fromBranch" );
73
74
    $result = C4::Circulation::CanItemBeTransferred( 'IPT', undef, $itemCPLFull, $biblioitem );
75
    is ( $result, 'CPL->IPT->BK', "Failing branch transfer, using defaults for \$fromBranch" );
76
77
    $result = C4::Circulation::CanItemBeTransferred( 'FFL', undef, $itemCPLFull, undef );
78
    is ( $result, 1, "Successful branch transfer, using minimum parameters" );
79
80
    $result = C4::Circulation::CanItemBeTransferred( 'IPT', undef, $itemCPLFull, undef );
81
    is ( $result, 'CPL->IPT->BK', "Failing branch transfer, using minimum parameters" );
82
83
    $result = C4::Circulation::CanItemBeTransferred( 'FFL', undef, $itemCPLLite, undef );
84
    is ( $result, 1, "Successful branch transfer, using minimum parameters, itemtype is pulled from Biblio" );
85
86
    $result = C4::Circulation::CanItemBeTransferred( 'IPT', undef, $itemCPLLite, undef );
87
    is ( $result, 'CPL->IPT->BK', "Failing branch transfer, using minimum parameters, itemtype is pulled from Biblio" );
88
}
89
### Tests prepared
90
91
### Preparing our generic testing data ###
92
93
#Set the item variables
94
my $ccode = 'FANTASY';
95
my $itemtype = 'BK';
96
97
## Add a example Bibliographic record
98
my $bibFramework = ''; #Using the default bibliographic framework.
99
my $marcxml;
100
if ( C4::Context->preference("marcflavour") eq "UNIMARC" ) {
101
    $marcxml=qq(
102
    <?xml version="1.0" encoding="UTF-8"?>
103
    <record
104
        xmlns:xsi="http://www.w3.org/2001/XMLSchema-instance"
105
        xsi:schemaLocation="http://www.loc.gov/MARC21/slim http://www.loc.gov/standards/marcxml/schema/MARC21slim.xsd"
106
        xmlns="http://www.loc.gov/MARC21/slim">
107
      <leader>01534njm a2200229   4500</leader>
108
      <controlfield tag="001">4172</controlfield>
109
      <datafield tag="071" ind1=" " ind2=" ">
110
        <subfield code="a">8344482</subfield>
111
      </datafield>
112
      <datafield tag="090" ind1=" " ind2=" ">
113
        <subfield code="a">4172</subfield>
114
      </datafield>
115
      <datafield tag="100" ind1=" " ind2=" ">
116
        <subfield code="a">20040408              frey50        </subfield>
117
      </datafield>
118
      <datafield tag="126" ind1=" " ind2=" ">
119
        <subfield code="a">agbxhx       cd</subfield>
120
      </datafield>
121
      <datafield tag="200" ind1="1" ind2=" ">
122
        <subfield code="a">The Beatles anthology 1965-1967</subfield>
123
        <subfield code="e">vol.2</subfield>
124
        <subfield code="f">The Beatles</subfield>
125
        <subfield code="b">CD</subfield>
126
      </datafield>
127
      <datafield tag="210" ind1=" " ind2="1">
128
        <subfield code="a">Null</subfield>
129
        <subfield code="c">Emi music</subfield>
130
        <subfield code="d">1996</subfield>
131
      </datafield>
132
      <datafield tag="322" ind1=" " ind2="1">
133
        <subfield code="a">anthologie des beatles concernant l'&#xE9;poque musicale de 1965 &#xE0; 1968 p&#xE9;riode la plus exp&#xE9;rimentale et prolifique du groupe</subfield>
134
      </datafield>
135
      <datafield tag="327" ind1="1" ind2=" ">
136
        <subfield code="a">Real love</subfield>
137
        <subfield code="a">Yes it is</subfield>
138
      </datafield>
139
      <datafield tag="345" ind1=" " ind2=" ">
140
        <subfield code="a">CVS</subfield>
141
        <subfield code="b">0724383444823</subfield>
142
        <subfield code="c">disque compact</subfield>
143
        <subfield code="d">34 E</subfield>
144
      </datafield>
145
    </record>
146
    );
147
}
148
else { # Using Marc21 by default
149
    $marcxml=qq(<?xml version="1.0" encoding="UTF-8"?>
150
    <record format="MARC21" type="Bibliographic">
151
      <leader>00000cim a22000004a 4500</leader>
152
      <controlfield tag="001">1001</controlfield>
153
      <controlfield tag="005">2013-06-03 07:04:07+02</controlfield>
154
      <controlfield tag="007">ss||||j|||||||</controlfield>
155
      <controlfield tag="008">       uuuu    xxk|||||||||||||||||eng|c</controlfield>
156
      <datafield tag="020" ind1=" " ind2=" ">
157
        <subfield code="a">0-00-103147-3</subfield>
158
        <subfield code="c">14.46 EUR</subfield>
159
      </datafield>
160
      <datafield tag="041" ind1="0" ind2=" ">
161
        <subfield code="d">eng</subfield>
162
      </datafield>
163
      <datafield tag="084" ind1=" " ind2=" ">
164
        <subfield code="a">83.5</subfield>
165
        <subfield code="2">ykl</subfield>
166
      </datafield>
167
      <datafield tag="100" ind1="1" ind2=" ">
168
        <subfield code="a">SHAKESPEARE, WILLIAM.</subfield>
169
      </datafield>
170
      <datafield tag="245" ind1="1" ind2="4">
171
        <subfield code="a">THE TAMING OF THE SHREW /</subfield>
172
        <subfield code="c">WILLIAM SHAKESPEARE</subfield>
173
        <subfield code="h">[ÄÄNITE].</subfield>
174
      </datafield>
175
      <datafield tag="260" ind1=" " ind2=" ">
176
        <subfield code="a">LONDON :</subfield>
177
        <subfield code="b">COLLINS.</subfield>
178
      </datafield>
179
      <datafield tag="300" ind1=" " ind2=" ">
180
        <subfield code="a">2 ÄÄNIKASETTIA.</subfield>
181
      </datafield>
182
      <datafield tag="852" ind1=" " ind2=" ">
183
        <subfield code="a">FI-Jm</subfield>
184
        <subfield code="h">83.5</subfield>
185
      </datafield>
186
      <datafield tag="852" ind1=" " ind2=" ">
187
        <subfield code="a">FI-Konti</subfield>
188
        <subfield code="h">83.5</subfield>
189
      </datafield>
190
    </record>
191
    );
192
}
193
194
my $record=C4::Record::marcxml2marc($marcxml);
195
196
# This should work regardless of the Marc flavour.
197
my ( $biblioitemtypeTagid, $biblioitemtypeSubfieldid ) =
198
            C4::Biblio::GetMarcFromKohaField( 'biblioitems.itemtype', $bibFramework );
199
my $itemtypeField = MARC::Field->new($biblioitemtypeTagid, '', '',
200
                                     $biblioitemtypeSubfieldid => $itemtype);
201
$record->append_fields( $itemtypeField );
202
203
my ( $newBiblionumber, $newBiblioitemnumber ) = C4::Biblio::AddBiblio( $record, $bibFramework, { defer_marc_save => 1 } );
204
205
## Add an item with a ccode.
206
my ($item_bibnum, $item_bibitemnum);
207
my ($itemCPLFull, $itemCPLFullId); #Item with a itemtype and ccode in its data.
208
my ($itemCPLLite, $itemCPLLiteId); #Item with no itemtype nor ccode in its data. Forces to look for it from the biblio.
209
($item_bibnum, $item_bibitemnum, $itemCPLFullId) = C4::Items::AddItem({ barcode => 'CPLFull', homebranch => 'CPL', holdingbranch => 'CPL', ccode => $ccode, itemtype => $itemtype}, $newBiblionumber);#, biblioitemnumber => $newBiblioitemnumber, biblionumber => $newBiblioitemnumber });
210
($item_bibnum, $item_bibitemnum, $itemCPLLiteId) = C4::Items::AddItem({ barcode => 'CPLLite', homebranch => 'CPL', holdingbranch => 'CPL'}, $newBiblionumber);# biblioitemnumber => $newBiblioitemnumber, biblionumber => $newBiblioitemnumber });
211
212
213
### Created the generic testing material. ###
214
### Setting preferences for ccode use-case ###
215
216
C4::Context->set_preference("BranchTransferLimitsType", 'ccode');
217
218
## Add the TransferLimit rules:
219
## IPT -> CPL -> FFL -> IPT
220
#                                            to     from
221
C4::Circulation::CreateBranchTransferLimit( 'IPT', 'CPL', $ccode );
222
C4::Circulation::CreateBranchTransferLimit( 'CPL', 'FFL', $ccode );
223
C4::Circulation::CreateBranchTransferLimit( 'FFL', 'IPT', $ccode );
224
225
## Ready to start testing ccode use-case ##
226
227
$itemCPLFull = C4::Items::GetItem($itemCPLFullId);
228
$itemCPLLite = C4::Items::GetItem($itemCPLLiteId);
229
my $biblioitem = C4::Biblio::GetBiblioFromItemNumber( $itemCPLFull->{itemnumber} );
230
231
232
runTestsForCCode($itemCPLFull, $itemCPLLite, $biblioitem);
233
234
235
236
### ccode tested
237
### Setting preferences for itemtype use-case ###
238
239
C4::Context->set_preference("BranchTransferLimitsType", 'itemtype');
240
241
## Add the TransferLimit rules:
242
## IPT -> CPL -> FFL -> IPT
243
#                                            to     from
244
C4::Circulation::CreateBranchTransferLimit( 'IPT', 'CPL', $itemtype );
245
C4::Circulation::CreateBranchTransferLimit( 'CPL', 'FFL', $itemtype );
246
C4::Circulation::CreateBranchTransferLimit( 'FFL', 'IPT', $itemtype );
247
248
## Ready to start testing itemtype use-case ##
249
250
$itemCPLFull = C4::Items::GetItem($itemCPLFullId);
251
$itemCPLLite = C4::Items::GetItem($itemCPLLiteId);
252
$biblioitem = C4::Biblio::GetBiblioFromItemNumber( $itemCPLFull->{itemnumber} );
253
254
255
runTestsForItype($itemCPLFull, $itemCPLLite, $biblioitem);
256
257
### itemtype tested
258
259
### Reset default preferences
260
C4::Context->set_preference("BranchTransferLimitsType", $originalBranchTransferLimitsType);
261
262
$dbh->rollback;

Return to bug 11005