C4/Circulation/Circ2.pm

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