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