circ2.pm

来自「开源图书馆管理软件」· PM 代码 · 共 1,870 行 · 第 1/5 页

	#	$sth->execute;
	#	($iteminformation->{loanlength},
	#	 $iteminformation->{notforloan}) = fetchrow_array;
	$sth=$dbh->prepare("select * from itemtypes where itemtype='$iteminformation->{'itemtype'}'");
	$sth->execute;
	my $itemtype=$sth->fetchrow_hashref;
	$iteminformation->{'loanlength'}=$itemtype->{'loanlength'};
	$iteminformation->{'notforloan'}=$itemtype->{'notforloan'};
	$sth->finish;
    }
    $dbh->disconnect;
    return($iteminformation);
}

=item findborrower

  $borrowers = &findborrower($env, $key);
  print $borrowers->[0]{surname};

Looks up patrons and returns information about them.

C<$env> is ignored.

C<$key> is either a card number or a string. C<&findborrower> tries to
look it up as a card number first. If that fails, C<&findborrower>
looks up all patrons whose surname begins with C<$key>.

C<$borrowers> is a reference-to-array. Each element is a
reference-to-hash whose keys are the fields of the borrowers table in
the Koha database.

=cut
#'
# If you really want to throw a monkey wrench into the works, change
# your last name to "V10000008" :-)

# FIXME - This is different from &C4::Borrower::findborrower, but I
# think that one's obsolete.
sub findborrower {
# returns an array of borrower hash references, given a cardnumber or a partial
# surname
    my ($env, $key) = @_;
    my $dbh=&C4Connect;
    my @borrowers;
    my $q_key=$dbh->quote($key);
    my $sth=$dbh->prepare("select * from borrowers where cardnumber=$q_key");
    $sth->execute;
    if ($sth->rows) {
	my ($borrower)=$sth->fetchrow_hashref;
	push (@borrowers, $borrower);
    } else {
	$q_key=$dbh->quote("$key%");
	$sth->finish;
	$sth=$dbh->prepare("select * from borrowers where surname like $q_key");
	$sth->execute;
	while (my $borrower = $sth->fetchrow_hashref) {
	    push (@borrowers, $borrower);
	}
    }
    $sth->finish;
    $dbh->disconnect;
    return(\@borrowers);
}


=item transferbook

  ($dotransfer, $messages, $iteminformation) =
	&transferbook($newbranch, $barcode, $ignore_reserves);

Transfers an item to a new branch. If the item is currently on loan,
it is automatically returned before the actual transfer.

C<$newbranch> is the code for the branch to which the item should be
transferred.

C<$barcode> is the barcode of the item to be transferred.

If C<$ignore_reserves> is true, C<&transferbook> ignores reserves.
Otherwise, if an item is reserved, the transfer fails.

Returns three values:

C<$dotransfer> is true iff the transfer was successful.

C<$messages> is a reference-to-hash which may have any of the
following keys:

=over 4

=item C<BadBarcode>

There is no item in the catalog with the given barcode. The value is
C<$barcode>.

=item C<IsPermanent>

The item's home branch is permanent. This doesn't prevent the item
from being transferred, though. The value is the code of the item's
home branch.

=item C<DestinationEqualsHolding>

The item is already at the branch to which it is being transferred.
The transfer is nonetheless considered to have failed. The value
should be ignored.

=item C<WasReturned>

The item was on loan, and C<&transferbook> automatically returned it
before transferring it. The value is the borrower number of the patron
who had the item.

=item C<ResFound>

The item was reserved. The value is a reference-to-hash whose keys are
fields from the reserves table of the Koha database, and
C<biblioitemnumber>. It also has the key C<ResFound>, whose value is
either C<Waiting> or C<Reserved>.

=item C<WasTransferred>

The item was eligible to be transferred. Barring problems
communicating with the database, the transfer should indeed have
succeeded. The value should be ignored.

=back

=cut
#'
# FIXME - This function tries to do too much, and its API is clumsy.
# If it didn't also return books, it could be used to change the home
# branch of a book while the book is on loan.
#
# Is there any point in returning the item information? The caller can
# look that up elsewhere if ve cares.
#
# This leaves the ($dotransfer, $messages) tuple. This seems clumsy.
# If the transfer succeeds, that's all the caller should need to know.
# Thus, this function could simply return 1 or 0 to indicate success
# or failure, and set $C4::Circulation::Circ2::errmsg in case of
# failure. Or this function could return undef if successful, and an
# error message in case of failure (this would feel more like C than
# Perl, though).
sub transferbook {
# transfer book code....
    my ($tbr, $barcode, $ignoreRs) = @_;
    my $messages;
    my %env;
    my $dotransfer = 1;
    my $branches = getbranches();
    my $iteminformation = getiteminformation(\%env, 0, $barcode);
# bad barcode..
    if (not $iteminformation) {
	$messages->{'BadBarcode'} = $barcode;
	$dotransfer = 0;
    }
# get branches of book...
    my $hbr = $iteminformation->{'homebranch'};
    my $fbr = $iteminformation->{'holdingbranch'};
# if is permanent...
    if ($branches->{$hbr}->{'PE'}) {
	$messages->{'IsPermanent'} = $hbr;
    }
# can't transfer book if is already there....
# FIXME - Why not? Shouldn't it trivially succeed?
    if ($fbr eq $tbr) {
	$messages->{'DestinationEqualsHolding'} = 1;
	$dotransfer = 0;
    }
# check if it is still issued to someone, return it...
    my ($currentborrower) = currentborrower($iteminformation->{'itemnumber'});
    if ($currentborrower) {
	returnbook($barcode, $fbr);
	$messages->{'WasReturned'} = $currentborrower;
    }
# find reserves.....
    # FIXME - Don't call &CheckReserves unless $ignoreRs is true.
    # That'll save a database query.
    my ($resfound, $resrec) = CheckReserves($iteminformation->{'itemnumber'});
    if ($resfound and not $ignoreRs) {
	$resrec->{'ResFound'} = $resfound;
	$messages->{'ResFound'} = $resrec;
	$dotransfer = 0;
    }
#actually do the transfer....
    if ($dotransfer) {
	dotransfer($iteminformation->{'itemnumber'}, $fbr, $tbr);
	$messages->{'WasTransfered'} = 1;
    }
    return ($dotransfer, $messages, $iteminformation);
}

# Not exported
# FIXME - This is only used in &transferbook. Why bother making it a
# separate function?
sub dotransfer {
    my ($itm, $fbr, $tbr) = @_;
    my $dbh = &C4Connect;
    $itm = $dbh->quote($itm);
    $fbr = $dbh->quote($fbr);
    $tbr = $dbh->quote($tbr);
    #new entry in branchtransfers....
    $dbh->do(<<EOT);
	INSERT INTO	branchtransfers
			(itemnumber, frombranch, datearrived, tobranch)
	VALUES		($itm, $fbr, now(), $tbr)
EOT

    #update holdingbranch in items .....
    $dbh->do(<<EOT);
	UPDATE	items
	SET	datelastseen  = now(),
		holdingbranch = $tbr
	WHERE	items.itemnumber = $itm
EOT
    return;
}

=item issuebook

  ($iteminformation, $datedue, $rejected, $question, $questionnumber,
   $defaultanswer, $message) =
	&issuebook($env, $patroninformation, $barcode, $responses, $date);

Issue a book to a patron.

C<$env-E<gt>{usercode}> will be used in the usercode field of the
statistics table of the Koha database when this transaction is
recorded.

C<$env-E<gt>{datedue}>, if given, specifies the date on which the book
is due back. This should be a string of the form "YYYY-MM-DD".

C<$env-E<gt>{branchcode}> is the code of the branch where this
transaction is taking place.

C<$patroninformation> is a reference-to-hash giving information about
the person borrowing the book. This is the first value returned by
C<&getpatroninformation>.

C<$barcode> is the bar code of the book being issued.

C<$responses> is a reference-to-hash. It represents the answers to the
questions asked by the C<$question>, C<$questionnumber>, and
C<$defaultanswer> return values (see below). The keys are numbers, and
the values can be "Y" or "N".

C<$date> is an optional date in the form "YYYY-MM-DD". If specified,
then only fines and charges up to that date will be considered when
checking to see whether the patron owes too much money to be lent a
book.

C<&issuebook> returns an array of seven values:

C<$iteminformation> is a reference-to-hash describing the item just
issued. This in a form similar to that returned by
C<&getiteminformation>.

C<$datedue> is a string giving the date when the book is due, in the
form "YYYY-MM-DD".

C<$rejected> is either a string, or -1. If it is defined and is a
string, then the book may not be issued, and C<$rejected> gives the
reason for this. If C<$rejected> is -1, then the book may not be
issued, but no reason is given.

If there is a problem or question (e.g., the book is reserved for
another patron), then C<$question>, C<$questionnumber>, and
C<$defaultanswer> will be set. C<$questionnumber> indicates the
problem. C<$question> is a text string asking how to resolve the
problem, as a yes-or-no question, and C<$defaultanswer> is either "Y"
or "N", giving the default answer. The questions, their numbers, and
default answers are:

=over 4

=item 1: "Issued to <name>. Mark as returned?" (Y)

=item 2: "Waiting for <patron> at <branch>. Allow issue?" (N)

=item 3: "Cancel reserve for <patron>?" (N)

=item 4: "Book is issued to this borrower. Renew?" (Y)

=item 5: "Reserved for <patron> at <branch> since <date>. Allow issue?" (N)

=item 6: "Set reserve for <patron> to waiting and transfer to <branch>?" (Y)

This is asked if the answer to question 5 was "N".

=item 7: "Cancel reserve for <patron>?" (N)

=back

C<$message>, if defined, is an additional information message, e.g., a
rental fee notice.

=cut
#'
# FIXME - The business with $responses is absurd. For one thing, these
# questions should have names, not numbers. For another, it'd be
# better to have the last argument be %extras. Then scripts can call
# this function with
#	&issuebook(...,
#		-renew		=> 1,
#		-mark_returned	=> 0,
#		-cancel_reserve	=> 1,
#		...
#		);
# and the script can use
#	if (defined($extras{"-mark_returned"}) && $extras{"-mark_returned"})
# Heck, the $date argument should go in there as well.
#
# Also, there might be several reasons why a book can't be issued, but
# this API only supports asking one question at a time. Perhaps it'd
# be better to return a ref-to-list of problem IDs. Then the calling
# script can display a list of all of the problems at once.
#
# Is it this function's place to decide the default answer to the
# various questions? Why not document the various problems and allow
# the caller to decide?
sub issuebook {
    my ($env, $patroninformation, $barcode, $responses, $date) = @_;
    my $dbh=&C4Connect;
    my $iteminformation = getiteminformation($env, 0, $barcode);
    my ($datedue);
    my ($rejected,$question,$defaultanswer,$questionnumber, $noissue);
    my $message;
#    warn "in issue book";
    # See if there's any reason this book shouldn't be issued to this
    # patron.
    SWITCH: {	# FIXME - Yes, we know it's a switch. Tell us what it's for.
	if ($patroninformation->{'gonenoaddress'}) {
	    $rejected="Patron is gone, with no known address.";
	    last SWITCH;
	}
	if ($patroninformation->{'lost'}) {
	    $rejected="Patron's card has been reported lost.";
	    last SWITCH;
	}
	if ($patroninformation->{'debarred'}) {
	    $rejected="Patron is Debarred";
	    last SWITCH;
	}
	my $amount = checkaccount($env,$patroninformation->{'borrowernumber'}, $dbh,$date);
	# FIXME - "5" shouldn't be hardcoded. An Italian library might
	# be generous enough to lend a book to a patron even if he
	# does still owe them 5 lire.
	if ($amount > 5 && $patroninformation->{'categorycode'} ne 'L' &&
                           $patroninformation->{'categorycode'} ne 'W' &&
                           $patroninformation->{'categorycode'} ne 'I' &&
                           $patroninformation->{'categorycode'} ne 'B' &&
                           $patroninformation->{'categorycode'} ne 'P') {
                           # FIXME - What do these category codes mean?
	    $rejected = sprintf "Patron owes \$%.02f.", $amount;
	    last SWITCH;
	}
	# FIXME - This sort of error-checking should be placed closer
	# to the test; in this case, this error-checking should be
	# done immediately after the call to &getiteminformation.
	unless ($iteminformation) {
	    $rejected = "$barcode is not a valid barcode.";
	    last SWITCH;
	}
	if ($iteminformation->{'notforloan'} == 1) {
	    $rejected="Item not for loan.";
	    last SWITCH;
	}
	if ($iteminformation->{'wthdrawn'} == 1) {
	    $rejected="Item withdrawn.";
	    last SWITCH;
	}
	if ($iteminformation->{'restricted'} == 1) {