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

(-)a/C4/Circulation.pm (-159 / +236 lines)
Lines 61-73 use Date::Calc qw( Link Here
61
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
61
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
62
62
63
BEGIN {
63
BEGIN {
64
	require Exporter;
64
    require Exporter;
65
    $VERSION = 3.07.00.049;	# for version checking
65
    $VERSION = 3.07.00.049;	# for version checking
66
	@ISA    = qw(Exporter);
66
    @ISA    = qw(Exporter);
67
67
68
	# FIXME subs that should probably be elsewhere
68
    # FIXME subs that should probably be elsewhere
69
	push @EXPORT, qw(
69
    push @EXPORT, qw(
70
		&barcodedecode
70
        &barcodedecode
71
        &LostItem
71
        &LostItem
72
        &ReturnLostItem
72
        &ReturnLostItem
73
	);
73
	);
Lines 86-116 BEGIN { Link Here
86
		&GetIssuingRule
86
		&GetIssuingRule
87
        &GetBranchBorrowerCircRule
87
        &GetBranchBorrowerCircRule
88
        &GetBranchItemRule
88
        &GetBranchItemRule
89
		&GetBiblioIssues
89
        &GetBiblioIssues
90
		&GetOpenIssue
90
        &GetOpenIssue
91
		&AnonymiseIssueHistory
91
        &AnonymiseIssueHistory
92
        &CheckIfIssuedToPatron
92
        &CheckIfIssuedToPatron
93
        &IsItemIssued
93
        &IsItemIssued
94
	);
94
    );
95
95
96
	# subs to deal with returns
96
    # subs to deal with returns
97
	push @EXPORT, qw(
97
    push @EXPORT, qw(
98
		&AddReturn
98
        &AddReturn
99
        &MarkIssueReturned
99
        &MarkIssueReturned
100
	);
100
    );
101
101
102
	# subs to deal with transfers
102
    # subs to deal with transfers
103
	push @EXPORT, qw(
103
    push @EXPORT, qw(
104
		&transferbook
104
        &transferbook
105
		&GetTransfers
105
        &GetTransfers
106
		&GetTransfersFromTo
106
        &GetTransfersFromTo
107
		&updateWrongTransfer
107
        &updateWrongTransfer
108
		&DeleteTransfer
108
        &DeleteTransfer
109
                &CanItemBeTransferred
109
                &IsBranchTransferAllowed
110
                &IsBranchTransferAllowed
110
                &CreateBranchTransferLimit
111
                &CreateBranchTransferLimit
111
                &DeleteBranchTransferLimits
112
                &DeleteBranchTransferLimits
112
        &TransferSlip
113
        &TransferSlip
113
	);
114
    );
114
115
115
    # subs to deal with offline circulation
116
    # subs to deal with offline circulation
116
    push @EXPORT, qw(
117
    push @EXPORT, qw(
Lines 163-192 sub barcodedecode { Link Here
163
    my $branch = C4::Branch::mybranch();
164
    my $branch = C4::Branch::mybranch();
164
    $filter = C4::Context->preference('itemBarcodeInputFilter') unless $filter;
165
    $filter = C4::Context->preference('itemBarcodeInputFilter') unless $filter;
165
    $filter or return $barcode;     # ensure filter is defined, else return untouched barcode
166
    $filter or return $barcode;     # ensure filter is defined, else return untouched barcode
166
	if ($filter eq 'whitespace') {
167
    if ($filter eq 'whitespace') {
167
		$barcode =~ s/\s//g;
168
        $barcode =~ s/\s//g;
168
	} elsif ($filter eq 'cuecat') {
169
    } elsif ($filter eq 'cuecat') {
169
		chomp($barcode);
170
        chomp($barcode);
170
	    my @fields = split( /\./, $barcode );
171
        my @fields = split( /\./, $barcode );
171
	    my @results = map( decode($_), @fields[ 1 .. $#fields ] );
172
        my @results = map( decode($_), @fields[ 1 .. $#fields ] );
172
	    ($#results == 2) and return $results[2];
173
        ($#results == 2) and return $results[2];
173
	} elsif ($filter eq 'T-prefix') {
174
    } elsif ($filter eq 'T-prefix') {
174
		if ($barcode =~ /^[Tt](\d)/) {
175
        if ($barcode =~ /^[Tt](\d)/) {
175
			(defined($1) and $1 eq '0') and return $barcode;
176
            (defined($1) and $1 eq '0') and return $barcode;
176
            $barcode = substr($barcode, 2) + 0;     # FIXME: probably should be substr($barcode, 1)
177
            $barcode = substr($barcode, 2) + 0;     # FIXME: probably should be substr($barcode, 1)
177
		}
178
        }
178
        return sprintf("T%07d", $barcode);
179
        return sprintf("T%07d", $barcode);
179
        # FIXME: $barcode could be "T1", causing warning: substr outside of string
180
        # FIXME: $barcode could be "T1", causing warning: substr outside of string
180
        # Why drop the nonzero digit after the T?
181
        # Why drop the nonzero digit after the T?
181
        # Why pass non-digits (or empty string) to "T%07d"?
182
        # Why pass non-digits (or empty string) to "T%07d"?
182
	} elsif ($filter eq 'libsuite8') {
183
    } elsif ($filter eq 'libsuite8') {
183
		unless($barcode =~ m/^($branch)-/i){	#if barcode starts with branch code its in Koha style. Skip it.
184
        unless($barcode =~ m/^($branch)-/i){	#if barcode starts with branch code its in Koha style. Skip it.
184
			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
185
            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
185
                                $barcode =~ s/^[0]*(\d+)$/$branch-b-$1/i;
186
                                $barcode =~ s/^[0]*(\d+)$/$branch-b-$1/i;
186
                        }else{
187
                        }else{
187
				$barcode =~ s/^(\D+)[0]*(\d+)$/$branch-$1-$2/i;
188
                $barcode =~ s/^(\D+)[0]*(\d+)$/$branch-$1-$2/i;
188
			}
189
            }
189
		}
190
        }
190
    } elsif ($filter eq 'EAN13') {
191
    } elsif ($filter eq 'EAN13') {
191
        my $ean = CheckDigits('ean');
192
        my $ean = CheckDigits('ean');
192
        if ( $ean->is_valid($barcode) ) {
193
        if ( $ean->is_valid($barcode) ) {
Lines 195-201 sub barcodedecode { Link Here
195
        } else {
196
        } else {
196
            warn "# [$barcode] not valid EAN-13/UPC-A\n";
197
            warn "# [$barcode] not valid EAN-13/UPC-A\n";
197
        }
198
        }
198
	}
199
    }
199
    return $barcode;    # return barcode, modified or not
200
    return $barcode;    # return barcode, modified or not
200
}
201
}
201
202
Lines 301-307 sub transferbook { Link Here
301
    my $messages;
302
    my $messages;
302
    my $dotransfer      = 1;
303
    my $dotransfer      = 1;
303
    my $branches        = GetBranches();
304
    my $branches        = GetBranches();
304
    my $itemnumber = GetItemnumberFromBarcode( $barcode );
305
    my $item = GetItem(undef,$barcode,undef);
306
    my $itemnumber = $item->{itemnumber};
305
    my $issue      = GetItemIssue($itemnumber);
307
    my $issue      = GetItemIssue($itemnumber);
306
    my $biblio = GetBiblioFromItemNumber($itemnumber);
308
    my $biblio = GetBiblioFromItemNumber($itemnumber);
307
309
Lines 316-331 sub transferbook { Link Here
316
    my $fbr = $biblio->{'holdingbranch'};
318
    my $fbr = $biblio->{'holdingbranch'};
317
319
318
    # if using Branch Transfer Limits
320
    # if using Branch Transfer Limits
319
    if ( C4::Context->preference("UseBranchTransferLimits") == 1 ) {
321
    my $errMsg;
320
        if ( C4::Context->preference("item-level_itypes") && C4::Context->preference("BranchTransferLimitsType") eq 'itemtype' ) {
322
    ($dotransfer, $errMsg) = CanItemBeTransferred( $tbr, $fbr, $item, $biblio );
321
            if ( ! IsBranchTransferAllowed( $tbr, $fbr, $biblio->{'itype'} ) ) {
323
    if ( ! $dotransfer ) {
322
                $messages->{'NotAllowed'} = $tbr . "::" . $biblio->{'itype'};
324
        $messages->{'NotAllowed'} = $errMsg;
323
                $dotransfer = 0;
324
            }
325
        } elsif ( ! IsBranchTransferAllowed( $tbr, $fbr, $biblio->{ C4::Context->preference("BranchTransferLimitsType") } ) ) {
326
            $messages->{'NotAllowed'} = $tbr . "::" . $biblio->{ C4::Context->preference("BranchTransferLimitsType") };
327
            $dotransfer = 0;
328
    	}
329
    }
325
    }
330
326
331
    # if is permanent...
327
    # if is permanent...
Lines 373-387 sub transferbook { Link Here
373
sub TooMany {
369
sub TooMany {
374
    my $borrower        = shift;
370
    my $borrower        = shift;
375
    my $biblionumber = shift;
371
    my $biblionumber = shift;
376
	my $item		= shift;
372
    my $item		= shift;
377
    my $cat_borrower    = $borrower->{'categorycode'};
373
    my $cat_borrower    = $borrower->{'categorycode'};
378
    my $dbh             = C4::Context->dbh;
374
    my $dbh             = C4::Context->dbh;
379
	my $branch;
375
    my $branch;
380
	# Get which branchcode we need
376
    # Get which branchcode we need
381
	$branch = _GetCircControlBranch($item,$borrower);
377
    $branch = _GetCircControlBranch($item,$borrower);
382
	my $type = (C4::Context->preference('item-level_itypes')) 
378
    my $type = (C4::Context->preference('item-level_itypes'))
383
  			? $item->{'itype'}         # item-level
379
            ? $item->{'itype'}         # item-level
384
			: $item->{'itemtype'};     # biblio-level
380
            : $item->{'itemtype'};     # biblio-level
385
 
381
 
386
    # given branch, patron category, and item type, determine
382
    # given branch, patron category, and item type, determine
387
    # applicable issuing rule
383
    # applicable issuing rule
Lines 698-712 sub CanBookBeIssued { Link Here
698
694
699
    my $item = GetItem(GetItemnumberFromBarcode( $barcode ));
695
    my $item = GetItem(GetItemnumberFromBarcode( $barcode ));
700
    my $issue = GetItemIssue($item->{itemnumber});
696
    my $issue = GetItemIssue($item->{itemnumber});
701
	my $biblioitem = GetBiblioItemData($item->{biblioitemnumber});
697
    my $biblioitem = GetBiblioItemData($item->{biblioitemnumber});
702
	$item->{'itemtype'}=$item->{'itype'}; 
698
    $item->{'itemtype'}=$item->{'itype'};
703
    my $dbh             = C4::Context->dbh;
699
    my $dbh             = C4::Context->dbh;
704
700
705
    # MANDATORY CHECKS - unless item exists, nothing else matters
701
    # MANDATORY CHECKS - unless item exists, nothing else matters
706
    unless ( $item->{barcode} ) {
702
    unless ( $item->{barcode} ) {
707
        $issuingimpossible{UNKNOWN_BARCODE} = 1;
703
        $issuingimpossible{UNKNOWN_BARCODE} = 1;
708
    }
704
    }
709
	return ( \%issuingimpossible, \%needsconfirmation ) if %issuingimpossible;
705
    return ( \%issuingimpossible, \%needsconfirmation ) if %issuingimpossible;
710
706
711
    #
707
    #
712
    # DUE DATE is OK ? -- should already have checked.
708
    # DUE DATE is OK ? -- should already have checked.
Lines 739-745 sub CanBookBeIssued { Link Here
739
    # BORROWER STATUS
735
    # BORROWER STATUS
740
    #
736
    #
741
    if ( $borrower->{'category_type'} eq 'X' && (  $item->{barcode}  )) { 
737
    if ( $borrower->{'category_type'} eq 'X' && (  $item->{barcode}  )) { 
742
    	# stats only borrower -- add entry to statistics table, and return issuingimpossible{STATS} = 1  .
738
        # stats only borrower -- add entry to statistics table, and return issuingimpossible{STATS} = 1  .
743
        &UpdateStats(C4::Context->userenv->{'branch'},'localuse','','',$item->{'itemnumber'},$item->{'itemtype'},$borrower->{'borrowernumber'}, undef, $item->{'ccode'});
739
        &UpdateStats(C4::Context->userenv->{'branch'},'localuse','','',$item->{'itemnumber'},$item->{'itemtype'},$borrower->{'borrowernumber'}, undef, $item->{'ccode'});
744
        ModDateLastSeen( $item->{'itemnumber'} );
740
        ModDateLastSeen( $item->{'itemnumber'} );
745
        return( { STATS => 1 }, {});
741
        return( { STATS => 1 }, {});
Lines 809-820 sub CanBookBeIssued { Link Here
809
    my ($blocktype, $count) = C4::Members::IsMemberBlocked($borrower->{'borrowernumber'});
805
    my ($blocktype, $count) = C4::Members::IsMemberBlocked($borrower->{'borrowernumber'});
810
    if ($blocktype == -1) {
806
    if ($blocktype == -1) {
811
        ## patron has outstanding overdue loans
807
        ## patron has outstanding overdue loans
812
	    if ( C4::Context->preference("OverduesBlockCirc") eq 'block'){
808
        if ( C4::Context->preference("OverduesBlockCirc") eq 'block'){
813
	        $issuingimpossible{USERBLOCKEDOVERDUE} = $count;
809
            $issuingimpossible{USERBLOCKEDOVERDUE} = $count;
814
	    }
810
        }
815
	    elsif ( C4::Context->preference("OverduesBlockCirc") eq 'confirmation'){
811
        elsif ( C4::Context->preference("OverduesBlockCirc") eq 'confirmation'){
816
	        $needsconfirmation{USERBLOCKEDOVERDUE} = $count;
812
            $needsconfirmation{USERBLOCKEDOVERDUE} = $count;
817
	    }
813
        }
818
    } elsif($blocktype == 1) {
814
    } elsif($blocktype == 1) {
819
        # patron has accrued fine days
815
        # patron has accrued fine days
820
        $issuingimpossible{USERBLOCKEDREMAINING} = $count;
816
        $issuingimpossible{USERBLOCKEDREMAINING} = $count;
Lines 823-829 sub CanBookBeIssued { Link Here
823
#
819
#
824
    # JB34 CHECKS IF BORROWERS DONT HAVE ISSUE TOO MANY BOOKS
820
    # JB34 CHECKS IF BORROWERS DONT HAVE ISSUE TOO MANY BOOKS
825
    #
821
    #
826
	my ($current_loan_count, $max_loans_allowed) = TooMany( $borrower, $item->{biblionumber}, $item );
822
    my ($current_loan_count, $max_loans_allowed) = TooMany( $borrower, $item->{biblionumber}, $item );
827
    # if TooMany max_loans_allowed returns 0 the user doesn't have permission to check out this book
823
    # if TooMany max_loans_allowed returns 0 the user doesn't have permission to check out this book
828
    if (defined $max_loans_allowed && $max_loans_allowed == 0) {
824
    if (defined $max_loans_allowed && $max_loans_allowed == 0) {
829
        $needsconfirmation{PATRON_CANT} = 1;
825
        $needsconfirmation{PATRON_CANT} = 1;
Lines 1178-1184 AddIssue does the following things : Link Here
1178
sub AddIssue {
1174
sub AddIssue {
1179
    my ( $borrower, $barcode, $datedue, $cancelreserve, $issuedate, $sipmode) = @_;
1175
    my ( $borrower, $barcode, $datedue, $cancelreserve, $issuedate, $sipmode) = @_;
1180
    my $dbh = C4::Context->dbh;
1176
    my $dbh = C4::Context->dbh;
1181
	my $barcodecheck=CheckValidBarcode($barcode);
1177
    my $barcodecheck=CheckValidBarcode($barcode);
1182
    if ($datedue && ref $datedue ne 'DateTime') {
1178
    if ($datedue && ref $datedue ne 'DateTime') {
1183
        $datedue = dt_from_string($datedue);
1179
        $datedue = dt_from_string($datedue);
1184
    }
1180
    }
Lines 1192-1233 sub AddIssue { Link Here
1192
1188
1193
        }
1189
        }
1194
    }
1190
    }
1195
	if ($borrower and $barcode and $barcodecheck ne '0'){#??? wtf
1191
    if ($borrower and $barcode and $barcodecheck ne '0'){#??? wtf
1196
		# find which item we issue
1192
        # find which item we issue
1197
		my $item = GetItem('', $barcode) or return;	# if we don't get an Item, abort.
1193
        my $item = GetItem('', $barcode) or return;	# if we don't get an Item, abort.
1198
		my $branch = _GetCircControlBranch($item,$borrower);
1194
        my $branch = _GetCircControlBranch($item,$borrower);
1199
		
1195
1200
		# get actual issuing if there is one
1196
        # get actual issuing if there is one
1201
		my $actualissue = GetItemIssue( $item->{itemnumber});
1197
        my $actualissue = GetItemIssue( $item->{itemnumber});
1202
		
1198
1203
		# get biblioinformation for this item
1199
        # get biblioinformation for this item
1204
		my $biblio = GetBiblioFromItemNumber($item->{itemnumber});
1200
        my $biblio = GetBiblioFromItemNumber($item->{itemnumber});
1205
		
1201
1206
		#
1202
        #
1207
		# check if we just renew the issue.
1203
        # check if we just renew the issue.
1208
		#
1204
        #
1209
		if ($actualissue->{borrowernumber} eq $borrower->{'borrowernumber'}) {
1205
        if ($actualissue->{borrowernumber} eq $borrower->{'borrowernumber'}) {
1210
		    $datedue = AddRenewal(
1206
            $datedue = AddRenewal(
1211
			$borrower->{'borrowernumber'},
1207
            $borrower->{'borrowernumber'},
1212
			$item->{'itemnumber'},
1208
            $item->{'itemnumber'},
1213
			$branch,
1209
            $branch,
1214
			$datedue,
1210
            $datedue,
1215
			$issuedate, # here interpreted as the renewal date
1211
            $issuedate, # here interpreted as the renewal date
1216
			);
1212
            );
1217
		}
1213
        }
1218
		else {
1214
        else {
1219
        # it's NOT a renewal
1215
        # it's NOT a renewal
1220
			if ( $actualissue->{borrowernumber}) {
1216
            if ( $actualissue->{borrowernumber}) {
1221
				# This book is currently on loan, but not to the person
1217
                # This book is currently on loan, but not to the person
1222
				# who wants to borrow it now. mark it returned before issuing to the new borrower
1218
                # who wants to borrow it now. mark it returned before issuing to the new borrower
1223
				AddReturn(
1219
                AddReturn(
1224
					$item->{'barcode'},
1220
                    $item->{'barcode'},
1225
					C4::Context->userenv->{'branch'}
1221
                    C4::Context->userenv->{'branch'}
1226
				);
1222
                );
1227
			}
1223
            }
1228
1224
1229
            MoveReserve( $item->{'itemnumber'}, $borrower->{'borrowernumber'}, $cancelreserve );
1225
            MoveReserve( $item->{'itemnumber'}, $borrower->{'borrowernumber'}, $cancelreserve );
1230
			# Starting process for transfer job (checking transfert and validate it if we have one)
1226
            # Starting process for transfer job (checking transfert and validate it if we have one)
1231
            my ($datesent) = GetTransfers($item->{'itemnumber'});
1227
            my ($datesent) = GetTransfers($item->{'itemnumber'});
1232
            if ($datesent) {
1228
            if ($datesent) {
1233
        # 	updating line of branchtranfert to finish it, and changing the to branch value, implement a comment for visibility of this case (maybe for stats ....)
1229
        # 	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 1444-1450 sub GetIssuingRule { Link Here
1444
    my $sth =  $dbh->prepare( "select * from issuingrules where categorycode=? and itemtype=? and branchcode=? and issuelength is not null"  );
1440
    my $sth =  $dbh->prepare( "select * from issuingrules where categorycode=? and itemtype=? and branchcode=? and issuelength is not null"  );
1445
    my $irule;
1441
    my $irule;
1446
1442
1447
	$sth->execute( $borrowertype, $itemtype, $branchcode );
1443
    $sth->execute( $borrowertype, $itemtype, $branchcode );
1448
    $irule = $sth->fetchrow_hashref;
1444
    $irule = $sth->fetchrow_hashref;
1449
    return $irule if defined($irule) ;
1445
    return $irule if defined($irule) ;
1450
1446
Lines 1805-1811 sub AddReturn { Link Here
1805
    if ($doreturn) {
1801
    if ($doreturn) {
1806
        my $datedue = $issue->{date_due};
1802
        my $datedue = $issue->{date_due};
1807
        $borrower or warn "AddReturn without current borrower";
1803
        $borrower or warn "AddReturn without current borrower";
1808
		my $circControlBranch;
1804
        my $circControlBranch;
1809
        if ($dropbox) {
1805
        if ($dropbox) {
1810
            # define circControlBranch only if dropbox mode is set
1806
            # define circControlBranch only if dropbox mode is set
1811
            # don't allow dropbox mode to create an invalid entry in issues (issuedate > today)
1807
            # don't allow dropbox mode to create an invalid entry in issues (issuedate > today)
Lines 2745-2766 sub AddRenewal { Link Here
2745
2741
2746
    # Send a renewal slip according to checkout alert preferencei
2742
    # Send a renewal slip according to checkout alert preferencei
2747
    if ( C4::Context->preference('RenewalSendNotice') eq '1') {
2743
    if ( C4::Context->preference('RenewalSendNotice') eq '1') {
2748
	my $borrower = C4::Members::GetMemberDetails( $borrowernumber, 0 );
2744
    my $borrower = C4::Members::GetMemberDetails( $borrowernumber, 0 );
2749
	my $circulation_alert = 'C4::ItemCirculationAlertPreference';
2745
    my $circulation_alert = 'C4::ItemCirculationAlertPreference';
2750
	my %conditions = (
2746
    my %conditions = (
2751
		branchcode   => $branch,
2747
        branchcode   => $branch,
2752
		categorycode => $borrower->{categorycode},
2748
        categorycode => $borrower->{categorycode},
2753
		item_type    => $item->{itype},
2749
        item_type    => $item->{itype},
2754
		notification => 'CHECKOUT',
2750
        notification => 'CHECKOUT',
2755
	);
2751
    );
2756
	if ($circulation_alert->is_enabled_for(\%conditions)) {
2752
    if ($circulation_alert->is_enabled_for(\%conditions)) {
2757
		SendCirculationAlert({
2753
        SendCirculationAlert({
2758
			type     => 'RENEWAL',
2754
            type     => 'RENEWAL',
2759
			item     => $item,
2755
            item     => $item,
2760
		borrower => $borrower,
2756
        borrower => $borrower,
2761
		branch   => $branch,
2757
        branch   => $branch,
2762
		});
2758
        });
2763
	}
2759
    }
2764
    }
2760
    }
2765
2761
2766
    # Remove any OVERDUES related debarment if the borrower has no overdues
2762
    # Remove any OVERDUES related debarment if the borrower has no overdues
Lines 2775-2781 sub AddRenewal { Link Here
2775
2771
2776
    # Log the renewal
2772
    # Log the renewal
2777
    UpdateStats( $branch, 'renew', $charge, '', $itemnumber, $item->{itype}, $borrowernumber, undef, $item->{'ccode'});
2773
    UpdateStats( $branch, 'renew', $charge, '', $itemnumber, $item->{itype}, $borrowernumber, undef, $item->{'ccode'});
2778
	return $datedue;
2774
    return $datedue;
2779
}
2775
}
2780
2776
2781
sub GetRenewCount {
2777
sub GetRenewCount {
Lines 3138-3144 sub SendCirculationAlert { Link Here
3138
    my %message_name = (
3134
    my %message_name = (
3139
        CHECKIN  => 'Item_Check_in',
3135
        CHECKIN  => 'Item_Check_in',
3140
        CHECKOUT => 'Item_Checkout',
3136
        CHECKOUT => 'Item_Checkout',
3141
	RENEWAL  => 'Item_Checkout',
3137
    RENEWAL  => 'Item_Checkout',
3142
    );
3138
    );
3143
    my $borrower_preferences = C4::Members::Messaging::GetMessagingPreferences({
3139
    my $borrower_preferences = C4::Members::Messaging::GetMessagingPreferences({
3144
        borrowernumber => $borrower->{borrowernumber},
3140
        borrowernumber => $borrower->{borrowernumber},
Lines 3186-3205 This function validate the line of brachtransfer but with the wrong destination Link Here
3186
=cut
3182
=cut
3187
3183
3188
sub updateWrongTransfer {
3184
sub updateWrongTransfer {
3189
	my ( $itemNumber,$waitingAtLibrary,$FromLibrary ) = @_;
3185
    my ( $itemNumber,$waitingAtLibrary,$FromLibrary ) = @_;
3190
	my $dbh = C4::Context->dbh;	
3186
    my $dbh = C4::Context->dbh;
3191
# first step validate the actual line of transfert .
3187
# first step validate the actual line of transfert .
3192
	my $sth =
3188
    my $sth =
3193
        	$dbh->prepare(
3189
            $dbh->prepare(
3194
			"update branchtransfers set datearrived = now(),tobranch=?,comments='wrongtransfer' where itemnumber= ? AND datearrived IS NULL"
3190
            "update branchtransfers set datearrived = now(),tobranch=?,comments='wrongtransfer' where itemnumber= ? AND datearrived IS NULL"
3195
          	);
3191
            );
3196
        	$sth->execute($FromLibrary,$itemNumber);
3192
            $sth->execute($FromLibrary,$itemNumber);
3197
3193
3198
# second step create a new line of branchtransfer to the right location .
3194
# second step create a new line of branchtransfer to the right location .
3199
	ModItemTransfer($itemNumber, $FromLibrary, $waitingAtLibrary);
3195
    ModItemTransfer($itemNumber, $FromLibrary, $waitingAtLibrary);
3200
3196
3201
#third step changing holdingbranch of item
3197
#third step changing holdingbranch of item
3202
	UpdateHoldingbranch($FromLibrary,$itemNumber);
3198
    UpdateHoldingbranch($FromLibrary,$itemNumber);
3203
}
3199
}
3204
3200
3205
=head2 UpdateHoldingbranch
3201
=head2 UpdateHoldingbranch
Lines 3211-3217 Simple methode for updating hodlingbranch in items BDD line Link Here
3211
=cut
3207
=cut
3212
3208
3213
sub UpdateHoldingbranch {
3209
sub UpdateHoldingbranch {
3214
	my ( $branch,$itemnumber ) = @_;
3210
    my ( $branch,$itemnumber ) = @_;
3215
    ModItem({ holdingbranch => $branch }, undef, $itemnumber);
3211
    ModItem({ holdingbranch => $branch }, undef, $itemnumber);
3216
}
3212
}
3217
3213
Lines 3331-3339 sub CheckRepeatableHolidays{ Link Here
3331
my($itemnumber,$week_day,$branchcode)=@_;
3327
my($itemnumber,$week_day,$branchcode)=@_;
3332
my $dbh = C4::Context->dbh;
3328
my $dbh = C4::Context->dbh;
3333
my $query = qq|SELECT count(*)  
3329
my $query = qq|SELECT count(*)  
3334
	FROM repeatable_holidays 
3330
    FROM repeatable_holidays
3335
	WHERE branchcode=?
3331
    WHERE branchcode=?
3336
	AND weekday=?|;
3332
    AND weekday=?|;
3337
my $sth = $dbh->prepare($query);
3333
my $sth = $dbh->prepare($query);
3338
$sth->execute($branchcode,$week_day);
3334
$sth->execute($branchcode,$week_day);
3339
my $result=$sth->fetchrow;
3335
my $result=$sth->fetchrow;
Lines 3359-3370 sub CheckSpecialHolidays{ Link Here
3359
my ($years,$month,$day,$itemnumber,$branchcode) = @_;
3355
my ($years,$month,$day,$itemnumber,$branchcode) = @_;
3360
my $dbh = C4::Context->dbh;
3356
my $dbh = C4::Context->dbh;
3361
my $query=qq|SELECT count(*) 
3357
my $query=qq|SELECT count(*) 
3362
	     FROM `special_holidays`
3358
         FROM `special_holidays`
3363
	     WHERE year=?
3359
         WHERE year=?
3364
	     AND month=?
3360
         AND month=?
3365
	     AND day=?
3361
         AND day=?
3366
             AND branchcode=?
3362
             AND branchcode=?
3367
	    |;
3363
        |;
3368
my $sth = $dbh->prepare($query);
3364
my $sth = $dbh->prepare($query);
3369
$sth->execute($years,$month,$day,$branchcode);
3365
$sth->execute($years,$month,$day,$branchcode);
3370
my $countspecial=$sth->fetchrow ;
3366
my $countspecial=$sth->fetchrow ;
Lines 3388-3398 sub CheckRepeatableSpecialHolidays{ Link Here
3388
my ($month,$day,$itemnumber,$branchcode) = @_;
3384
my ($month,$day,$itemnumber,$branchcode) = @_;
3389
my $dbh = C4::Context->dbh;
3385
my $dbh = C4::Context->dbh;
3390
my $query=qq|SELECT count(*) 
3386
my $query=qq|SELECT count(*) 
3391
	     FROM `repeatable_holidays`
3387
         FROM `repeatable_holidays`
3392
	     WHERE month=?
3388
         WHERE month=?
3393
	     AND day=?
3389
         AND day=?
3394
             AND branchcode=?
3390
             AND branchcode=?
3395
	    |;
3391
        |;
3396
my $sth = $dbh->prepare($query);
3392
my $sth = $dbh->prepare($query);
3397
$sth->execute($month,$day,$branchcode);
3393
$sth->execute($month,$day,$branchcode);
3398
my $countspecial=$sth->fetchrow ;
3394
my $countspecial=$sth->fetchrow ;
Lines 3405-3419 sub CheckValidBarcode{ Link Here
3405
my ($barcode) = @_;
3401
my ($barcode) = @_;
3406
my $dbh = C4::Context->dbh;
3402
my $dbh = C4::Context->dbh;
3407
my $query=qq|SELECT count(*) 
3403
my $query=qq|SELECT count(*) 
3408
	     FROM items 
3404
         FROM items
3409
             WHERE barcode=?
3405
             WHERE barcode=?
3410
	    |;
3406
        |;
3411
my $sth = $dbh->prepare($query);
3407
my $sth = $dbh->prepare($query);
3412
$sth->execute($barcode);
3408
$sth->execute($barcode);
3413
my $exist=$sth->fetchrow ;
3409
my $exist=$sth->fetchrow ;
3414
return $exist;
3410
return $exist;
3415
}
3411
}
3416
3412
3413
3414
=head2 CanItemBeTransferred
3415
3416
A convenience function to easily check item transfer limits.
3417
3418
   ($allowed, $errorMessage) = CanItemBeTransferred( $toBranch, $fromBranch, $item, $biblioitem );
3419
   ($allowed, $errorMessage) = CanItemBeTransferred( $toBranch, undef, $item, undef] );
3420
3421
Checks if UseBranchTransferLimits global preference is in use.
3422
Checks if the given item can be transferred from $fromBranch to $toBranch.
3423
This is dependant on the global setting:
3424
* UseBranchTransferLimits
3425
and "Administration" -> "Library transfer limits"
3426
3427
C<$toBranch>   = the transfer destination library's code
3428
C<$fromBranch>     = OPTIONAL, the transfer departure library's code
3429
                     DEFAULT: using the item's holdingbranch
3430
C<$item>  = item-object from items-table
3431
C<$biblioitem>  = OPTIONAL, biblioitem-object, is needed when using CCODE instead if
3432
              using itemtype to limit branch transfers.
3433
              If biblioitem-object is available, it should be provided for performance reasons.
3434
C<returns> if transfer is not allowed: (0, "$fromBranch->$toBranch->transfer limit code")
3435
           (1) if transfer allowed.
3436
=cut
3437
3438
sub CanItemBeTransferred {
3439
3440
    #When we check for BranchTransferLimit global settings centrally, it makes
3441
    #  using this functionality much easier.
3442
    unless ( C4::Context->preference("UseBranchTransferLimits") == 1 ) {
3443
           return 1;
3444
    }
3445
3446
    #Init parameter variables
3447
    my ( $toBranch, $fromBranch, $item, $biblioitem ) = @_;
3448
3449
    #Check the $fromBranch and set the DEFAULT value
3450
    $fromBranch = $item->{holdingbranch} if ! defined $fromBranch;
3451
3452
    if ( $toBranch eq $fromBranch ) { return 1; } ## Short circuit for speed.
3453
3454
    #This is the CCode or itemtype value used to find the correct transfer rule for this item.
3455
    my $code;
3456
3457
    ## Figure out the $code!
3458
    ## First we need to figure out are we using CCODE or itemtype, this limits do we need $biblioitem or not.
3459
    ## Since $biblioitem can be optional, we cannot count that it is defined.
3460
    if ( C4::Context->preference("BranchTransferLimitsType") eq 'itemtype' ) {
3461
            if (C4::Context->preference("item-level_itypes") && defined $item->{'itype'}) {
3462
                    $code = $item->{'itype'}; #Easiest way to get the $code is from the item.
3463
            }
3464
            elsif (defined $biblioitem->{itemtype}) {
3465
                    $code = $biblioitem->{itemtype}
3466
            }
3467
            #If code cannot be resolved from $item or $biblioitem, we need to escalate to the DB
3468
            else {
3469
                    $biblioitem = C4::Biblio::GetBiblioFromItemNumber( $item->{itemnumber} );
3470
                    $code = $biblioitem->{itemtype}
3471
            }
3472
3473
    } else {
3474
            my $limitType = C4::Context->preference("BranchTransferLimitsType");
3475
            if (defined $item->{ $limitType }) {
3476
                    $code = $item->{ $limitType };
3477
            }
3478
            else {
3479
                    #collection code (ccode) is not present in the Biblio, so no point looking there.
3480
                    #  If the Item doesn't have a itemtype, then give up and let the transfer pass.
3481
            }
3482
    }
3483
    ## Phew we finally got the $code, now it's time to rumble!
3484
3485
    if (! IsBranchTransferAllowed($toBranch, $fromBranch, $code)) {
3486
            return 0, "$fromBranch->$toBranch->$code";
3487
    }
3488
    else {
3489
            return 1;
3490
    }
3491
}
3492
3493
3417
=head2 IsBranchTransferAllowed
3494
=head2 IsBranchTransferAllowed
3418
3495
3419
  $allowed = IsBranchTransferAllowed( $toBranch, $fromBranch, $code );
3496
  $allowed = IsBranchTransferAllowed( $toBranch, $fromBranch, $code );
Lines 3423-3445 Code is either an itemtype or collection doe depending on the pref BranchTransfe Link Here
3423
=cut
3500
=cut
3424
3501
3425
sub IsBranchTransferAllowed {
3502
sub IsBranchTransferAllowed {
3426
	my ( $toBranch, $fromBranch, $code ) = @_;
3503
    my ( $toBranch, $fromBranch, $code ) = @_;
3427
3504
3428
	if ( $toBranch eq $fromBranch ) { return 1; } ## Short circuit for speed.
3505
    if ( $toBranch eq $fromBranch ) { return 1; } ## Short circuit for speed.
3429
        
3506
        
3430
	my $limitType = C4::Context->preference("BranchTransferLimitsType");   
3507
    my $limitType = C4::Context->preference("BranchTransferLimitsType");
3431
	my $dbh = C4::Context->dbh;
3508
    my $dbh = C4::Context->dbh;
3432
            
3509
            
3433
	my $sth = $dbh->prepare("SELECT * FROM branch_transfer_limits WHERE toBranch = ? AND fromBranch = ? AND $limitType = ?");
3510
    my $sth = $dbh->prepare("SELECT * FROM branch_transfer_limits WHERE toBranch = ? AND fromBranch = ? AND $limitType = ?");
3434
	$sth->execute( $toBranch, $fromBranch, $code );
3511
    $sth->execute( $toBranch, $fromBranch, $code );
3435
	my $limit = $sth->fetchrow_hashref();
3512
    my $limit = $sth->fetchrow_hashref();
3436
                        
3513
                        
3437
	## If a row is found, then that combination is not allowed, if no matching row is found, then the combination *is allowed*
3514
    ## If a row is found, then that combination is not allowed, if no matching row is found, then the combination *is allowed*
3438
	if ( $limit->{'limitId'} ) {
3515
    if ( $limit->{'limitId'} ) {
3439
		return 0;
3516
        return 0;
3440
	} else {
3517
    } else {
3441
		return 1;
3518
        return 1;
3442
	}
3519
    }
3443
}                                                        
3520
}                                                        
3444
3521
3445
=head2 CreateBranchTransferLimit
3522
=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