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