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                     # FIXME - -=
1111                     $amountleft = $amountleft - $accdata->{'amountoutstanding'};
1112                 }  else {
1113                     $newamtos = $accdata->{'amountoutstanding'} - $amountleft;
1114                     $amountleft = 0;
1115                 }
1116                 my $thisacct = $accdata->{'accountno'};
1117                 my $updquery = "update accountlines set amountoutstanding= '$newamtos'
1118                                  where (borrowernumber = '$data->{'borrowernumber'}')
1119                                    and (accountno='$thisacct')";
1120                 my $usth = $dbh->prepare($updquery);
1121                 $usth->execute;
1122                 $usth->finish;
1123                 $updquery = "insert into accountoffsets
1124                           (borrowernumber, accountno, offsetaccount,  offsetamount)
1125                           values
1126                           ('$data->{'borrowernumber'}','$accdata->{'accountno'}','$nextaccntno','$newamtos')";
1127                 $usth = $dbh->prepare($updquery);
1128                 $usth->execute;
1129                 $usth->finish;
1130             }
1131             $msth->finish;
1132         }
1133         if ($amountleft > 0){
1134             $amountleft*=-1;
1135         }
1136         my $desc="Book Returned ".$iteminfo->{'barcode'};
1137         $uquery = "insert into accountlines
1138                   (borrowernumber,accountno,date,amount,description,accounttype,amountoutstanding)
1139                   values ('$data->{'borrowernumber'}','$nextaccntno',now(),0-$amount,'$desc',
1140                   'CR',$amountleft)";
1141         $usth = $dbh->prepare($uquery);
1142         $usth->execute;
1143         $usth->finish;
1144         $uquery = "insert into accountoffsets
1145                   (borrowernumber, accountno, offsetaccount,  offsetamount)
1146                   values ($borrower->{'borrowernumber'},$data->{'accountno'},$nextaccntno,$offset)";
1147         $usth = $dbh->prepare($uquery);
1148         $usth->execute;
1149         $usth->finish;
1150         $uquery = "update items set paidfor='' where itemnumber=$itm";
1151         $usth = $dbh->prepare($uquery);
1152         $usth->execute;
1153         $usth->finish;
1154     }
1155     $sth->finish;
1156     return;
1157 }
1158
1159 # Not exported
1160 sub fixoverduesonreturn {
1161     my ($brn, $itm) = @_;
1162     my $dbh = C4::Context->dbh;
1163     $itm = $dbh->quote($itm);
1164     $brn = $dbh->quote($brn);
1165 # check for overdue fine
1166     my $query = "select * from accountlines where (borrowernumber=$brn)
1167                            and (itemnumber = $itm) and (accounttype='FU' or accounttype='O')";
1168     my $sth = $dbh->prepare($query);
1169     $sth->execute;
1170 # alter fine to show that the book has been returned
1171     if (my $data = $sth->fetchrow_hashref) {
1172         my $query = "update accountlines set accounttype='F' where (borrowernumber = $brn)
1173                            and (itemnumber = $itm) and (acccountno='$data->{'accountno'}')";
1174         my $usth=$dbh->prepare($query);
1175         $usth->execute();
1176         $usth->finish();
1177     }
1178     $sth->finish;
1179     return;
1180 }
1181
1182 # Not exported
1183 #
1184 # NOTE!: If you change this function, be sure to update the POD for
1185 # &getpatroninformation.
1186 #
1187 # $flags = &patronflags($env, $patron, $dbh);
1188 #
1189 # $flags->{CHARGES}
1190 #               {message}       Message showing patron's credit or debt
1191 #               {noissues}      Set if patron owes >$5.00
1192 #         {GNA}                 Set if patron gone w/o address
1193 #               {message}       "Borrower has no valid address"
1194 #               {noissues}      Set.
1195 #         {LOST}                Set if patron's card reported lost
1196 #               {message}       Message to this effect
1197 #               {noissues}      Set.
1198 #         {DBARRED}             Set is patron is debarred
1199 #               {message}       Message to this effect
1200 #               {noissues}      Set.
1201 #         {NOTES}               Set if patron has notes
1202 #               {message}       Notes about patron
1203 #         {ODUES}               Set if patron has overdue books
1204 #               {message}       "Yes"
1205 #               {itemlist}      ref-to-array: list of overdue books
1206 #               {itemlisttext}  Text list of overdue items
1207 #         {WAITING}             Set if there are items available that the
1208 #                               patron reserved
1209 #               {message}       Message to this effect
1210 #               {itemlist}      ref-to-array: list of available items
1211 sub patronflags {
1212 # Original subroutine for Circ2.pm
1213     my %flags;
1214     my ($env, $patroninformation, $dbh) = @_;
1215     my $amount = checkaccount($env, $patroninformation->{'borrowernumber'}, $dbh);
1216     if ($amount > 0) {
1217         my %flaginfo;
1218         $flaginfo{'message'}= sprintf "Patron owes \$%.02f", $amount;
1219         if ($amount > 5) {
1220             $flaginfo{'noissues'} = 1;
1221         }
1222         $flags{'CHARGES'} = \%flaginfo;
1223     } elsif ($amount < 0){
1224        my %flaginfo;
1225        $flaginfo{'message'} = sprintf "Patron has credit of \$%.02f", -$amount;
1226         $flags{'CHARGES'} = \%flaginfo;
1227     }
1228     if ($patroninformation->{'gonenoaddress'} == 1) {
1229         my %flaginfo;
1230         $flaginfo{'message'} = 'Borrower has no valid address.';
1231         $flaginfo{'noissues'} = 1;
1232         $flags{'GNA'} = \%flaginfo;
1233     }
1234     if ($patroninformation->{'lost'} == 1) {
1235         my %flaginfo;
1236         $flaginfo{'message'} = 'Borrower\'s card reported lost.';
1237         $flaginfo{'noissues'} = 1;
1238         $flags{'LOST'} = \%flaginfo;
1239     }
1240     if ($patroninformation->{'debarred'} == 1) {
1241         my %flaginfo;
1242         $flaginfo{'message'} = 'Borrower is Debarred.';
1243         $flaginfo{'noissues'} = 1;
1244         $flags{'DBARRED'} = \%flaginfo;
1245     }
1246     if ($patroninformation->{'borrowernotes'}) {
1247         my %flaginfo;
1248         $flaginfo{'message'} = "$patroninformation->{'borrowernotes'}";
1249         $flags{'NOTES'} = \%flaginfo;
1250     }
1251     my ($odues, $itemsoverdue)
1252                   = checkoverdues($env, $patroninformation->{'borrowernumber'}, $dbh);
1253     if ($odues > 0) {
1254         my %flaginfo;
1255         $flaginfo{'message'} = "Yes";
1256         $flaginfo{'itemlist'} = $itemsoverdue;
1257         foreach (sort {$a->{'date_due'} cmp $b->{'date_due'}} @$itemsoverdue) {
1258             $flaginfo{'itemlisttext'}.="$_->{'date_due'} $_->{'barcode'} $_->{'title'} \n";
1259         }
1260         $flags{'ODUES'} = \%flaginfo;
1261     }
1262     my ($nowaiting, $itemswaiting)
1263                   = CheckWaiting($patroninformation->{'borrowernumber'});
1264     if ($nowaiting > 0) {
1265         my %flaginfo;
1266         $flaginfo{'message'} = "Reserved items available";
1267         $flaginfo{'itemlist'} = $itemswaiting;
1268         $flags{'WAITING'} = \%flaginfo;
1269     }
1270     return(\%flags);
1271 }
1272
1273
1274 # Not exported
1275 sub checkoverdues {
1276 # From Main.pm, modified to return a list of overdueitems, in addition to a count
1277   #checks whether a borrower has overdue items
1278   my ($env, $bornum, $dbh)=@_;
1279   my @datearr = localtime;
1280   my $today = ($datearr[5] + 1900)."-".($datearr[4]+1)."-".$datearr[3];
1281   my @overdueitems;
1282   my $count = 0;
1283   my $query = "SELECT * FROM issues,biblio,biblioitems,items
1284                        WHERE items.biblioitemnumber = biblioitems.biblioitemnumber
1285                          AND items.biblionumber     = biblio.biblionumber
1286                          AND issues.itemnumber      = items.itemnumber
1287                          AND issues.borrowernumber  = $bornum
1288                          AND issues.returndate is NULL
1289                          AND issues.date_due < '$today'";
1290   my $sth = $dbh->prepare($query);
1291   $sth->execute;
1292   while (my $data = $sth->fetchrow_hashref) {
1293       push (@overdueitems, $data);
1294       $count++;
1295   }
1296   $sth->finish;
1297   return ($count, \@overdueitems);
1298 }
1299
1300 # Not exported
1301 sub currentborrower {
1302 # Original subroutine for Circ2.pm
1303     my ($itemnumber) = @_;
1304     my $dbh = C4::Context->dbh;
1305     my $q_itemnumber = $dbh->quote($itemnumber);
1306     my $sth=$dbh->prepare("select borrowers.borrowernumber from
1307     issues,borrowers where issues.itemnumber=$q_itemnumber and
1308     issues.borrowernumber=borrowers.borrowernumber and issues.returndate is
1309     NULL");
1310     $sth->execute;
1311     my ($borrower) = $sth->fetchrow;
1312     return($borrower);
1313 }
1314
1315 # FIXME - Not exported, but used in 'updateitem.pl' anyway.
1316 sub checkreserve {
1317 # Stolen from Main.pm
1318   # Check for reserves for biblio
1319   my ($env,$dbh,$itemnum)=@_;
1320   my $resbor = "";
1321   my $query = "select * from reserves,items
1322     where (items.itemnumber = '$itemnum')
1323     and (reserves.cancellationdate is NULL)
1324     and (items.biblionumber = reserves.biblionumber)
1325     and ((reserves.found = 'W')
1326     or (reserves.found is null))
1327     order by priority";
1328   my $sth = $dbh->prepare($query);
1329   $sth->execute();
1330   my $resrec;
1331   my $data=$sth->fetchrow_hashref;
1332   while ($data && $resbor eq '') {
1333     $resrec=$data;
1334     my $const = $data->{'constrainttype'};
1335     if ($const eq "a") {
1336       $resbor = $data->{'borrowernumber'};
1337     } else {
1338       my $found = 0;
1339       my $cquery = "select * from reserveconstraints,items
1340          where (borrowernumber='$data->{'borrowernumber'}')
1341          and reservedate='$data->{'reservedate'}'
1342          and reserveconstraints.biblionumber='$data->{'biblionumber'}'
1343          and (items.itemnumber=$itemnum and
1344          items.biblioitemnumber = reserveconstraints.biblioitemnumber)";
1345       my $csth = $dbh->prepare($cquery);
1346       $csth->execute;
1347       if (my $cdata=$csth->fetchrow_hashref) {$found = 1;}
1348       if ($const eq 'o') {
1349         if ($found eq 1) {$resbor = $data->{'borrowernumber'};}
1350       } else {
1351         if ($found eq 0) {$resbor = $data->{'borrowernumber'};}
1352       }
1353       $csth->finish();
1354     }
1355     $data=$sth->fetchrow_hashref;
1356   }
1357   $sth->finish;
1358   return ($resbor,$resrec);
1359 }
1360
1361 =item currentissues
1362
1363   $issues = &currentissues($env, $borrower);
1364
1365 Returns a list of books currently on loan to a patron.
1366
1367 If C<$env-E<gt>{todaysissues}> is set and true, C<&currentissues> only
1368 returns information about books issued today. If
1369 C<$env-E<gt>{nottodaysissues}> is set and true, C<&currentissues> only
1370 returns information about books issued before today. If both are
1371 specified, C<$env-E<gt>{todaysissues}> is ignored. If neither is
1372 specified, C<&currentissues> returns all of the patron's issues.
1373
1374 C<$borrower->{borrowernumber}> is the borrower number of the patron
1375 whose issues we want to list.
1376
1377 C<&currentissues> returns a PHP-style array: C<$issues> is a
1378 reference-to-hash whose keys are integers in the range 1...I<n>, where
1379 I<n> is the number of items on issue (either today or before today).
1380 C<$issues-E<gt>{I<n>}> is a reference-to-hash whose keys are all of
1381 the fields of the biblio, biblioitems, items, and issues fields of the
1382 Koha database for that particular item.
1383
1384 =cut
1385 #'
1386 sub currentissues {
1387 # New subroutine for Circ2.pm
1388     my ($env, $borrower) = @_;
1389     my $dbh = C4::Context->dbh;
1390     my %currentissues;
1391     my $counter=1;
1392     my $borrowernumber = $borrower->{'borrowernumber'};
1393     my $crit='';
1394
1395     # Figure out whether to get the books issued today, or earlier.
1396     # FIXME - $env->{todaysissues} and $env->{nottodaysissues} can
1397     # both be specified, but are mutually-exclusive. This is bogus.
1398     # Make this a flag. Or better yet, return everything in (reverse)
1399     # chronological order and let the caller figure out which books
1400     # were issued today.
1401     if ($env->{'todaysissues'}) {
1402         # FIXME - Could use
1403         #       $today = POSIX::strftime("%Y%m%d", localtime);
1404         # FIXME - Since $today will be used in either case, move it
1405         # out of the two if-blocks.
1406         my @datearr = localtime(time());
1407         my $today = (1900+$datearr[5]).sprintf "%02d", ($datearr[4]+1).sprintf "%02d", $datearr[3];
1408         # FIXME - MySQL knows about dates. Just use
1409         #       and issues.timestamp = curdate();
1410         $crit=" and issues.timestamp like '$today%' ";
1411     }
1412     if ($env->{'nottodaysissues'}) {
1413         # FIXME - Could use
1414         #       $today = POSIX::strftime("%Y%m%d", localtime);
1415         # FIXME - Since $today will be used in either case, move it
1416         # out of the two if-blocks.
1417         my @datearr = localtime(time());
1418         my $today = (1900+$datearr[5]).sprintf "%02d", ($datearr[4]+1).sprintf "%02d", $datearr[3];
1419         # FIXME - MySQL knows about dates. Just use
1420         #       and issues.timestamp < curdate();
1421         $crit=" and !(issues.timestamp like '$today%') ";
1422     }
1423
1424     # FIXME - Does the caller really need every single field from all
1425     # four tables?
1426     my $select="select * from issues,items,biblioitems,biblio where
1427        borrowernumber='$borrowernumber' and issues.itemnumber=items.itemnumber and
1428        items.biblionumber=biblio.biblionumber and
1429        items.biblioitemnumber=biblioitems.biblioitemnumber and returndate is null
1430        $crit order by issues.date_due";
1431 #    warn $select;
1432     my $sth=$dbh->prepare($select);
1433     $sth->execute;
1434     while (my $data = $sth->fetchrow_hashref) {
1435         # FIXME - The Dewey code is a string, not a number.
1436         $data->{'dewey'}=~s/0*$//;
1437         ($data->{'dewey'} == 0) && ($data->{'dewey'}='');
1438         # FIXME - Could use
1439         #       $todaysdate = POSIX::strftime("%Y%m%d", localtime)
1440         # or better yet, just reuse $today which was calculated above.
1441         # This function isn't going to run until midnight, is it?
1442         # Alternately, use
1443         #       $todaysdate = POSIX::strftime("%Y-%m-%d", localtime)
1444         #       if ($data->{'date_due'} lt $todaysdate)
1445         #               ...
1446         # Either way, the date should be be formatted outside of the
1447         # loop.
1448         my @datearr = localtime(time());
1449         my $todaysdate = (1900+$datearr[5]).sprintf ("%0.2d", ($datearr[4]
1450         +1)).sprintf ("%0.2d", $datearr[3]);
1451         my $datedue=$data->{'date_due'};
1452         $datedue=~s/-//g;
1453         if ($datedue < $todaysdate) {
1454             $data->{'overdue'}=1;
1455         }
1456         my $itemnumber=$data->{'itemnumber'};
1457         # FIXME - Consecutive integers as hash keys? You have GOT to
1458         # be kidding me! Use an array, fercrissakes!
1459         $currentissues{$counter}=$data;
1460         $counter++;
1461     }
1462     $sth->finish;
1463     return(\%currentissues);
1464 }
1465
1466 =item getissues
1467
1468   $issues = &getissues($borrowernumber);
1469
1470 Returns the set of books currently on loan to a patron.
1471
1472 C<$borrowernumber> is the patron's borrower number.
1473
1474 C<&getissues> returns a PHP-style array: C<$issues> is a
1475 reference-to-hash whose keys are integers in the range 0..I<n>-1,
1476 where I<n> is the number of books the patron currently has on loan.
1477
1478 The values of C<$issues> are references-to-hash whose keys are
1479 selected fields from the issues, items, biblio, and biblioitems tables
1480 of the Koha database.
1481
1482 =cut
1483 #'
1484 sub getissues {
1485 # New subroutine for Circ2.pm
1486     my ($borrower) = @_;
1487     my $dbh = C4::Context->dbh;
1488     my $borrowernumber = $borrower->{'borrowernumber'};
1489     my $brn =$dbh->quote($borrowernumber);
1490     my %currentissues;
1491     my $select = "select issues.timestamp, issues.date_due, items.biblionumber,
1492                          items.barcode, biblio.title, biblio.author, biblioitems.dewey,
1493                          biblioitems.subclass
1494                     from issues,items,biblioitems,biblio
1495                    where issues.borrowernumber = $brn
1496                      and issues.itemnumber = items.itemnumber
1497                      and items.biblionumber = biblio.biblionumber
1498                      and items.biblioitemnumber = biblioitems.biblioitemnumber
1499                      and issues.returndate is null
1500                          order by issues.date_due";
1501 #    warn $select;
1502     my $sth=$dbh->prepare($select);
1503     $sth->execute;
1504     my $counter = 0;
1505     while (my $data = $sth->fetchrow_hashref) {
1506         $data->{'dewey'} =~ s/0*$//;
1507         ($data->{'dewey'} == 0) && ($data->{'dewey'} = '');
1508                 # FIXME - The Dewey code is a string, not a number.
1509         # FIXME - Use POSIX::strftime to get a text version of today's
1510         # date. That's what it's for.
1511         # FIXME - Move the date calculation outside of the loop.
1512         my @datearr = localtime(time());
1513         my $todaysdate = (1900+$datearr[5]).sprintf ("%0.2d", ($datearr[4]+1)).sprintf ("%0.2d", $datearr[3]);
1514
1515         # FIXME - Instead of converting the due date to YYYYMMDD, just
1516         # use
1517         #       $todaysdate = POSIX::strftime("%Y-%m-%d", localtime);
1518         #       ...
1519         #       if ($date->{date_due} lt $todaysdate)
1520         my $datedue = $data->{'date_due'};
1521         $datedue =~ s/-//g;
1522         if ($datedue < $todaysdate) {
1523             $data->{'overdue'} = 1;
1524         }
1525         $currentissues{$counter} = $data;
1526         $counter++;
1527                 # FIXME - This is ludicrous. If you want to return an
1528                 # array of values, just use an array. That's what
1529                 # they're there for.
1530     }
1531     $sth->finish;
1532     return(\%currentissues);
1533 }
1534
1535 # Not exported
1536 sub checkwaiting {
1537 #Stolen from Main.pm
1538   # check for reserves waiting
1539   my ($env,$dbh,$bornum)=@_;
1540   my @itemswaiting;
1541   my $query = "select * from reserves
1542     where (borrowernumber = '$bornum')
1543     and (reserves.found='W') and cancellationdate is NULL";
1544   my $sth = $dbh->prepare($query);
1545   $sth->execute();
1546   my $cnt=0;
1547   if (my $data=$sth->fetchrow_hashref) {
1548     $itemswaiting[$cnt] =$data;
1549     $cnt ++
1550   }
1551   $sth->finish;
1552   return ($cnt,\@itemswaiting);
1553 }
1554
1555 # Not exported
1556 # FIXME - This is nearly-identical to &C4::Accounts::checkaccount
1557 sub checkaccount  {
1558 # Stolen from Accounts.pm
1559   #take borrower number
1560   #check accounts and list amounts owing
1561   my ($env,$bornumber,$dbh,$date)=@_;
1562   my $select="Select sum(amountoutstanding) from accountlines where
1563   borrowernumber=$bornumber and amountoutstanding<>0";
1564   if ($date ne ''){
1565     $select.=" and date < '$date'";
1566   }
1567 #  print $select;
1568   my $sth=$dbh->prepare($select);
1569   $sth->execute;
1570   my $total=0;
1571   while (my $data=$sth->fetchrow_hashref){
1572     # FIXME = +=
1573     $total=$total+$data->{'sum(amountoutstanding)'};
1574   }
1575   $sth->finish;
1576   # output(1,2,"borrower owes $total");
1577   #if ($total > 0){
1578   #  # output(1,2,"borrower owes $total");
1579   #  if ($total > 5){
1580   #    reconcileaccount($env,$dbh,$bornumber,$total);
1581   #  }
1582   #}
1583   #  pause();
1584   return($total);
1585 }
1586
1587 # FIXME - This is identical to &C4::Circulation::Renewals::renewstatus.
1588 # Pick one and stick with it.
1589 sub renewstatus {
1590 # Stolen from Renewals.pm
1591   # check renewal status
1592   my ($env,$dbh,$bornum,$itemno)=@_;
1593   my $renews = 1;
1594   my $renewokay = 0;
1595   my $q1 = "select * from issues
1596     where (borrowernumber = '$bornum')
1597     and (itemnumber = '$itemno')
1598     and returndate is null";
1599   my $sth1 = $dbh->prepare($q1);
1600   $sth1->execute;
1601   if (my $data1 = $sth1->fetchrow_hashref) {
1602     my $q2 = "select renewalsallowed from items,biblioitems,itemtypes
1603        where (items.itemnumber = '$itemno')
1604        and (items.biblioitemnumber = biblioitems.biblioitemnumber)
1605        and (biblioitems.itemtype = itemtypes.itemtype)";
1606     my $sth2 = $dbh->prepare($q2);
1607     $sth2->execute;
1608     if (my $data2=$sth2->fetchrow_hashref) {
1609       $renews = $data2->{'renewalsallowed'};
1610     }
1611     if ($renews > $data1->{'renewals'}) {
1612       $renewokay = 1;
1613     }
1614     $sth2->finish;
1615   }
1616   $sth1->finish;
1617   return($renewokay);
1618 }
1619
1620 sub renewbook {
1621 # Stolen from Renewals.pm
1622   # mark book as renewed
1623   my ($env,$dbh,$bornum,$itemno,$datedue)=@_;
1624   $datedue=$env->{'datedue'};
1625   if ($datedue eq "" ) {
1626     my $loanlength=21;
1627     my $query= "Select * from biblioitems,items,itemtypes
1628        where (items.itemnumber = '$itemno')
1629        and (biblioitems.biblioitemnumber = items.biblioitemnumber)
1630        and (biblioitems.itemtype = itemtypes.itemtype)";
1631     my $sth=$dbh->prepare($query);
1632     $sth->execute;
1633     if (my $data=$sth->fetchrow_hashref) {
1634       $loanlength = $data->{'loanlength'}
1635     }
1636     $sth->finish;
1637     my $ti = time;
1638     my $datedu = time + ($loanlength * 86400);
1639     my @datearr = localtime($datedu);
1640     $datedue = (1900+$datearr[5])."-".($datearr[4]+1)."-".$datearr[3];
1641   }
1642   my @date = split("-",$datedue);
1643   my $odatedue = ($date[2]+0)."-".($date[1]+0)."-".$date[0];
1644   my $issquery = "select * from issues where borrowernumber='$bornum' and
1645     itemnumber='$itemno' and returndate is null";
1646   my $sth=$dbh->prepare($issquery);
1647   $sth->execute;
1648   my $issuedata=$sth->fetchrow_hashref;
1649   $sth->finish;
1650   my $renews = $issuedata->{'renewals'} +1;
1651   my $updquery = "update issues
1652     set date_due = '$datedue', renewals = '$renews'
1653     where borrowernumber='$bornum' and
1654     itemnumber='$itemno' and returndate is null";
1655   $sth=$dbh->prepare($updquery);
1656
1657   $sth->execute;
1658   $sth->finish;
1659   return($odatedue);
1660 }
1661
1662 # FIXME - This is almost, but not quite, identical to
1663 # &C4::Circulation::Issues::calc_charges and
1664 # &C4::Circulation::Renewals2::calc_charges.
1665 # Pick one and stick with it.
1666 sub calc_charges {
1667 # Stolen from Issues.pm
1668 # calculate charges due
1669     my ($env, $dbh, $itemno, $bornum)=@_;
1670 #    if (!$dbh){
1671 #      $dbh=C4Connect();
1672 #    }
1673     my $charge=0;
1674 #    open (FILE,">>/tmp/charges");
1675     my $item_type;
1676     my $q1 = "select itemtypes.itemtype,rentalcharge from items,biblioitems,itemtypes
1677     where (items.itemnumber ='$itemno')
1678     and (biblioitems.biblioitemnumber = items.biblioitemnumber)
1679     and (biblioitems.itemtype = itemtypes.itemtype)";
1680     my $sth1= $dbh->prepare($q1);
1681 #    print FILE "$q1\n";
1682     $sth1->execute;
1683     if (my $data1=$sth1->fetchrow_hashref) {
1684         $item_type = $data1->{'itemtype'};
1685         $charge = $data1->{'rentalcharge'};
1686 #       print FILE "charge is $charge\n";
1687         my $q2 = "select rentaldiscount from borrowers,categoryitem
1688         where (borrowers.borrowernumber = '$bornum')
1689         and (borrowers.categorycode = categoryitem.categorycode)
1690         and (categoryitem.itemtype = '$item_type')";
1691         my $sth2=$dbh->prepare($q2);
1692 #       warn $q2;
1693         $sth2->execute;
1694         if (my $data2=$sth2->fetchrow_hashref) {
1695             my $discount = $data2->{'rentaldiscount'};
1696 #           print FILE "discount is $discount";
1697             if ($discount eq 'NULL') {
1698               $discount=0;
1699             }
1700             $charge = ($charge *(100 - $discount)) / 100;
1701         }
1702         $sth2->finish;
1703     }
1704     $sth1->finish;
1705 #    close FILE;
1706     return ($charge);
1707 }
1708
1709 # FIXME - A virtually identical function appears in
1710 # C4::Circulation::Issues. Pick one and stick with it.
1711 sub createcharge {
1712 #Stolen from Issues.pm
1713     my ($env,$dbh,$itemno,$bornum,$charge) = @_;
1714     my $nextaccntno = getnextacctno($env,$bornum,$dbh);
1715     my $sth = $dbh->prepare(<<EOT);
1716         INSERT INTO     accountlines
1717                         (borrowernumber, itemnumber, accountno,
1718                          date, amount, description, accounttype,
1719                          amountoutstanding)
1720         VALUES          (?, ?, ?,
1721                          now(), ?, 'Rental', 'Rent',
1722                          ?)
1723 EOT
1724     $sth->execute($bornum, $itemno, $nextaccntno, $charge, $charge);
1725     $sth->finish;
1726 }
1727
1728
1729 sub getnextacctno {
1730 # Stolen from Accounts.pm
1731     my ($env,$bornumber,$dbh)=@_;
1732     my $nextaccntno = 1;
1733     my $query = "select * from accountlines where (borrowernumber = '$bornumber') order by accountno desc";
1734     my $sth = $dbh->prepare($query);
1735     $sth->execute;
1736     if (my $accdata=$sth->fetchrow_hashref){
1737         $nextaccntno = $accdata->{'accountno'} + 1;
1738     }
1739     $sth->finish;
1740     return($nextaccntno);
1741 }
1742
1743 =item find_reserves
1744
1745   ($status, $record) = &find_reserves($itemnumber);
1746
1747 Looks up an item in the reserves.
1748
1749 C<$itemnumber> is the itemnumber to look up.
1750
1751 C<$status> is true iff the search was successful.
1752
1753 C<$record> is a reference-to-hash describing the reserve. Its keys are
1754 the fields from the reserves table of the Koha database.
1755
1756 =cut
1757 #'
1758 # FIXME - This API is bogus: just return the record, or undef if none
1759 # was found.
1760 # FIXME - There's also a &C4::Circulation::Returns::find_reserves, but
1761 # that one looks rather different.
1762 sub find_reserves {
1763 # Stolen from Returns.pm
1764     my ($itemno) = @_;
1765     my %env;
1766     my $dbh = C4::Context->dbh;
1767     my ($itemdata) = getiteminformation(\%env, $itemno,0);
1768     my $bibno = $dbh->quote($itemdata->{'biblionumber'});
1769     my $bibitm = $dbh->quote($itemdata->{'biblioitemnumber'});
1770     my $query = "select * from reserves where ((found = 'W') or (found is null))
1771                        and biblionumber = $bibno and cancellationdate is NULL
1772                        order by priority, reservedate ";
1773     my $sth = $dbh->prepare($query);
1774     $sth->execute;
1775     my $resfound = 0;
1776     my $resrec;
1777     my $lastrec;
1778 # print $query;
1779
1780     # FIXME - I'm not really sure what's going on here, but since we
1781     # only want one result, wouldn't it be possible (and far more
1782     # efficient) to do something clever in SQL that only returns one
1783     # set of values?
1784     while (($resrec = $sth->fetchrow_hashref) && (not $resfound)) {
1785                 # FIXME - Unlike Pascal, Perl allows you to exit loops
1786                 # early. Take out the "&& (not $resfound)" and just
1787                 # use "last" at the appropriate point in the loop.
1788                 # (Oh, and just in passing: if you'd used "!" instead
1789                 # of "not", you wouldn't have needed the parentheses.)
1790         $lastrec = $resrec;
1791         my $brn = $dbh->quote($resrec->{'borrowernumber'});
1792         my $rdate = $dbh->quote($resrec->{'reservedate'});
1793         my $bibno = $dbh->quote($resrec->{'biblionumber'});
1794         if ($resrec->{'found'} eq "W") {
1795             if ($resrec->{'itemnumber'} eq $itemno) {
1796                 $resfound = 1;
1797             }
1798         } else {
1799             # FIXME - Use 'elsif' to avoid unnecessary indentation.
1800             if ($resrec->{'constrainttype'} eq "a") {
1801                 $resfound = 1;
1802             } else {
1803                 my $conquery = "select * from reserveconstraints where borrowernumber = $brn
1804                      and reservedate = $rdate and biblionumber = $bibno and biblioitemnumber = $bibitm";
1805                 my $consth = $dbh->prepare($conquery);
1806                 $consth->execute;
1807                 if (my $conrec = $consth->fetchrow_hashref) {
1808                     if ($resrec->{'constrainttype'} eq "o") {
1809                         $resfound = 1;
1810                     }
1811                 }
1812                 $consth->finish;
1813             }
1814         }
1815         if ($resfound) {
1816             my $updquery = "update reserves set found = 'W', itemnumber = '$itemno'
1817                   where borrowernumber = $brn and reservedate = $rdate and biblionumber = $bibno";
1818             my $updsth = $dbh->prepare($updquery);
1819             $updsth->execute;
1820             $updsth->finish;
1821             # FIXME - "last;" here to break out of the loop early.
1822         }
1823     }
1824     $sth->finish;
1825     return ($resfound,$lastrec);
1826 }
1827
1828 1;
1829 __END__
1830
1831 =back
1832
1833 =head1 AUTHOR
1834
1835 Koha Developement team <info@koha.org>
1836
1837 =cut