C4/Circulation/Circ2.pm

   1 # -*- tab-width: 8 -*-
   2 # Please use 8-character tabs for this file (indents are every 4 characters)
   3
   4 package C4::Circulation::Circ2;
   5
   6 # $Id$
   7
   8 #package to deal with Returns
   9 #written 3/11/99 by olwen@katipo.co.nz
  10
  11
  12 # Copyright 2000-2002 Katipo Communications
  13 #
  14 # This file is part of Koha.
  15 #
  16 # Koha is free software; you can redistribute it and/or modify it under the
  17 # terms of the GNU General Public License as published by the Free Software
  18 # Foundation; either version 2 of the License, or (at your option) any later
  19 # version.
  20 #
  21 # Koha is distributed in the hope that it will be useful, but WITHOUT ANY
  22 # WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
  23 # A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
  24 #
  25 # You should have received a copy of the GNU General Public License along with
  26 # Koha; if not, write to the Free Software Foundation, Inc., 59 Temple Place,
  27 # Suite 330, Boston, MA  02111-1307 USA
  28
  29 use strict;
  30 # use warnings;
  31 require Exporter;
  32 use DBI;
  33 use C4::Context;
  34 use C4::Stats;
  35 use C4::Reserves2;
  36 use C4::Koha;
  37
  38 use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
  39
  40 # set the version for version checking
  41 $VERSION = 0.01;
  42
  43 =head1 NAME
  44
  45 C4::Circulation::Circ2 - Koha circulation module
  46
  47 =head1 SYNOPSIS
  48
  49   use C4::Circulation::Circ2;
  50
  51 =head1 DESCRIPTION
  52
  53 The functions in this module deal with circulation, issues, and
  54 returns, as well as general information about the library.
  55
  56 =head1 FUNCTIONS
  57
  58 =over 2
  59
  60 =cut
  61
  62 @ISA = qw(Exporter);
  63 @EXPORT = qw(&getpatroninformation
  64         &currentissues &getissues &getiteminformation
  65         &issuebook &returnbook &find_reserves &transferbook &decode
  66         &calc_charges);
  67
  68 # &getbranches &getprinters &getbranch &getprinter => moved to C4::Koha.pm
  69
  70 =item getpatroninformation
  71
  72   ($borrower, $flags) = &getpatroninformation($env, $borrowernumber,
  73                                         $cardnumber);
  74
  75 Looks up a patron and returns information about him or her. If
  76 C<$borrowernumber> is true (nonzero), C<&getpatroninformation> looks
  77 up the borrower by number; otherwise, it looks up the borrower by card
  78 number.
  79
  80 C<$env> is effectively ignored, but should be a reference-to-hash.
  81
  82 C<$borrower> is a reference-to-hash whose keys are the fields of the
  83 borrowers table in the Koha database. In addition,
  84 C<$borrower-E<gt>{flags}> is the same as C<$flags>.
  85
  86 C<$flags> is a reference-to-hash giving more detailed information
  87 about the patron. Its keys act as flags: if they are set, then the key
  88 is a reference-to-hash that gives further details:
  89
  90   if (exists($flags->{LOST}))
  91   {
  92           # Patron's card was reported lost
  93           print $flags->{LOST}{message}, "\n";
  94   }
  95
  96 Each flag has a C<message> key, giving a human-readable explanation of
  97 the flag. If the state of a flag means that the patron should not be
  98 allowed to borrow any more books, then it will have a C<noissues> key
  99 with a true value.
 100
 101 The possible flags are:
 102
 103 =over 4
 104
 105 =item CHARGES
 106
 107 Shows the patron's credit or debt, if any.
 108
 109 =item GNA
 110
 111 (Gone, no address.) Set if the patron has left without giving a
 112 forwarding address.
 113
 114 =item LOST
 115
 116 Set if the patron's card has been reported as lost.
 117
 118 =item DBARRED
 119
 120 Set if the patron has been debarred.
 121
 122 =item NOTES
 123
 124 Any additional notes about the patron.
 125
 126 =item ODUES
 127
 128 Set if the patron has overdue items. This flag has several keys:
 129
 130 C<$flags-E<gt>{ODUES}{itemlist}> is a reference-to-array listing the
 131 overdue items. Its elements are references-to-hash, each describing an
 132 overdue item. The keys are selected fields from the issues, biblio,
 133 biblioitems, and items tables of the Koha database.
 134
 135 C<$flags-E<gt>{ODUES}{itemlist}> is a string giving a text listing of
 136 the overdue items, one per line.
 137
 138 =item WAITING
 139
 140 Set if any items that the patron has reserved are available.
 141
 142 C<$flags-E<gt>{WAITING}{itemlist}> is a reference-to-array listing the
 143 available items. Each element is a reference-to-hash whose keys are
 144 fields from the reserves table of the Koha database.
 145
 146 =back
 147
 148 =cut
 149 #'
 150 sub getpatroninformation {
 151 # returns
 152         my ($env, $borrowernumber,$cardnumber) = @_;
 153         my $dbh = C4::Context->dbh;
 154         my $query;
 155         my $sth;
 156         if ($borrowernumber) {
 157                 $sth = $dbh->prepare("select * from borrowers where borrowernumber=?");
 158                 $sth->execute($borrowernumber);
 159         } elsif ($cardnumber) {
 160                 $sth = $dbh->prepare("select * from borrowers where cardnumber=?");
 161                 $sth->execute($cardnumber);
 162         } else {
 163                 $env->{'apierror'} = "invalid borrower information passed to getpatroninformation subroutine";
 164                 return();
 165         }
 166         $env->{'mess'} = $query;
 167         my $borrower = $sth->fetchrow_hashref;
 168         my $amount = checkaccount($env, $borrowernumber, $dbh);
 169         $borrower->{'amountoutstanding'} = $amount;
 170         my $flags = patronflags($env, $borrower, $dbh);
 171         my $accessflagshash;
 172
 173         $sth=$dbh->prepare("select bit,flag from userflags");
 174         $sth->execute;
 175         while (my ($bit, $flag) = $sth->fetchrow) {
 176                 if ($borrower->{'flags'} & 2**$bit) {
 177                 $accessflagshash->{$flag}=1;
 178                 }
 179         }
 180         $sth->finish;
 181         $borrower->{'flags'}=$flags;
 182         return ($borrower, $flags, $accessflagshash);
 183 }
 184
 185 =item decode
 186
 187   $str = &decode($chunk);
 188
 189 Decodes a segment of a string emitted by a CueCat barcode scanner and
 190 returns it.
 191
 192 =cut
 193 #'
 194 # FIXME - At least, I'm pretty sure this is for decoding CueCat stuff.
 195 sub decode {
 196         my ($encoded) = @_;
 197         my $seq = 'abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789+-';
 198         my @s = map { index($seq,$_); } split(//,$encoded);
 199         my $l = ($#s+1) % 4;
 200         if ($l)
 201         {
 202                 if ($l == 1)
 203                 {
 204                         print "Error!";
 205                         return;
 206                 }
 207                 $l = 4-$l;
 208                 $#s += $l;
 209         }
 210         my $r = '';
 211         while ($#s >= 0)
 212         {
 213                 my $n = (($s[0] << 6 | $s[1]) << 6 | $s[2]) << 6 | $s[3];
 214                 $r .=chr(($n >> 16) ^ 67) .
 215                 chr(($n >> 8 & 255) ^ 67) .
 216                 chr(($n & 255) ^ 67);
 217                 @s = @s[4..$#s];
 218         }
 219         $r = substr($r,0,length($r)-$l);
 220         return $r;
 221 }
 222
 223 =item getiteminformation
 224
 225   $item = &getiteminformation($env, $itemnumber, $barcode);
 226
 227 Looks up information about an item, given either its item number or
 228 its barcode. If C<$itemnumber> is a nonzero value, it is used;
 229 otherwise, C<$barcode> is used.
 230
 231 C<$env> is effectively ignored, but should be a reference-to-hash.
 232
 233 C<$item> is a reference-to-hash whose keys are fields from the biblio,
 234 items, and biblioitems tables of the Koha database. It may also
 235 contain the following keys:
 236
 237 =over 4
 238
 239 =item C<date_due>
 240
 241 The due date on this item, if it has been borrowed and not returned
 242 yet. The date is in YYYY-MM-DD format.
 243
 244 =item C<loanlength>
 245
 246 The length of time for which the item can be borrowed, in days.
 247
 248 =item C<notforloan>
 249
 250 True if the item may not be borrowed.
 251
 252 =back
 253
 254 =cut
 255 #'
 256 sub getiteminformation {
 257 # returns a hash of item information given either the itemnumber or the barcode
 258         my ($env, $itemnumber, $barcode) = @_;
 259         my $dbh = C4::Context->dbh;
 260         my $sth;
 261         if ($itemnumber) {
 262                 $sth=$dbh->prepare("select * from biblio,items,biblioitems where items.itemnumber=? and biblio.biblionumber=items.biblionumber and biblioitems.biblioitemnumber = items.biblioitemnumber");
 263                 $sth->execute($itemnumber);
 264         } elsif ($barcode) {
 265                 $sth=$dbh->prepare("select * from biblio,items,biblioitems where items.barcode=? and biblio.biblionumber=items.biblionumber and biblioitems.biblioitemnumber = items.biblioitemnumber");
 266                 $sth->execute($barcode);
 267         } else {
 268                 $env->{'apierror'}="getiteminformation() subroutine must be called with either an itemnumber or a barcode";
 269                 # Error condition.
 270                 return();
 271         }
 272         my $iteminformation=$sth->fetchrow_hashref;
 273         $sth->finish;
 274         # FIXME - Style: instead of putting the entire rest of the
 275         # function in a block, just say
 276         #       return undef unless $iteminformation;
 277         # That way, the rest of the function needn't be indented as much.
 278         if ($iteminformation) {
 279                 $sth=$dbh->prepare("select date_due from issues where itemnumber=? and isnull(returndate)");
 280                 $sth->execute($iteminformation->{'itemnumber'});
 281                 my ($date_due) = $sth->fetchrow;
 282                 $iteminformation->{'date_due'}=$date_due;
 283                 $sth->finish;
 284                 # FIXME - The Dewey code is a string, not a number. Besides,
 285                 # "000" is a perfectly valid Dewey code.
 286                 #$iteminformation->{'dewey'}=~s/0*$//;
 287                 ($iteminformation->{'dewey'} == 0) && ($iteminformation->{'dewey'}='');
 288                 # FIXME - fetchrow_hashref is documented as being inefficient.
 289                 # Perhaps this should be rewritten as
 290                 #       $sth = $dbh->prepare("select loanlength, notforloan ...");
 291                 #       $sth->execute;
 292                 #       ($iteminformation->{loanlength},
 293                 #        $iteminformation->{notforloan}) = fetchrow_array;
 294                 $sth=$dbh->prepare("select * from itemtypes where itemtype=?");
 295                 $sth->execute($iteminformation->{'itemtype'});
 296                 my $itemtype=$sth->fetchrow_hashref;
 297                 $iteminformation->{'loanlength'}=$itemtype->{'loanlength'};
 298                 $iteminformation->{'notforloan'}=$itemtype->{'notforloan'};
 299                 $sth->finish;
 300         }
 301         return($iteminformation);
 302 }
 303
 304 =item transferbook
 305
 306   ($dotransfer, $messages, $iteminformation) =
 307         &transferbook($newbranch, $barcode, $ignore_reserves);
 308
 309 Transfers an item to a new branch. If the item is currently on loan,
 310 it is automatically returned before the actual transfer.
 311
 312 C<$newbranch> is the code for the branch to which the item should be
 313 transferred.
 314
 315 C<$barcode> is the barcode of the item to be transferred.
 316
 317 If C<$ignore_reserves> is true, C<&transferbook> ignores reserves.
 318 Otherwise, if an item is reserved, the transfer fails.
 319
 320 Returns three values:
 321
 322 C<$dotransfer> is true iff the transfer was successful.
 323
 324 C<$messages> is a reference-to-hash which may have any of the
 325 following keys:
 326
 327 =over 4
 328
 329 =item C<BadBarcode>
 330
 331 There is no item in the catalog with the given barcode. The value is
 332 C<$barcode>.
 333
 334 =item C<IsPermanent>
 335
 336 The item's home branch is permanent. This doesn't prevent the item
 337 from being transferred, though. The value is the code of the item's
 338 home branch.
 339
 340 =item C<DestinationEqualsHolding>
 341
 342 The item is already at the branch to which it is being transferred.
 343 The transfer is nonetheless considered to have failed. The value
 344 should be ignored.
 345
 346 =item C<WasReturned>
 347
 348 The item was on loan, and C<&transferbook> automatically returned it
 349 before transferring it. The value is the borrower number of the patron
 350 who had the item.
 351
 352 =item C<ResFound>
 353
 354 The item was reserved. The value is a reference-to-hash whose keys are
 355 fields from the reserves table of the Koha database, and
 356 C<biblioitemnumber>. It also has the key C<ResFound>, whose value is
 357 either C<Waiting> or C<Reserved>.
 358
 359 =item C<WasTransferred>
 360
 361 The item was eligible to be transferred. Barring problems
 362 communicating with the database, the transfer should indeed have
 363 succeeded. The value should be ignored.
 364
 365 =back
 366
 367 =cut
 368 #'
 369 # FIXME - This function tries to do too much, and its API is clumsy.
 370 # If it didn't also return books, it could be used to change the home
 371 # branch of a book while the book is on loan.
 372 #
 373 # Is there any point in returning the item information? The caller can
 374 # look that up elsewhere if ve cares.
 375 #
 376 # This leaves the ($dotransfer, $messages) tuple. This seems clumsy.
 377 # If the transfer succeeds, that's all the caller should need to know.
 378 # Thus, this function could simply return 1 or 0 to indicate success
 379 # or failure, and set $C4::Circulation::Circ2::errmsg in case of
 380 # failure. Or this function could return undef if successful, and an
 381 # error message in case of failure (this would feel more like C than
 382 # Perl, though).
 383 sub transferbook {
 384 # transfer book code....
 385         my ($tbr, $barcode, $ignoreRs) = @_;
 386         my $messages;
 387         my %env;
 388         my $dotransfer = 1;
 389         my $branches = getbranches();
 390         my $iteminformation = getiteminformation(\%env, 0, $barcode);
 391         # bad barcode..
 392         if (not $iteminformation) {
 393                 $messages->{'BadBarcode'} = $barcode;
 394                 $dotransfer = 0;
 395         }
 396         # get branches of book...
 397         my $hbr = $iteminformation->{'homebranch'};
 398         my $fbr = $iteminformation->{'holdingbranch'};
 399         # if is permanent...
 400         if ($branches->{$hbr}->{'PE'}) {
 401                 $messages->{'IsPermanent'} = $hbr;
 402         }
 403         # can't transfer book if is already there....
 404         # FIXME - Why not? Shouldn't it trivially succeed?
 405         if ($fbr eq $tbr) {
 406                 $messages->{'DestinationEqualsHolding'} = 1;
 407                 $dotransfer = 0;
 408         }
 409         # check if it is still issued to someone, return it...
 410         my ($currentborrower) = currentborrower($iteminformation->{'itemnumber'});
 411         if ($currentborrower) {
 412                 returnbook($barcode, $fbr);
 413                 $messages->{'WasReturned'} = $currentborrower;
 414         }
 415         # find reserves.....
 416         # FIXME - Don't call &CheckReserves unless $ignoreRs is true.
 417         # That'll save a database query.
 418         my ($resfound, $resrec) = CheckReserves($iteminformation->{'itemnumber'});
 419         if ($resfound and not $ignoreRs) {
 420                 $resrec->{'ResFound'} = $resfound;
 421                 $messages->{'ResFound'} = $resrec;
 422                 $dotransfer = 0;
 423         }
 424         #actually do the transfer....
 425         if ($dotransfer) {
 426                 dotransfer($iteminformation->{'itemnumber'}, $fbr, $tbr);
 427                 $messages->{'WasTransfered'} = 1;
 428         }
 429         return ($dotransfer, $messages, $iteminformation);
 430 }
 431
 432 # Not exported
 433 # FIXME - This is only used in &transferbook. Why bother making it a
 434 # separate function?
 435 sub dotransfer {
 436         my ($itm, $fbr, $tbr) = @_;
 437         my $dbh = C4::Context->dbh;
 438         $itm = $dbh->quote($itm);
 439         $fbr = $dbh->quote($fbr);
 440         $tbr = $dbh->quote($tbr);
 441         #new entry in branchtransfers....
 442         $dbh->do("INSERT INTO   branchtransfers (itemnumber, frombranch, datearrived, tobranch)
 443                                         VALUES ($itm, $fbr, now(), $tbr)");
 444         #update holdingbranch in items .....
 445         $dbh->do("UPDATE items SET      datelastseen  = now(), holdingbranch = $tbr WHERE       items.itemnumber = $itm");
 446         return;
 447 }
 448
 449 =item issuebook
 450
 451   ($iteminformation, $datedue, $rejected, $question, $questionnumber,
 452    $defaultanswer, $message) =
 453         &issuebook($env, $patroninformation, $barcode, $responses, $date);
 454
 455 Issue a book to a patron.
 456
 457 C<$env-E<gt>{usercode}> will be used in the usercode field of the
 458 statistics table of the Koha database when this transaction is
 459 recorded.
 460
 461 C<$env-E<gt>{datedue}>, if given, specifies the date on which the book
 462 is due back. This should be a string of the form "YYYY-MM-DD".
 463
 464 C<$env-E<gt>{branchcode}> is the code of the branch where this
 465 transaction is taking place.
 466
 467 C<$patroninformation> is a reference-to-hash giving information about
 468 the person borrowing the book. This is the first value returned by
 469 C<&getpatroninformation>.
 470
 471 C<$barcode> is the bar code of the book being issued.
 472
 473 C<$responses> is a reference-to-hash. It represents the answers to the
 474 questions asked by the C<$question>, C<$questionnumber>, and
 475 C<$defaultanswer> return values (see below). The keys are numbers, and
 476 the values can be "Y" or "N".
 477
 478 C<$date> is an optional date in the form "YYYY-MM-DD". If specified,
 479 then only fines and charges up to that date will be considered when
 480 checking to see whether the patron owes too much money to be lent a
 481 book.
 482
 483 C<&issuebook> returns an array of seven values:
 484
 485 C<$iteminformation> is a reference-to-hash describing the item just
 486 issued. This in a form similar to that returned by
 487 C<&getiteminformation>.
 488
 489 C<$datedue> is a string giving the date when the book is due, in the
 490 form "YYYY-MM-DD".
 491
 492 C<$rejected> is either a string, or -1. If it is defined and is a
 493 string, then the book may not be issued, and C<$rejected> gives the
 494 reason for this. If C<$rejected> is -1, then the book may not be
 495 issued, but no reason is given.
 496
 497 If there is a problem or question (e.g., the book is reserved for
 498 another patron), then C<$question>, C<$questionnumber>, and
 499 C<$defaultanswer> will be set. C<$questionnumber> indicates the
 500 problem. C<$question> is a text string asking how to resolve the
 501 problem, as a yes-or-no question, and C<$defaultanswer> is either "Y"
 502 or "N", giving the default answer. The questions, their numbers, and
 503 default answers are:
 504
 505 =over 4
 506
 507 =item 1: "Issued to <name>. Mark as returned?" (Y)
 508
 509 =item 2: "Waiting for <patron> at <branch>. Allow issue?" (N)
 510
 511 =item 3: "Cancel reserve for <patron>?" (N)
 512
 513 =item 4: "Book is issued to this borrower. Renew?" (Y)
 514
 515 =item 5: "Reserved for <patron> at <branch> since <date>. Allow issue?" (N)
 516
 517 =item 6: "Set reserve for <patron> to waiting and transfer to <branch>?" (Y)
 518
 519 This is asked if the answer to question 5 was "N".
 520
 521 =item 7: "Cancel reserve for <patron>?" (N)
 522
 523 =back
 524
 525 C<$message>, if defined, is an additional information message, e.g., a
 526 rental fee notice.
 527
 528 =cut
 529 #'
 530 # FIXME - The business with $responses is absurd. For one thing, these
 531 # questions should have names, not numbers. For another, it'd be
 532 # better to have the last argument be %extras. Then scripts can call
 533 # this function with
 534 #       &issuebook(...,
 535 #               -renew          => 1,
 536 #               -mark_returned  => 0,
 537 #               -cancel_reserve => 1,
 538 #               ...
 539 #               );
 540 # and the script can use
 541 #       if (defined($extras{"-mark_returned"}) && $extras{"-mark_returned"})
 542 # Heck, the $date argument should go in there as well.
 543 #
 544 # Also, there might be several reasons why a book can't be issued, but
 545 # this API only supports asking one question at a time. Perhaps it'd
 546 # be better to return a ref-to-list of problem IDs. Then the calling
 547 # script can display a list of all of the problems at once.
 548 #
 549 # Is it this function's place to decide the default answer to the
 550 # various questions? Why not document the various problems and allow
 551 # the caller to decide?
 552 sub issuebook {
 553         my ($env, $patroninformation, $barcode, $responses, $date) = @_;
 554         my $dbh = C4::Context->dbh;
 555         my $iteminformation = getiteminformation($env, 0, $barcode);
 556         my ($datedue);
 557         my ($rejected,$question,$defaultanswer,$questionnumber, $noissue);
 558         my $message;
 559
 560         # See if there's any reason this book shouldn't be issued to this
 561         # patron.
 562         SWITCH: {       # FIXME - Yes, we know it's a switch. Tell us what it's for.
 563                 if ($patroninformation->{'gonenoaddress'}) {
 564                         $rejected="Patron is gone, with no known address.";
 565                         last SWITCH;
 566                 }
 567                 if ($patroninformation->{'lost'}) {
 568                         $rejected="Patron's card has been reported lost.";
 569                         last SWITCH;
 570                 }
 571                 if ($patroninformation->{'debarred'}) {
 572                         $rejected="Patron is Debarred";
 573                         last SWITCH;
 574                 }
 575                 my $amount = checkaccount($env,$patroninformation->{'borrowernumber'}, $dbh,$date);
 576                 # FIXME - "5" shouldn't be hardcoded. An Italian library might
 577                 # be generous enough to lend a book to a patron even if he
 578                 # does still owe them 5 lire.
 579                 if ($amount > 5 && $patroninformation->{'categorycode'} ne 'L' &&
 580                                                                 $patroninformation->{'categorycode'} ne 'W' &&
 581                                                                 $patroninformation->{'categorycode'} ne 'I' &&
 582                                                                 $patroninformation->{'categorycode'} ne 'B' &&
 583                                                                 $patroninformation->{'categorycode'} ne 'P') {
 584                 # FIXME - What do these category codes mean?
 585                 $rejected = sprintf "Patron owes \$%.02f.", $amount;
 586                 last SWITCH;
 587                 }
 588                 # FIXME - This sort of error-checking should be placed closer
 589                 # to the test; in this case, this error-checking should be
 590                 # done immediately after the call to &getiteminformation.
 591                 unless ($iteminformation) {
 592                         $rejected = "$barcode is not a valid barcode.";
 593                         last SWITCH;
 594                 }
 595                 if ($iteminformation->{'notforloan'} == 1) {
 596                         $rejected="Item not for loan.";
 597                         last SWITCH;
 598                 }
 599                 if ($iteminformation->{'wthdrawn'} == 1) {
 600                         $rejected="Item withdrawn.";
 601                         last SWITCH;
 602                 }
 603                 if ($iteminformation->{'restricted'} == 1) {
 604                         $rejected="Restricted item.";
 605                         last SWITCH;
 606                 }
 607                 if ($iteminformation->{'itemtype'} eq 'REF') {
 608                         $rejected="Reference item:  Not for loan.";
 609                         last SWITCH;
 610                 }
 611                 my ($currentborrower) = currentborrower($iteminformation->{'itemnumber'});
 612                 if ($currentborrower eq $patroninformation->{'borrowernumber'}) {
 613         # Already issued to current borrower. Ask whether the loan should
 614         # be renewed.
 615                         my ($renewstatus) = renewstatus($env,$dbh,$patroninformation->{'borrowernumber'}, $iteminformation->{'itemnumber'});
 616                         if ($renewstatus == 0) {
 617                                 $rejected="No more renewals allowed for this item.";
 618                                 last SWITCH;
 619                         } else {
 620                                 if ($responses->{4} eq '') {
 621                                         $questionnumber = 4;
 622                                         $question = "Book is issued to this borrower.\nRenew?";
 623                                         $defaultanswer = 'Y';
 624                                         last SWITCH;
 625                                 } elsif ($responses->{4} eq 'Y') {
 626                                         my ($charge,$itemtype) = calc_charges($env, $dbh, $iteminformation->{'itemnumber'}, $patroninformation->{'borrowernumber'});
 627                                         if ($charge > 0) {
 628                                                 createcharge($env, $dbh, $iteminformation->{'itemnumber'}, $patroninformation->{'borrowernumber'}, $charge);
 629                                                 $iteminformation->{'charge'} = $charge;
 630                                         }
 631                                         &UpdateStats($env,$env->{'branchcode'},'renew',$charge,'',$iteminformation->{'itemnumber'},$iteminformation->{'itemtype'},$patroninformation->{'borrowernumber'});
 632                                         renewbook($env,$dbh, $patroninformation->{'borrowernumber'}, $iteminformation->{'itemnumber'});
 633                                         $noissue=1;
 634                                 } else {
 635                                         $rejected=-1;
 636                                         last SWITCH;
 637                                 }
 638                         }
 639                 } elsif ($currentborrower ne '') {
 640                         # This book is currently on loan, but not to the person
 641                         # who wants to borrow it now.
 642                         my ($currborrower, $cbflags) = getpatroninformation($env,$currentborrower,0);
 643                         if ($responses->{1} eq '') {
 644                                 $questionnumber=1;
 645                                 $question = "Issued to $currborrower->{'firstname'} $currborrower->{'surname'} ($currborrower->{'cardnumber'}).\nMark as returned?";
 646                                 $defaultanswer='Y';
 647                                 last SWITCH;
 648                         } elsif ($responses->{1} eq 'Y') {
 649                                 returnbook($iteminformation->{'barcode'}, $env->{'branchcode'});
 650                         } else {
 651                                 $rejected=-1;
 652                                 last SWITCH;
 653                         }
 654                 }
 655
 656                 # See if the item is on reserve.
 657                 my ($restype, $res) = CheckReserves($iteminformation->{'itemnumber'});
 658                 if ($restype) {
 659                         my $resbor = $res->{'borrowernumber'};
 660                         if ($resbor eq $patroninformation->{'borrowernumber'}) {
 661                                 # The item is on reserve to the current patron
 662                                 FillReserve($res);
 663                         } elsif ($restype eq "Waiting") {
 664                                 # The item is on reserve and waiting, but has been
 665                                 # reserved by some other patron.
 666                                 my ($resborrower, $flags)=getpatroninformation($env, $resbor,0);
 667                                 my $branches = getbranches();
 668                                 my $branchname = $branches->{$res->{'branchcode'}}->{'branchname'};
 669                                 if ($responses->{2} eq '') {
 670                                         $questionnumber=2;
 671                                         # FIXME - Assumes HTML
 672                                         $question="<font color=red>Waiting</font> for $resborrower->{'firstname'} $resborrower->{'surname'} ($resborrower->{'cardnumber'}) at $branchname \nAllow issue?";
 673                                         $defaultanswer='N';
 674                                         last SWITCH;
 675                                 } elsif ($responses->{2} eq 'N') {
 676                                         $rejected=-1;
 677                                         last SWITCH;
 678                                 } else {
 679                                         if ($responses->{3} eq '') {
 680                                                 $questionnumber=3;
 681                                                 $question="Cancel reserve for $resborrower->{'firstname'} $resborrower->{'surname'} ($resborrower->{'cardnumber'})?";
 682                                                 $defaultanswer='N';
 683                                                 last SWITCH;
 684                                         } elsif ($responses->{3} eq 'Y') {
 685                                                 CancelReserve(0, $res->{'itemnumber'}, $res->{'borrowernumber'});
 686                                         }
 687
 688 }
 689                         } elsif ($restype eq "Reserved") {
 690                                 # The item is on reserve for someone else.
 691                                 my ($resborrower, $flags)=getpatroninformation($env, $resbor,0);
 692                                 my $branches = getbranches();
 693                                 my $branchname = $branches->{$res->{'branchcode'}}->{'branchname'};
 694                                 if ($responses->{5} eq '' && $responses->{7} eq '') {
 695                                         $questionnumber=5;
 696                                         $question="Reserved for $resborrower->{'firstname'} $resborrower->{'surname'} ($resborrower->{'cardnumber'}) since $res->{'reservedate'} \nAllow issue?";
 697                                         $defaultanswer='N';
 698                                         if ($responses->{6} eq 'Y') {
 699                                            my $tobrcd = ReserveWaiting($res->{'itemnumber'}, $res->{'borrowernumber'});
 700                                            transferbook($tobrcd,$barcode, 1);
 701                                            $message = "Item should now be waiting at $branchname";
 702                                         }
 703                                         last SWITCH;
 704                                 } elsif ($responses->{5} eq 'N') {
 705                                         if ($responses->{6} eq '') {
 706                                                 $questionnumber=6;
 707                                                 $question="Set reserve for $resborrower->{'firstname'} $resborrower->{'surname'} ($resborrower->{'cardnumber'}) to waiting and transfer to $branchname?";
 708                                                 $defaultanswer='N';
 709                                         } elsif ($responses->{6} eq 'Y') {
 710                                                 my $tobrcd = ReserveWaiting($res->{'itemnumber'}, $res->{'borrowernumber'});
 711                                                 transferbook($tobrcd, $barcode, 1);
 712                                                 $message = "Item should now be waiting at $branchname";
 713                                         }
 714                                         $rejected=-1;
 715                                         last SWITCH;
 716                                 } else {
 717                                         if ($responses->{7} eq '') {
 718                                                 $questionnumber=7;
 719                                                 $question="Cancel reserve for $resborrower->{'firstname'} $resborrower->{'surname'} ($resborrower->{'cardnumber'})?";
 720                                                 $defaultanswer='N';
 721                                                 last SWITCH;
 722                                         } elsif ($responses->{7} eq 'Y') {
 723                                                 CancelReserve(0, $res->{'itemnumber'}, $res->{'borrowernumber'});
 724                                         }
 725                                 }
 726                         }
 727                 }
 728         }
 729     my $dateduef;
 730     unless (($question) || ($rejected) || ($noissue)) {
 731                 # There's no reason why the item can't be issued.
 732                 # FIXME - my $loanlength = $iteminformation->{loanlength} || 21;
 733                 my $loanlength=21;
 734                 if ($iteminformation->{'loanlength'}) {
 735                         $loanlength=$iteminformation->{'loanlength'};
 736                 }
 737                 my $ti=time;            # FIXME - Never used
 738                 my $datedue=time+($loanlength)*86400;
 739                 # FIXME - Could just use POSIX::strftime("%Y-%m-%d", localtime);
 740                 # That's what it's for. Or, in this case:
 741                 #       $dateduef = $env->{datedue} ||
 742                 #               strftime("%Y-%m-%d", localtime(time +
 743                 #                                    $loanlength * 86400));
 744                 my @datearr = localtime($datedue);
 745                 $dateduef = (1900+$datearr[5])."-".($datearr[4]+1)."-".$datearr[3];
 746                 if ($env->{'datedue'}) {
 747                         $dateduef=$env->{'datedue'};
 748                 }
 749                 $dateduef=~ s/2001\-4\-25/2001\-4\-26/;
 750                         # FIXME - What's this for? Leftover from debugging?
 751
 752                 # Record in the database the fact that the book was issued.
 753                 my $sth=$dbh->prepare("insert into issues (borrowernumber, itemnumber, date_due, branchcode) values (?,?,?,?)");
 754                 $sth->execute($patroninformation->{'borrowernumber'}, $iteminformation->{'itemnumber'}, $dateduef, $env->{'branchcode'});
 755                 $sth->finish;
 756                 $iteminformation->{'issues'}++;
 757                 $sth=$dbh->prepare("update items set issues=?,datelastseen=now() where itemnumber=?");
 758                 $sth->execute($iteminformation->{'issues'},$iteminformation->{'itemnumber'});
 759                 $sth->finish;
 760                 # If it costs to borrow this book, charge it to the patron's account.
 761                 my ($charge,$itemtype)=calc_charges($env, $dbh, $iteminformation->{'itemnumber'}, $patroninformation->{'borrowernumber'});
 762                 if ($charge > 0) {
 763                         createcharge($env, $dbh, $iteminformation->{'itemnumber'}, $patroninformation->{'borrowernumber'}, $charge);
 764                         $iteminformation->{'charge'}=$charge;
 765                 }
 766                 # Record the fact that this book was issued.
 767                 &UpdateStats($env,$env->{'branchcode'},'issue',$charge,'',$iteminformation->{'itemnumber'},$iteminformation->{'itemtype'},$patroninformation->{'borrowernumber'});
 768         }
 769
 770         if ($iteminformation->{'charge'}) {
 771                 $message=sprintf "Rental charge of \$%.02f applies.", $iteminformation->{'charge'};
 772         }
 773         return ($iteminformation, $dateduef, $rejected, $question, $questionnumber, $defaultanswer, $message);
 774 }
 775
 776
 777
 778 =item returnbook
 779
 780   ($doreturn, $messages, $iteminformation, $borrower) =
 781           &returnbook($barcode, $branch);
 782
 783 Returns a book.
 784
 785 C<$barcode> is the bar code of the book being returned. C<$branch> is
 786 the code of the branch where the book is being returned.
 787
 788 C<&returnbook> returns a list of four items:
 789
 790 C<$doreturn> is true iff the return succeeded.
 791
 792 C<$messages> is a reference-to-hash giving the reason for failure:
 793
 794 =over 4
 795
 796 =item C<BadBarcode>
 797
 798 No item with this barcode exists. The value is C<$barcode>.
 799
 800 =item C<NotIssued>
 801
 802 The book is not currently on loan. The value is C<$barcode>.
 803
 804 =item C<IsPermanent>
 805
 806 The book's home branch is a permanent collection. If you have borrowed
 807 this book, you are not allowed to return it. The value is the code for
 808 the book's home branch.
 809
 810 =item C<wthdrawn>
 811
 812 This book has been withdrawn/cancelled. The value should be ignored.
 813
 814 =item C<ResFound>
 815
 816 The item was reserved. The value is a reference-to-hash whose keys are
 817 fields from the reserves table of the Koha database, and
 818 C<biblioitemnumber>. It also has the key C<ResFound>, whose value is
 819 either C<Waiting>, C<Reserved>, or 0.
 820
 821 =back
 822
 823 C<$borrower> is a reference-to-hash, giving information about the
 824 patron who last borrowed the book.
 825
 826 =cut
 827 #'
 828 # FIXME - This API is bogus. There's no need to return $borrower and
 829 # $iteminformation; the caller can ask about those separately, if it
 830 # cares (it'd be inefficient to make two database calls instead of
 831 # one, but &getpatroninformation and &getiteminformation can be
 832 # memoized if this is an issue).
 833 #
 834 # The ($doreturn, $messages) tuple is redundant: if the return
 835 # succeeded, that's all the caller needs to know. So &returnbook can
 836 # return 1 and 0 on success and failure, and set
 837 # $C4::Circulation::Circ2::errmsg to indicate the error. Or it can
 838 # return undef for success, and an error message on error (though this
 839 # is more C-ish than Perl-ish).
 840 sub returnbook {
 841         my ($barcode, $branch) = @_;
 842         my %env;
 843         my $messages;
 844         my $doreturn = 1;
 845         die '$branch not defined' unless defined $branch; # just in case (bug 170)
 846         # get information on item
 847         my ($iteminformation) = getiteminformation(\%env, 0, $barcode);
 848         if (not $iteminformation) {
 849                 $messages->{'BadBarcode'} = $barcode;
 850                 $doreturn = 0;
 851         }
 852         # find the borrower
 853         my ($currentborrower) = currentborrower($iteminformation->{'itemnumber'});
 854         if ((not $currentborrower) && $doreturn) {
 855                 $messages->{'NotIssued'} = $barcode;
 856                 $doreturn = 0;
 857         }
 858         # check if the book is in a permanent collection....
 859         my $hbr = $iteminformation->{'homebranch'};
 860         my $branches = getbranches();
 861         if ($branches->{$hbr}->{'PE'}) {
 862                 $messages->{'IsPermanent'} = $hbr;
 863         }
 864         # check that the book has been cancelled
 865         if ($iteminformation->{'wthdrawn'}) {
 866                 $messages->{'wthdrawn'} = 1;
 867                 $doreturn = 0;
 868         }
 869         # update issues, thereby returning book (should push this out into another subroutine
 870         my ($borrower) = getpatroninformation(\%env, $currentborrower, 0);
 871         if ($doreturn) {
 872                 doreturn($borrower->{'borrowernumber'}, $iteminformation->{'itemnumber'});
 873                 $messages->{'WasReturned'} = 1; # FIXME is the "= 1" right?
 874         }
 875         ($borrower) = getpatroninformation(\%env, $currentborrower, 0);
 876         # transfer book to the current branch
 877         my ($transfered, $mess, $item) = transferbook($branch, $barcode, 1);
 878         if ($transfered) {
 879                 $messages->{'WasTransfered'} = 1; # FIXME is the "= 1" right?
 880         }
 881         # fix up the accounts.....
 882         if ($iteminformation->{'itemlost'}) {
 883                 # Mark the item as not being lost.
 884                 updateitemlost($iteminformation->{'itemnumber'});
 885                 fixaccountforlostandreturned($iteminformation, $borrower);
 886                 $messages->{'WasLost'} = 1; # FIXME is the "= 1" right?
 887         }
 888         # fix up the overdues in accounts...
 889         fixoverduesonreturn($borrower->{'borrowernumber'}, $iteminformation->{'itemnumber'});
 890         # find reserves.....
 891         my ($resfound, $resrec) = CheckReserves($iteminformation->{'itemnumber'});
 892         if ($resfound) {
 893         #       my $tobrcd = ReserveWaiting($resrec->{'itemnumber'}, $resrec->{'borrowernumber'});
 894                 $resrec->{'ResFound'} = $resfound;
 895                 $messages->{'ResFound'} = $resrec;
 896         }
 897         # update stats?
 898         # Record the fact that this book was returned.
 899         UpdateStats(\%env, $branch ,'return','0','',$iteminformation->{'itemnumber'},$iteminformation->{'itemtype'},$borrower->{'borrowernumber'});
 900         return ($doreturn, $messages, $iteminformation, $borrower);
 901 }
 902
 903 # doreturn
 904 # Takes a borrowernumber and an itemnuber.
 905 # Updates the 'issues' table to mark the item as returned (assuming
 906 # that it's currently on loan to the given borrower. Otherwise, the
 907 # item remains on loan.
 908 # Updates items.datelastseen for the item.
 909 # Not exported
 910 # FIXME - This is only used in &returnbook. Why make it into a
 911 # separate function? (is this a recognizable step in the return process? - acli)
 912 sub doreturn {
 913         my ($brn, $itm) = @_;
 914         my $dbh = C4::Context->dbh;
 915         my $sth = $dbh->prepare("update issues set returndate = now() where (borrowernumber = ?)
 916                 and (itemnumber = ?) and (returndate is null)");
 917         $sth->execute($brn,$itm);
 918         $sth->finish;
 919         $sth=$dbh->prepare("update items set datelastseen=now() where itemnumber=?");
 920         $sth->execute($itm);
 921         $sth->finish;
 922         return;
 923 }
 924
 925 # updateitemlost
 926 # Marks an item as not being lost.
 927 # Not exported
 928 sub updateitemlost{
 929         my ($itemno)=@_;
 930         my $dbh = C4::Context->dbh;
 931
 932         my $sth = $dbh->prepare("UPDATE items SET itemlost = 0 WHERE    itemnumber =?");
 933         $sth->execute($itemno);
 934         $sth->finish();
 935 }
 936
 937 # Not exported
 938 sub fixaccountforlostandreturned {
 939         my ($iteminfo, $borrower) = @_;
 940         my %env;
 941         my $dbh = C4::Context->dbh;
 942         my $itm = $iteminfo->{'itemnumber'};
 943         # check for charge made for lost book
 944         my $sth = $dbh->prepare("select * from accountlines where (itemnumber = ?)
 945                                 and (accounttype='L' or accounttype='Rep') order by date desc");
 946         $sth->execute($itm);
 947         if (my $data = $sth->fetchrow_hashref) {
 948         # writeoff this amount
 949                 my $offset;
 950                 my $amount = $data->{'amount'};
 951                 my $acctno = $data->{'accountno'};
 952                 my $amountleft;
 953                 if ($data->{'amountoutstanding'} == $amount) {
 954                 $offset = $data->{'amount'};
 955                 $amountleft = 0;
 956                 } else {
 957                 $offset = $amount - $data->{'amountoutstanding'};
 958                 $amountleft = $data->{'amountoutstanding'} - $amount;
 959                 }
 960                 my $usth = $dbh->prepare("update accountlines set accounttype = 'LR',amountoutstanding='0'
 961                         where (borrowernumber = ?)
 962                         and (itemnumber = ?) and (accountno = ?) ");
 963                 $usth->execute($data->{'borrowernumber'},$itm,$acctno);
 964                 $usth->finish;
 965         #check if any credit is left if so writeoff other accounts
 966                 my $nextaccntno = getnextacctno(\%env,$data->{'borrowernumber'},$dbh);
 967                 if ($amountleft < 0){
 968                 $amountleft*=-1;
 969                 }
 970                 if ($amountleft > 0){
 971                 my $msth = $dbh->prepare("select * from accountlines where (borrowernumber = ?)
 972                                                         and (amountoutstanding >0) order by date");
 973                 $msth->execute($data->{'borrowernumber'});
 974         # offset transactions
 975                 my $newamtos;
 976                 my $accdata;
 977                 while (($accdata=$msth->fetchrow_hashref) and ($amountleft>0)){
 978                         if ($accdata->{'amountoutstanding'} < $amountleft) {
 979                         $newamtos = 0;
 980                         $amountleft -= $accdata->{'amountoutstanding'};
 981                         }  else {
 982                         $newamtos = $accdata->{'amountoutstanding'} - $amountleft;
 983                         $amountleft = 0;
 984                         }
 985                         my $thisacct = $accdata->{'accountno'};
 986                         my $usth = $dbh->prepare("update accountlines set amountoutstanding= ?
 987                                         where (borrowernumber = ?)
 988                                         and (accountno=?)");
 989                         $usth->execute($newamtos,$data->{'borrowernumber'},'$thisacct');
 990                         $usth->finish;
 991                         $usth = $dbh->prepare("insert into accountoffsets
 992                                 (borrowernumber, accountno, offsetaccount,  offsetamount)
 993                                 values
 994                                 (?,?,?,?)");
 995                         $usth->execute($data->{'borrowernumber'},$accdata->{'accountno'},$nextaccntno,$newamtos);
 996                         $usth->finish;
 997                 }
 998                 $msth->finish;
 999                 }
1000                 if ($amountleft > 0){
1001                         $amountleft*=-1;
1002                 }
1003                 my $desc="Book Returned ".$iteminfo->{'barcode'};
1004                 $usth = $dbh->prepare("insert into accountlines
1005                         (borrowernumber,accountno,date,amount,description,accounttype,amountoutstanding)
1006                         values (?,?,now(),?,?,'CR',?)");
1007                 $usth->execute($data->{'borrowernumber'},$nextaccntno,0-$amount,$desc,$amountleft);
1008                 $usth->finish;
1009                 $usth = $dbh->prepare("insert into accountoffsets
1010                         (borrowernumber, accountno, offsetaccount,  offsetamount)
1011                         values (?,?,?,?)");
1012                 $usth->execute($borrower->{'borrowernumber'},$data->{'accountno'},$nextaccntno,$offset);
1013                 $usth->finish;
1014                 $usth = $dbh->prepare("update items set paidfor='' where itemnumber=?");
1015                 $usth->execute($itm);
1016                 $usth->finish;
1017         }
1018         $sth->finish;
1019         return;
1020 }
1021
1022 # Not exported
1023 sub fixoverduesonreturn {
1024         my ($brn, $itm) = @_;
1025         my $dbh = C4::Context->dbh;
1026         # check for overdue fine
1027         my $sth = $dbh->prepare("select * from accountlines where (borrowernumber = ?) and (itemnumber = ?) and (accounttype='FU' or accounttype='O')");
1028         $sth->execute($brn,$itm);
1029         # alter fine to show that the book has been returned
1030         if (my $data = $sth->fetchrow_hashref) {
1031                 my $usth=$dbh->prepare("update accountlines set accounttype='F' where (borrowernumber = ?) and (itemnumber = ?) and (acccountno = ?)");
1032                 $usth->execute($brn,$itm,$data->{'accountno'});
1033                 $usth->finish();
1034         }
1035         $sth->finish();
1036         return;
1037 }
1038
1039 # Not exported
1040 #
1041 # NOTE!: If you change this function, be sure to update the POD for
1042 # &getpatroninformation.
1043 #
1044 # $flags = &patronflags($env, $patron, $dbh);
1045 #
1046 # $flags->{CHARGES}
1047 #               {message}       Message showing patron's credit or debt
1048 #               {noissues}      Set if patron owes >$5.00
1049 #         {GNA}                 Set if patron gone w/o address
1050 #               {message}       "Borrower has no valid address"
1051 #               {noissues}      Set.
1052 #         {LOST}                Set if patron's card reported lost
1053 #               {message}       Message to this effect
1054 #               {noissues}      Set.
1055 #         {DBARRED}             Set is patron is debarred
1056 #               {message}       Message to this effect
1057 #               {noissues}      Set.
1058 #         {NOTES}               Set if patron has notes
1059 #               {message}       Notes about patron
1060 #         {ODUES}               Set if patron has overdue books
1061 #               {message}       "Yes"
1062 #               {itemlist}      ref-to-array: list of overdue books
1063 #               {itemlisttext}  Text list of overdue items
1064 #         {WAITING}             Set if there are items available that the
1065 #                               patron reserved
1066 #               {message}       Message to this effect
1067 #               {itemlist}      ref-to-array: list of available items
1068 sub patronflags {
1069 # Original subroutine for Circ2.pm
1070         my %flags;
1071         my ($env, $patroninformation, $dbh) = @_;
1072         my $amount = checkaccount($env, $patroninformation->{'borrowernumber'}, $dbh);
1073         if ($amount > 0) {
1074                 my %flaginfo;
1075                 my $noissuescharge = C4::Context->preference("noissuescharge");
1076                 $flaginfo{'message'}= sprintf "Patron owes \$%.02f", $amount;
1077                 if ($amount > $noissuescharge) {
1078                 $flaginfo{'noissues'} = 1;
1079                 }
1080                 $flags{'CHARGES'} = \%flaginfo;
1081         } elsif ($amount < 0){
1082         my %flaginfo;
1083         $flaginfo{'message'} = sprintf "Patron has credit of \$%.02f", -$amount;
1084                 $flags{'CHARGES'} = \%flaginfo;
1085         }
1086         if ($patroninformation->{'gonenoaddress'} == 1) {
1087                 my %flaginfo;
1088                 $flaginfo{'message'} = 'Borrower has no valid address.';
1089                 $flaginfo{'noissues'} = 1;
1090                 $flags{'GNA'} = \%flaginfo;
1091         }
1092         if ($patroninformation->{'lost'} == 1) {
1093                 my %flaginfo;
1094                 $flaginfo{'message'} = 'Borrower\'s card reported lost.';
1095                 $flaginfo{'noissues'} = 1;
1096                 $flags{'LOST'} = \%flaginfo;
1097         }
1098         if ($patroninformation->{'debarred'} == 1) {
1099                 my %flaginfo;
1100                 $flaginfo{'message'} = 'Borrower is Debarred.';
1101                 $flaginfo{'noissues'} = 1;
1102                 $flags{'DBARRED'} = \%flaginfo;
1103         }
1104         if ($patroninformation->{'borrowernotes'}) {
1105                 my %flaginfo;
1106                 $flaginfo{'message'} = "$patroninformation->{'borrowernotes'}";
1107                 $flags{'NOTES'} = \%flaginfo;
1108         }
1109         my ($odues, $itemsoverdue)
1110                         = checkoverdues($env, $patroninformation->{'borrowernumber'}, $dbh);
1111         if ($odues > 0) {
1112                 my %flaginfo;
1113                 $flaginfo{'message'} = "Yes";
1114                 $flaginfo{'itemlist'} = $itemsoverdue;
1115                 foreach (sort {$a->{'date_due'} cmp $b->{'date_due'}} @$itemsoverdue) {
1116                 $flaginfo{'itemlisttext'}.="$_->{'date_due'} $_->{'barcode'} $_->{'title'} \n";
1117                 }
1118                 $flags{'ODUES'} = \%flaginfo;
1119         }
1120         my ($nowaiting, $itemswaiting)
1121                         = CheckWaiting($patroninformation->{'borrowernumber'});
1122         if ($nowaiting > 0) {
1123                 my %flaginfo;
1124                 $flaginfo{'message'} = "Reserved items available";
1125                 $flaginfo{'itemlist'} = $itemswaiting;
1126                 $flags{'WAITING'} = \%flaginfo;
1127         }
1128         return(\%flags);
1129 }
1130
1131
1132 # Not exported
1133 sub checkoverdues {
1134 # From Main.pm, modified to return a list of overdueitems, in addition to a count
1135   #checks whether a borrower has overdue items
1136         my ($env, $bornum, $dbh)=@_;
1137         my @datearr = localtime;
1138         my $today = ($datearr[5] + 1900)."-".($datearr[4]+1)."-".$datearr[3];
1139         my @overdueitems;
1140         my $count = 0;
1141         my $sth = $dbh->prepare("SELECT * FROM issues,biblio,biblioitems,items
1142                         WHERE items.biblioitemnumber = biblioitems.biblioitemnumber
1143                                 AND items.biblionumber     = biblio.biblionumber
1144                                 AND issues.itemnumber      = items.itemnumber
1145                                 AND issues.borrowernumber  = ?
1146                                 AND issues.returndate is NULL
1147                                 AND issues.date_due < ?");
1148         $sth->execute($bornum,$today);
1149         while (my $data = $sth->fetchrow_hashref) {
1150         push (@overdueitems, $data);
1151         $count++;
1152         }
1153         $sth->finish;
1154         return ($count, \@overdueitems);
1155 }
1156
1157 # Not exported
1158 sub currentborrower {
1159 # Original subroutine for Circ2.pm
1160         my ($itemnumber) = @_;
1161         my $dbh = C4::Context->dbh;
1162         my $q_itemnumber = $dbh->quote($itemnumber);
1163         my $sth=$dbh->prepare("select borrowers.borrowernumber from
1164         issues,borrowers where issues.itemnumber=$q_itemnumber and
1165         issues.borrowernumber=borrowers.borrowernumber and issues.returndate is
1166         NULL");
1167         $sth->execute;
1168         my ($borrower) = $sth->fetchrow;
1169         return($borrower);
1170 }
1171
1172 # FIXME - Not exported, but used in 'updateitem.pl' anyway.
1173 sub checkreserve {
1174 # Stolen from Main.pm
1175 # Check for reserves for biblio
1176         my ($env,$dbh,$itemnum)=@_;
1177         my $resbor = "";
1178         my $sth = $dbh->prepare("select * from reserves,items
1179         where (items.itemnumber = ?)
1180         and (reserves.cancellationdate is NULL)
1181         and (items.biblionumber = reserves.biblionumber)
1182         and ((reserves.found = 'W')
1183         or (reserves.found is null))
1184         order by priority");
1185         $sth->execute($itemnum);
1186         my $resrec;
1187         my $data=$sth->fetchrow_hashref;
1188         while ($data && $resbor eq '') {
1189         $resrec=$data;
1190         my $const = $data->{'constrainttype'};
1191         if ($const eq "a") {
1192         $resbor = $data->{'borrowernumber'};
1193         } else {
1194         my $found = 0;
1195         my $csth = $dbh->prepare("select * from reserveconstraints,items
1196                 where (borrowernumber=?)
1197                 and reservedate=?
1198                 and reserveconstraints.biblionumber=?
1199                 and (items.itemnumber=? and
1200                 items.biblioitemnumber = reserveconstraints.biblioitemnumber)");
1201         $csth->execute($data->{'borrowernumber'},$data->{'biblionumber'},$data->{'reservedate'},$itemnum);
1202         if (my $cdata=$csth->fetchrow_hashref) {$found = 1;}
1203         if ($const eq 'o') {
1204                 if ($found eq 1) {$resbor = $data->{'borrowernumber'};}
1205         } else {
1206                 if ($found eq 0) {$resbor = $data->{'borrowernumber'};}
1207         }
1208         $csth->finish();
1209         }
1210         $data=$sth->fetchrow_hashref;
1211         }
1212         $sth->finish;
1213         return ($resbor,$resrec);
1214 }
1215
1216 =item currentissues
1217
1218   $issues = &currentissues($env, $borrower);
1219
1220 Returns a list of books currently on loan to a patron.
1221
1222 If C<$env-E<gt>{todaysissues}> is set and true, C<&currentissues> only
1223 returns information about books issued today. If
1224 C<$env-E<gt>{nottodaysissues}> is set and true, C<&currentissues> only
1225 returns information about books issued before today. If both are
1226 specified, C<$env-E<gt>{todaysissues}> is ignored. If neither is
1227 specified, C<&currentissues> returns all of the patron's issues.
1228
1229 C<$borrower->{borrowernumber}> is the borrower number of the patron
1230 whose issues we want to list.
1231
1232 C<&currentissues> returns a PHP-style array: C<$issues> is a
1233 reference-to-hash whose keys are integers in the range 1...I<n>, where
1234 I<n> is the number of items on issue (either today or before today).
1235 C<$issues-E<gt>{I<n>}> is a reference-to-hash whose keys are all of
1236 the fields of the biblio, biblioitems, items, and issues fields of the
1237 Koha database for that particular item.
1238
1239 =cut
1240 #'
1241 sub currentissues {
1242 # New subroutine for Circ2.pm
1243         my ($env, $borrower) = @_;
1244         my $dbh = C4::Context->dbh;
1245         my %currentissues;
1246         my $counter=1;
1247         my $borrowernumber = $borrower->{'borrowernumber'};
1248         my $crit='';
1249
1250         # Figure out whether to get the books issued today, or earlier.
1251         # FIXME - $env->{todaysissues} and $env->{nottodaysissues} can
1252         # both be specified, but are mutually-exclusive. This is bogus.
1253         # Make this a flag. Or better yet, return everything in (reverse)
1254         # chronological order and let the caller figure out which books
1255         # were issued today.
1256         if ($env->{'todaysissues'}) {
1257                 # FIXME - Could use
1258                 #       $today = POSIX::strftime("%Y%m%d", localtime);
1259                 # FIXME - Since $today will be used in either case, move it
1260                 # out of the two if-blocks.
1261                 my @datearr = localtime(time());
1262                 my $today = (1900+$datearr[5]).sprintf "%02d", ($datearr[4]+1).sprintf "%02d", $datearr[3];
1263                 # FIXME - MySQL knows about dates. Just use
1264                 #       and issues.timestamp = curdate();
1265                 $crit=" and issues.timestamp like '$today%' ";
1266         }
1267         if ($env->{'nottodaysissues'}) {
1268                 # FIXME - Could use
1269                 #       $today = POSIX::strftime("%Y%m%d", localtime);
1270                 # FIXME - Since $today will be used in either case, move it
1271                 # out of the two if-blocks.
1272                 my @datearr = localtime(time());
1273                 my $today = (1900+$datearr[5]).sprintf "%02d", ($datearr[4]+1).sprintf "%02d", $datearr[3];
1274                 # FIXME - MySQL knows about dates. Just use
1275                 #       and issues.timestamp < curdate();
1276                 $crit=" and !(issues.timestamp like '$today%') ";
1277         }
1278
1279         # FIXME - Does the caller really need every single field from all
1280         # four tables?
1281         my $sth=$dbh->prepare("select * from issues,items,biblioitems,biblio where
1282         borrowernumber=? and issues.itemnumber=items.itemnumber and
1283         items.biblionumber=biblio.biblionumber and
1284         items.biblioitemnumber=biblioitems.biblioitemnumber and returndate is null
1285         $crit order by issues.date_due");
1286         $sth->execute($borrowernumber);
1287         while (my $data = $sth->fetchrow_hashref) {
1288                 # FIXME - The Dewey code is a string, not a number.
1289                 $data->{'dewey'}=~s/0*$//;
1290                 ($data->{'dewey'} == 0) && ($data->{'dewey'}='');
1291                 # FIXME - Could use
1292                 #       $todaysdate = POSIX::strftime("%Y%m%d", localtime)
1293                 # or better yet, just reuse $today which was calculated above.
1294                 # This function isn't going to run until midnight, is it?
1295                 # Alternately, use
1296                 #       $todaysdate = POSIX::strftime("%Y-%m-%d", localtime)
1297                 #       if ($data->{'date_due'} lt $todaysdate)
1298                 #               ...
1299                 # Either way, the date should be be formatted outside of the
1300                 # loop.
1301                 my @datearr = localtime(time());
1302                 my $todaysdate = (1900+$datearr[5]).sprintf ("%0.2d", ($datearr[4]+1)).sprintf ("%0.2d", $datearr[3]);
1303                 my $datedue=$data->{'date_due'};
1304                 $datedue=~s/-//g;
1305                 if ($datedue < $todaysdate) {
1306                         $data->{'overdue'}=1;
1307                 }
1308                 my $itemnumber=$data->{'itemnumber'};
1309                 # FIXME - Consecutive integers as hash keys? You have GOT to
1310                 # be kidding me! Use an array, fercrissakes!
1311                 $currentissues{$counter}=$data;
1312                 $counter++;
1313         }
1314         $sth->finish;
1315         return(\%currentissues);
1316 }
1317
1318 =item getissues
1319
1320   $issues = &getissues($borrowernumber);
1321
1322 Returns the set of books currently on loan to a patron.
1323
1324 C<$borrowernumber> is the patron's borrower number.
1325
1326 C<&getissues> returns a PHP-style array: C<$issues> is a
1327 reference-to-hash whose keys are integers in the range 0..I<n>-1,
1328 where I<n> is the number of books the patron currently has on loan.
1329
1330 The values of C<$issues> are references-to-hash whose keys are
1331 selected fields from the issues, items, biblio, and biblioitems tables
1332 of the Koha database.
1333
1334 =cut
1335 #'
1336 sub getissues {
1337 # New subroutine for Circ2.pm
1338         my ($borrower) = @_;
1339         my $dbh = C4::Context->dbh;
1340         my $borrowernumber = $borrower->{'borrowernumber'};
1341         my %currentissues;
1342         my $select = "SELECT issues.timestamp      AS timestamp,
1343                                 issues.date_due       AS date_due,
1344                                 items.biblionumber    AS biblionumber,
1345                                 items.itemnumber    AS itemnumber,
1346                                 items.barcode         AS barcode,
1347                                 biblio.title          AS title,
1348                                 biblio.author         AS author,
1349                                 biblioitems.dewey     AS dewey,
1350                                 itemtypes.description AS itemtype,
1351                                 biblioitems.subclass  AS subclass,
1352                                 biblioitems.classification AS classification
1353                         FROM issues,items,biblioitems,biblio, itemtypes
1354                         WHERE issues.borrowernumber  = ?
1355                         AND issues.itemnumber      = items.itemnumber
1356                         AND items.biblionumber     = biblio.biblionumber
1357                         AND items.biblioitemnumber = biblioitems.biblioitemnumber
1358                         AND itemtypes.itemtype     = biblioitems.itemtype
1359                         AND issues.returndate      IS NULL
1360                         ORDER BY issues.date_due";
1361         #    print $select;
1362         my $sth=$dbh->prepare($select);
1363         $sth->execute($borrowernumber);
1364         my $counter = 0;
1365         while (my $data = $sth->fetchrow_hashref) {
1366                 $data->{'dewey'} =~ s/0*$//;
1367                 ($data->{'dewey'} == 0) && ($data->{'dewey'} = '');
1368                         # FIXME - The Dewey code is a string, not a number.
1369                 # FIXME - Use POSIX::strftime to get a text version of today's
1370                 # date. That's what it's for.
1371                 # FIXME - Move the date calculation outside of the loop.
1372                 my @datearr = localtime(time());
1373                 my $todaysdate = (1900+$datearr[5]).sprintf ("%0.2d", ($datearr[4]+1)).sprintf ("%0.2d", $datearr[3]);
1374
1375                 # FIXME - Instead of converting the due date to YYYYMMDD, just
1376                 # use
1377                 #       $todaysdate = POSIX::strftime("%Y-%m-%d", localtime);
1378                 #       ...
1379                 #       if ($date->{date_due} lt $todaysdate)
1380                 my $datedue = $data->{'date_due'};
1381                 $datedue =~ s/-//g;
1382                 if ($datedue < $todaysdate) {
1383                         $data->{'overdue'} = 1;
1384                 }
1385                 $currentissues{$counter} = $data;
1386                 $counter++;
1387                         # FIXME - This is ludicrous. If you want to return an
1388                         # array of values, just use an array. That's what
1389                         # they're there for.
1390         }
1391         $sth->finish;
1392         return(\%currentissues);
1393 }
1394
1395 # Not exported
1396 sub checkwaiting {
1397 #Stolen from Main.pm
1398 # check for reserves waiting
1399         my ($env,$dbh,$bornum)=@_;
1400         my @itemswaiting;
1401         my $sth = $dbh->prepare("select * from reserves where (borrowernumber = ?) and (reserves.found='W') and cancellationdate is NULL");
1402         $sth->execute($bornum);
1403         my $cnt=0;
1404         if (my $data=$sth->fetchrow_hashref) {
1405                 $itemswaiting[$cnt] =$data;
1406                 $cnt ++
1407         }
1408         $sth->finish;
1409         return ($cnt,\@itemswaiting);
1410 }
1411
1412 # Not exported
1413 # FIXME - This is nearly-identical to &C4::Accounts::checkaccount
1414 sub checkaccount  {
1415 # Stolen from Accounts.pm
1416   #take borrower number
1417   #check accounts and list amounts owing
1418         my ($env,$bornumber,$dbh,$date)=@_;
1419         my $select="SELECT SUM(amountoutstanding) AS total
1420                         FROM accountlines
1421                 WHERE borrowernumber = ?
1422                         AND amountoutstanding<>0";
1423         my @bind = ($bornumber);
1424         if ($date ne ''){
1425         $select.=" AND date < ?";
1426         push(@bind,$date);
1427         }
1428         #  print $select;
1429         my $sth=$dbh->prepare($select);
1430         $sth->execute(@bind);
1431         my $data=$sth->fetchrow_hashref;
1432         my $total = $data->{'total'};
1433         $sth->finish;
1434         # output(1,2,"borrower owes $total");
1435         #if ($total > 0){
1436         #  # output(1,2,"borrower owes $total");
1437         #  if ($total > 5){
1438         #    reconcileaccount($env,$dbh,$bornumber,$total);
1439         #  }
1440         #}
1441         #  pause();
1442         return($total);
1443 }
1444
1445 # FIXME - This is identical to &C4::Circulation::Renewals::renewstatus.
1446 # Pick one and stick with it.
1447 sub renewstatus {
1448 # Stolen from Renewals.pm
1449   # check renewal status
1450   my ($env,$dbh,$bornum,$itemno)=@_;
1451   my $renews = 1;
1452   my $renewokay = 0;
1453   my $sth1 = $dbh->prepare("select * from issues
1454     where (borrowernumber = ?)
1455     and (itemnumber = ?)
1456     and returndate is null");
1457   $sth1->execute($bornum,$itemno);
1458   if (my $data1 = $sth1->fetchrow_hashref) {
1459     my $sth2 = $dbh->prepare("select renewalsallowed from items,biblioitems,itemtypes
1460        where (items.itemnumber = ?)
1461        and (items.biblioitemnumber = biblioitems.biblioitemnumber)
1462        and (biblioitems.itemtype = itemtypes.itemtype)");
1463     $sth2->execute($itemno);
1464     if (my $data2=$sth2->fetchrow_hashref) {
1465       $renews = $data2->{'renewalsallowed'};
1466     }
1467     if ($renews > $data1->{'renewals'}) {
1468       $renewokay = 1;
1469     }
1470     $sth2->finish;
1471   }
1472   $sth1->finish;
1473   return($renewokay);
1474 }
1475
1476 sub renewbook {
1477 # Stolen from Renewals.pm
1478   # mark book as renewed
1479   my ($env,$dbh,$bornum,$itemno,$datedue)=@_;
1480   $datedue=$env->{'datedue'};
1481   if ($datedue eq "" ) {
1482     my $loanlength=21;
1483     my $sth=$dbh->prepare("Select * from biblioitems,items,itemtypes
1484        where (items.itemnumber = ?)
1485        and (biblioitems.biblioitemnumber = items.biblioitemnumber)
1486        and (biblioitems.itemtype = itemtypes.itemtype)");
1487     $sth->execute($itemno);
1488     if (my $data=$sth->fetchrow_hashref) {
1489       $loanlength = $data->{'loanlength'}
1490     }
1491     $sth->finish;
1492     my $ti = time;
1493     my $datedu = time + ($loanlength * 86400);
1494     my @datearr = localtime($datedu);
1495     $datedue = (1900+$datearr[5])."-".($datearr[4]+1)."-".$datearr[3];
1496   }
1497   my @date = split("-",$datedue);
1498   my $odatedue = ($date[2]+0)."-".($date[1]+0)."-".$date[0];
1499   my $sth=$dbh->prepare("select * from issues where borrowernumber=? and
1500     itemnumber=? and returndate is null");
1501   $sth->execute($bornum,$itemno);
1502   my $issuedata=$sth->fetchrow_hashref;
1503   $sth->finish;
1504   my $renews = $issuedata->{'renewals'} +1;
1505   $sth=$dbh->prepare("update issues
1506     set date_due = ?, renewals = ?
1507     where borrowernumber=? and
1508     itemnumber=? and returndate is null");
1509
1510   $sth->execute($datedue,$renews,$bornum,$itemno);
1511   $sth->finish;
1512   return($odatedue);
1513 }
1514
1515 # FIXME - This is almost, but not quite, identical to
1516 # &C4::Circulation::Issues::calc_charges and
1517 # &C4::Circulation::Renewals2::calc_charges.
1518 # Pick one and stick with it.
1519 sub calc_charges {
1520 # Stolen from Issues.pm
1521 # calculate charges due
1522     my ($env, $dbh, $itemno, $bornum)=@_;
1523 #    if (!$dbh){
1524 #      $dbh=C4Connect();
1525 #    }
1526     my $charge=0;
1527 #    open (FILE,">>/tmp/charges");
1528     my $item_type;
1529     my $sth1= $dbh->prepare("select itemtypes.itemtype,rentalcharge from items,biblioitems,itemtypes
1530     where (items.itemnumber =?)
1531     and (biblioitems.biblioitemnumber = items.biblioitemnumber)
1532     and (biblioitems.itemtype = itemtypes.itemtype)");
1533 #    print FILE "$q1\n";
1534     $sth1->execute($itemno);
1535     if (my $data1=$sth1->fetchrow_hashref) {
1536         $item_type = $data1->{'itemtype'};
1537         $charge = $data1->{'rentalcharge'};
1538 #       print FILE "charge is $charge\n";
1539         my $sth2=$dbh->prepare("select rentaldiscount from borrowers,categoryitem
1540         where (borrowers.borrowernumber = ?)
1541         and (borrowers.categorycode = categoryitem.categorycode)
1542         and (categoryitem.itemtype = ?)");
1543 #       warn $q2;
1544         $sth2->execute($bornum,$item_type);
1545         if (my $data2=$sth2->fetchrow_hashref) {
1546             my $discount = $data2->{'rentaldiscount'};
1547 #           print FILE "discount is $discount";
1548             if ($discount eq 'NULL') {
1549               $discount=0;
1550             }
1551             $charge = ($charge *(100 - $discount)) / 100;
1552         }
1553         $sth2->finish;
1554     }
1555     $sth1->finish;
1556 #    close FILE;
1557     return ($charge, $item_type);
1558 }
1559
1560 # FIXME - A virtually identical function appears in
1561 # C4::Circulation::Issues. Pick one and stick with it.
1562 sub createcharge {
1563 #Stolen from Issues.pm
1564     my ($env,$dbh,$itemno,$bornum,$charge) = @_;
1565     my $nextaccntno = getnextacctno($env,$bornum,$dbh);
1566     my $sth = $dbh->prepare(<<EOT);
1567         INSERT INTO     accountlines
1568                         (borrowernumber, itemnumber, accountno,
1569                          date, amount, description, accounttype,
1570                          amountoutstanding)
1571         VALUES          (?, ?, ?,
1572                          now(), ?, 'Rental', 'Rent',
1573                          ?)
1574 EOT
1575     $sth->execute($bornum, $itemno, $nextaccntno, $charge, $charge);
1576     $sth->finish;
1577 }
1578
1579
1580 sub getnextacctno {
1581 # Stolen from Accounts.pm
1582     my ($env,$bornumber,$dbh)=@_;
1583     my $nextaccntno = 1;
1584     my $sth = $dbh->prepare("select * from accountlines where (borrowernumber = ?) order by accountno desc");
1585     $sth->execute($bornumber);
1586     if (my $accdata=$sth->fetchrow_hashref){
1587         $nextaccntno = $accdata->{'accountno'} + 1;
1588     }
1589     $sth->finish;
1590     return($nextaccntno);
1591 }
1592
1593 =item find_reserves
1594
1595   ($status, $record) = &find_reserves($itemnumber);
1596
1597 Looks up an item in the reserves.
1598
1599 C<$itemnumber> is the itemnumber to look up.
1600
1601 C<$status> is true iff the search was successful.
1602
1603 C<$record> is a reference-to-hash describing the reserve. Its keys are
1604 the fields from the reserves table of the Koha database.
1605
1606 =cut
1607 #'
1608 # FIXME - This API is bogus: just return the record, or undef if none
1609 # was found.
1610 # FIXME - There's also a &C4::Circulation::Returns::find_reserves, but
1611 # that one looks rather different.
1612 sub find_reserves {
1613 # Stolen from Returns.pm
1614     my ($itemno) = @_;
1615     my %env;
1616     my $dbh = C4::Context->dbh;
1617     my ($itemdata) = getiteminformation(\%env, $itemno,0);
1618     my $bibno = $dbh->quote($itemdata->{'biblionumber'});
1619     my $bibitm = $dbh->quote($itemdata->{'biblioitemnumber'});
1620     my $sth = $dbh->prepare("select * from reserves where ((found = 'W') or (found is null)) and biblionumber = ? and cancellationdate is NULL order by priority, reservedate");
1621     $sth->execute($bibno);
1622     my $resfound = 0;
1623     my $resrec;
1624     my $lastrec;
1625 # print $query;
1626
1627     # FIXME - I'm not really sure what's going on here, but since we
1628     # only want one result, wouldn't it be possible (and far more
1629     # efficient) to do something clever in SQL that only returns one
1630     # set of values?
1631     while (($resrec = $sth->fetchrow_hashref) && (not $resfound)) {
1632                 # FIXME - Unlike Pascal, Perl allows you to exit loops
1633                 # early. Take out the "&& (not $resfound)" and just
1634                 # use "last" at the appropriate point in the loop.
1635                 # (Oh, and just in passing: if you'd used "!" instead
1636                 # of "not", you wouldn't have needed the parentheses.)
1637         $lastrec = $resrec;
1638         my $brn = $dbh->quote($resrec->{'borrowernumber'});
1639         my $rdate = $dbh->quote($resrec->{'reservedate'});
1640         my $bibno = $dbh->quote($resrec->{'biblionumber'});
1641         if ($resrec->{'found'} eq "W") {
1642             if ($resrec->{'itemnumber'} eq $itemno) {
1643                 $resfound = 1;
1644             }
1645         } else {
1646             # FIXME - Use 'elsif' to avoid unnecessary indentation.
1647             if ($resrec->{'constrainttype'} eq "a") {
1648                 $resfound = 1;
1649             } else {
1650                         my $consth = $dbh->prepare("select * from reserveconstraints where borrowernumber = ? and reservedate = ? and biblionumber = ? and biblioitemnumber = ?");
1651                         $consth->execute($brn,$rdate,$bibno,$bibitm);
1652                         if (my $conrec = $consth->fetchrow_hashref) {
1653                                 if ($resrec->{'constrainttype'} eq "o") {
1654                                 $resfound = 1;
1655                                 }
1656                         }
1657                 $consth->finish;
1658                 }
1659         }
1660         if ($resfound) {
1661             my $updsth = $dbh->prepare("update reserves set found = 'W', itemnumber = ? where borrowernumber = ? and reservedate = ? and biblionumber = ?");
1662             $updsth->execute($itemno,$brn,$rdate,$bibno);
1663             $updsth->finish;
1664             # FIXME - "last;" here to break out of the loop early.
1665         }
1666     }
1667     $sth->finish;
1668     return ($resfound,$lastrec);
1669 }
1670
1671 1;
1672 __END__
1673
1674 =back
1675
1676 =head1 AUTHOR
1677
1678 Koha Developement team <info@koha.org>
1679
1680 =cut