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