offline_circ/process_koc.pl

   1 #!/usr/bin/perl
   2
   3 # 2008 Kyle Hall <kyle.m.hall@gmail.com>
   4
   5 # This file is part of Koha.
   6 #
   7 # Koha is free software; you can redistribute it and/or modify it under the
   8 # terms of the GNU General Public License as published by the Free Software
   9 # Foundation; either version 2 of the License, or (at your option) any later
  10 # version.
  11 #
  12 # Koha is distributed in the hope that it will be useful, but WITHOUT ANY
  13 # WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
  14 # A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
  15 #
  16 # You should have received a copy of the GNU General Public License along with
  17 # Koha; if not, write to the Free Software Foundation, Inc., 59 Temple Place,
  18 # Suite 330, Boston, MA  02111-1307 USA
  19 #
  20
  21 use strict;
  22 require Exporter;
  23
  24 use CGI;
  25 use C4::Output;
  26 use C4::Auth;
  27 use C4::Koha;
  28 use C4::Context;
  29 use C4::Biblio;
  30 use C4::Accounts;
  31 use C4::Circulation;
  32 use C4::Members;
  33 use C4::Stats;
  34
  35 use Date::Calc qw( Add_Delta_Days Date_to_Days );
  36
  37 use constant DEBUG => 0;
  38
  39 # this is the file version number that we're coded against.
  40 my $FILE_VERSION = '1.0';
  41
  42 our $query = CGI->new;
  43
  44 my ($template, $loggedinuser, $cookie)
  45   = get_template_and_user( { template_name => "offline_circ/process_koc.tmpl",
  46                                 query => $query,
  47                                 type => "intranet",
  48                                 authnotrequired => 1,
  49                                 debug => 1,
  50                                 });
  51
  52 ## 'Local' globals.
  53 our $dbh = C4::Context->dbh();
  54 our @output; ## For storing messages to be displayed to the user
  55
  56 $query::POST_MAX = 1024 * 10000;
  57 my $file = $query->param("kocfile");
  58 $file=~m/^.*(\\|\/)(.*)/; # strip the remote path and keep the filename
  59
  60 my $header_line = <$file>;
  61 my $file_info   = parse_header_line($header_line);
  62 if ($file_info->{'Version'} ne $FILE_VERSION) {
  63     push( @output, { message => "Warning: This file is version '$file_info->{'Version'}', but I only know how to import version '$FILE_VERSION'. I'll try my best." } );
  64 }
  65
  66
  67 while ( my $line = <$file> ) {
  68
  69     # my ( $date, $time, $command, @arguments ) = parse_command_line( $line );
  70     my $command_line = parse_command_line($line);
  71
  72     # map command names in the file to subroutine names
  73     my %dispatch_table = (
  74         issue   => \&kocIssueItem,
  75         return  => \&kocReturnItem,
  76         payment => \&kocMakePayment,
  77     );
  78
  79     # call the right sub name, passing the hashref of command_line to it.
  80     if ( exists $dispatch_table{ $command_line->{'command'} } ) {
  81         $dispatch_table{ $command_line->{'command'} }->($command_line);
  82     } else {
  83         warn "unknown command: '$command_line->{command}' not processed";
  84     }
  85
  86 }
  87
  88 $template->param(
  89                 intranetcolorstylesheet => C4::Context->preference("intranetcolorstylesheet"),
  90                 intranetstylesheet => C4::Context->preference("intranetstylesheet"),
  91                 IntranetNav => C4::Context->preference("IntranetNav"),
  92
  93                 messages => \@output,
  94         );
  95 output_html_with_http_headers $query, $cookie, $template->output;
  96
  97 =head3 parse_header_line
  98
  99 parses the header line from a .koc file. This is the line that
 100 specifies things such as the file version, and the name and version of
 101 the offline circulation tool that generated the file. See
 102 L<http://wiki.koha.org/doku.php?id=koha_offline_circulation_file_format>
 103 for more information.
 104
 105 pass in a string containing the header line (the first line from th
 106 file).
 107
 108 returns a hashref containing the information from the header.
 109
 110 =cut
 111
 112 sub parse_header_line {
 113     my $header_line = shift;
 114     chomp($header_line);
 115
 116     my @fields = split( /\t/, $header_line );
 117     my %header_info = map { split( /=/, $_ ) } @fields;
 118     return \%header_info;
 119 }
 120
 121 =head3 parse_command_line
 122
 123 =cut
 124
 125 sub parse_command_line {
 126     my $command_line = shift;
 127     chomp($command_line);
 128
 129     my ( $timestamp, $command, @args ) = split( /\t/, $command_line );
 130     my ( $date,      $time,    $id )   = split( /\s/, $timestamp );
 131
 132     my %command = (
 133         date    => $date,
 134         time    => $time,
 135         id      => $id,
 136         command => $command,
 137     );
 138
 139     # set the rest of the keys using a hash slice
 140     my $argument_names = arguments_for_command($command);
 141     @command{@$argument_names} = @args;
 142
 143     return \%command;
 144
 145 }
 146
 147 =head3 arguments_for_command
 148
 149 fetches the names of the columns (and function arguments) found in the
 150 .koc file for a particular command name. For instance, the C<issue>
 151 command requires a C<cardnumber> and C<barcode>. In that case this
 152 function returns a reference to the list C<qw( cardnumber barcode )>.
 153
 154 parameters: the command name
 155
 156 returns: listref of column names.
 157
 158 =cut
 159
 160 sub arguments_for_command {
 161     my $command = shift;
 162
 163     # define the fields for this version of the file.
 164     my %format = (
 165         issue   => [qw( cardnumber barcode )],
 166         return  => [qw( barcode )],
 167         payment => [qw( cardnumber amount )],
 168     );
 169
 170     return $format{$command};
 171 }
 172
 173 sub kocIssueItem {
 174   my $circ = shift;
 175
 176   my $branchcode = C4::Context->userenv->{branch};
 177   my $borrower = GetMember( $circ->{ 'cardnumber' }, 'cardnumber' );
 178   my $item = GetBiblioFromItemNumber( undef, $circ->{ 'barcode' } );
 179   my $issue = GetItemIssue( $item->{'itemnumber'} );
 180
 181   my $issuingrule = GetIssuingRule( $borrower->{ 'categorycode' }, $item->{ 'itemtype' }, $branchcode );
 182   my $issuelength = $issuingrule->{ 'issuelength' };
 183   my ( $year, $month, $day ) = split( /-/, $circ->{'date'} );
 184   ( $year, $month, $day ) = Add_Delta_Days( $year, $month, $day, $issuelength );
 185   my $date_due = sprintf("%04d-%02d-%02d", $year, $month, $day);
 186
 187   if ( $issue->{ 'date_due' } ) { ## Item is currently checked out to another person.
 188 warn "Item Currently Issued.";
 189     my $issue = GetOpenIssue( $item->{'itemnumber'} );
 190
 191     if ( $issue->{'borrowernumber'} eq $borrower->{'borrowernumber'} ) { ## Issued to this person already, renew it.
 192 warn "Item issued to this member already, renewing.";
 193
 194     my $date_due_object = C4::Dates->new($date_due ,'iso');
 195     C4::Circulation::AddRenewal(
 196         $issue->{'borrowernumber'},    # borrowernumber
 197         $item->{'itemnumber'},         # itemnumber
 198         undef,                         # branch
 199         $date_due_object,              # datedue
 200         $circ->{'date'},               # issuedate
 201     ) unless ($DEBUG);
 202
 203       push( @output, { message => "Renewed $item->{ 'title' } ( $item->{ 'barcode' } ) to $borrower->{ 'firstname' } $borrower->{ 'surename' } ( $borrower->{'cardnumber'} ) : $circ->{ 'datetime' }\n" } );
 204
 205     } else {
 206 warn "Item issued to a different member.";
 207 warn "Date of previous issue: $issue->{'issuedate'}";
 208 warn "Date of this issue: $circ->{'date'}";
 209       my ( $i_y, $i_m, $i_d ) = split( /-/, $issue->{'issuedate'} );
 210       my ( $c_y, $c_m, $c_d ) = split( /-/, $circ->{'date'} );
 211
 212       if ( Date_to_Days( $i_y, $i_m, $i_d ) < Date_to_Days( $c_y, $c_m, $c_d ) ) { ## Current issue to a different persion is older than this issue, return and issue.
 213         C4::Circulation::AddIssue( $borrower, $circ->{'barcode'}, $date_due ) unless ( DEBUG );
 214         push( @output, { message => "Issued $item->{ 'title' } ( $item->{ 'barcode' } ) to $borrower->{ 'firstname' } $borrower->{ 'surename' } ( $borrower->{'cardnumber'} ) : $circ->{ 'datetime' }\n" } );
 215
 216       } else { ## Current issue is *newer* than this issue, write a 'returned' issue, as the item is most likely in the hands of someone else now.
 217 warn "Current issue to another member is newer. Doing nothing";
 218         ## This situation should only happen of the Offline Circ data is *really* old.
 219         ## FIXME: write line to old_issues and statistics
 220       }
 221
 222     }
 223   } else { ## Item is not checked out to anyone at the moment, go ahead and issue it
 224       C4::Circulation::AddIssue( $borrower, $circ->{'barcode'}, $date_due ) unless ( DEBUG );
 225     push( @output, { message => "Issued $item->{ 'title' } ( $item->{ 'barcode' } ) to $borrower->{ 'firstname' } $borrower->{ 'surename' } ( $borrower->{'cardnumber'} ) : $circ->{ 'datetime' }\n" } );
 226   }
 227 }
 228
 229 sub kocReturnItem {
 230   my ( $circ ) = @_;
 231   my $item = GetBiblioFromItemNumber( undef, $circ->{ 'barcode' } );
 232   warn( Data::Dumper->Dump( [ $circ, $item ], [ qw( circ item ) ] ) );
 233   my $borrowernumber = _get_borrowernumber_from_barcode( $circ->{'barcode'} );
 234   unless ( $borrowernumber ) {
 235       push( @output, { message => "Warning: unable to determine borrower from item ($item->{'barcode'}). Cannot mark returned\n" } );
 236   }
 237   C4::Circulation::MarkIssueReturned( $borrowernumber,
 238                                       $item->{'itemnumber'},
 239                                       undef,
 240                                       $circ->{'date'} );
 241
 242   push( @output, { message => "Returned $item->{ 'title' } ( $item->{ 'barcode' } ) From borrower number $borrowernumber : $circ->{ 'datetime' }\n" } );
 243 }
 244
 245 sub kocMakePayment {
 246   my ( $circ ) = @_;
 247   my $borrower = GetMember( $circ->{ 'cardnumber' }, 'cardnumber' );
 248   recordpayment( $borrower->{'borrowernumber'}, $circ->{'amount'} );
 249   push( @output, { message => "accepted payment ($circ->{'amount'}) from cardnumber ($circ->{'cardnumber'}), borrower ($borrower->{'borrowernumber'})" } );
 250 }
 251
 252 =head3 _get_borrowernumber_from_barcode
 253
 254 pass in a barcode
 255 get back the borrowernumber of the patron who has it checked out.
 256 undef if that can't be found
 257
 258 =cut
 259
 260 sub _get_borrowernumber_from_barcode {
 261     my $barcode = shift;
 262
 263     return unless $barcode;
 264
 265     my $item = GetBiblioFromItemNumber( undef, $barcode );
 266     return unless $item->{'itemnumber'};
 267
 268     my $issue = C4::Circulation::GetItemIssue( $item->{'itemnumber'} );
 269     return unless $issue->{'borrowernumber'};
 270     return $issue->{'borrowernumber'};
 271
 272 }