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