C4/Circulation/Circ2.pm

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