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 use warnings;
  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 use C4::UploadedFile;
  35 use C4::BackgroundJob;
  36
  37 use Date::Calc qw( Add_Delta_Days Date_to_Days );
  38
  39 use constant DEBUG => 0;
  40
  41 # this is the file version number that we're coded against.
  42 my $FILE_VERSION = '1.0';
  43
  44 our $query = CGI->new;
  45
  46 my ($template, $loggedinuser, $cookie)
  47   = get_template_and_user( { template_name => "offline_circ/process_koc.tmpl",
  48                                 query => $query,
  49                                 type => "intranet",
  50                                 authnotrequired => 1,
  51                                 debug => 1,
  52                                 });
  53
  54
  55 my $fileID=$query->param('uploadedfileid');
  56 my $runinbackground = $query->param('runinbackground');
  57 my $completedJobID = $query->param('completedJobID');
  58 my %cookies = parse CGI::Cookie($cookie);
  59 my $sessionID = $cookies{'CGISESSID'}->value;
  60 ## 'Local' globals.
  61 our $dbh = C4::Context->dbh();
  62 our @output = (); ## For storing messages to be displayed to the user
  63
  64
  65 if ($completedJobID) {
  66     my $job = C4::BackgroundJob->fetch($sessionID, $completedJobID);
  67     my $results = $job->results();
  68     $template->param(transactions_loaded => 1);
  69     $template->param(messages => $results->{results});
  70 } elsif ($fileID) {
  71     my $uploaded_file = C4::UploadedFile->fetch($sessionID, $fileID);
  72     my $fh = $uploaded_file->fh();
  73     my @input_lines = <$fh>;
  74
  75     my $filename = $uploaded_file->name();
  76     my $job = undef;
  77
  78     if ($runinbackground) {
  79         my $job_size = scalar(@input_lines);
  80         $job = C4::BackgroundJob->new($sessionID, $filename, $ENV{'SCRIPT_NAME'}, $job_size);
  81         my $jobID = $job->id();
  82
  83         # fork off
  84         if (my $pid = fork) {
  85             # parent
  86             # return job ID as JSON
  87
  88             # prevent parent exiting from
  89             # destroying the kid's database handle
  90             # FIXME: according to DBI doc, this may not work for Oracle
  91             $dbh->{InactiveDestroy}  = 1;
  92
  93             my $reply = CGI->new("");
  94             print $reply->header(-type => 'text/html');
  95             print "{ jobID: '$jobID' }";
  96             exit 0;
  97         } elsif (defined $pid) {
  98             # child
  99             # close STDOUT to signal to Apache that
 100             # we're now running in the background
 101             close STDOUT;
 102             close STDERR;
 103         } else {
 104             # fork failed, so exit immediately
 105             # fork failed, so exit immediately
 106             warn "fork failed while attempting to run $ENV{'SCRIPT_NAME'} as a background job";
 107             exit 0;
 108         }
 109
 110         # if we get here, we're a child that has detached
 111         # itself from Apache
 112
 113     }
 114
 115     my $header_line = shift @input_lines;
 116     my $file_info   = parse_header_line($header_line);
 117     if ($file_info->{'Version'} ne $FILE_VERSION) {
 118         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." } );
 119     }
 120
 121
 122     my $i = 0;
 123     foreach  my $line (@input_lines)  {
 124
 125         $i++;
 126         my $command_line = parse_command_line($line);
 127
 128         # map command names in the file to subroutine names
 129         my %dispatch_table = (
 130             issue     => \&kocIssueItem,
 131             'return'  => \&kocReturnItem,
 132             payment   => \&kocMakePayment,
 133         );
 134
 135         # call the right sub name, passing the hashref of command_line to it.
 136         if ( exists $dispatch_table{ $command_line->{'command'} } ) {
 137             $dispatch_table{ $command_line->{'command'} }->($command_line);
 138         } else {
 139             warn "unknown command: '$command_line->{command}' not processed";
 140         }
 141
 142         if ($runinbackground) {
 143             $job->progress($i);
 144         }
 145     }
 146
 147     if ($runinbackground) {
 148         $job->finish({ results => \@output }) if defined($job);
 149     } else {
 150         $template->param(transactions_loaded => 1);
 151         $template->param(messages => \@output);
 152     }
 153 }
 154
 155 output_html_with_http_headers $query, $cookie, $template->output;
 156
 157 =head3 parse_header_line
 158
 159 parses the header line from a .koc file. This is the line that
 160 specifies things such as the file version, and the name and version of
 161 the offline circulation tool that generated the file. See
 162 L<http://wiki.koha.org/doku.php?id=koha_offline_circulation_file_format>
 163 for more information.
 164
 165 pass in a string containing the header line (the first line from th
 166 file).
 167
 168 returns a hashref containing the information from the header.
 169
 170 =cut
 171
 172 sub parse_header_line {
 173     my $header_line = shift;
 174     chomp($header_line);
 175
 176     my @fields = split( /\t/, $header_line );
 177     my %header_info = map { split( /=/, $_ ) } @fields;
 178     return \%header_info;
 179 }
 180
 181 =head3 parse_command_line
 182
 183 =cut
 184
 185 sub parse_command_line {
 186     my $command_line = shift;
 187     chomp($command_line);
 188
 189     my ( $timestamp, $command, @args ) = split( /\t/, $command_line );
 190     my ( $date,      $time,    $id )   = split( /\s/, $timestamp );
 191
 192     my %command = (
 193         date    => $date,
 194         time    => $time,
 195         id      => $id,
 196         command => $command,
 197     );
 198
 199     # set the rest of the keys using a hash slice
 200     my $argument_names = arguments_for_command($command);
 201     @command{@$argument_names} = @args;
 202
 203     return \%command;
 204
 205 }
 206
 207 =head3 arguments_for_command
 208
 209 fetches the names of the columns (and function arguments) found in the
 210 .koc file for a particular command name. For instance, the C<issue>
 211 command requires a C<cardnumber> and C<barcode>. In that case this
 212 function returns a reference to the list C<qw( cardnumber barcode )>.
 213
 214 parameters: the command name
 215
 216 returns: listref of column names.
 217
 218 =cut
 219
 220 sub arguments_for_command {
 221     my $command = shift;
 222
 223     # define the fields for this version of the file.
 224     my %format = (
 225         issue   => [qw( cardnumber barcode )],
 226         return  => [qw( barcode )],
 227         payment => [qw( cardnumber amount )],
 228     );
 229
 230     return $format{$command};
 231 }
 232
 233 sub kocIssueItem {
 234   my $circ = shift;
 235
 236   my $branchcode = C4::Context->userenv->{branch};
 237   my $borrower = GetMember( $circ->{ 'cardnumber' }, 'cardnumber' );
 238   my $item = GetBiblioFromItemNumber( undef, $circ->{ 'barcode' } );
 239   my $issue = GetItemIssue( $item->{'itemnumber'} );
 240
 241   my $issuingrule = GetIssuingRule( $borrower->{ 'categorycode' }, $item->{ 'itemtype' }, $branchcode );
 242   my $issuelength = $issuingrule->{ 'issuelength' };
 243   my ( $year, $month, $day ) = split( /-/, $circ->{'date'} );
 244   ( $year, $month, $day ) = Add_Delta_Days( $year, $month, $day, $issuelength );
 245   my $date_due = sprintf("%04d-%02d-%02d", $year, $month, $day);
 246
 247   if ( $issue->{ 'date_due' } ) { ## Item is currently checked out to another person.
 248 #warn "Item Currently Issued.";
 249     my $issue = GetOpenIssue( $item->{'itemnumber'} );
 250
 251     if ( $issue->{'borrowernumber'} eq $borrower->{'borrowernumber'} ) { ## Issued to this person already, renew it.
 252 #warn "Item issued to this member already, renewing.";
 253
 254     my $date_due_object = C4::Dates->new($date_due ,'iso');
 255     C4::Circulation::AddRenewal(
 256         $issue->{'borrowernumber'},    # borrowernumber
 257         $item->{'itemnumber'},         # itemnumber
 258         undef,                         # branch
 259         $date_due_object,              # datedue
 260         $circ->{'date'},               # issuedate
 261     ) unless ($DEBUG);
 262
 263       push( @output, { message => "Renewed $item->{ 'title' } ( $item->{ 'barcode' } ) to $borrower->{ 'firstname' } $borrower->{ 'surename' } ( $borrower->{'cardnumber'} ) : $circ->{ 'datetime' }\n" } );
 264
 265     } else {
 266 #warn "Item issued to a different member.";
 267 #warn "Date of previous issue: $issue->{'issuedate'}";
 268 #warn "Date of this issue: $circ->{'date'}";
 269       my ( $i_y, $i_m, $i_d ) = split( /-/, $issue->{'issuedate'} );
 270       my ( $c_y, $c_m, $c_d ) = split( /-/, $circ->{'date'} );
 271
 272       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.
 273         my $date_due_object = C4::Dates->new($date_due ,'iso');
 274         C4::Circulation::AddIssue( $borrower, $circ->{'barcode'}, $date_due_object ) unless ( DEBUG );
 275         push( @output, { message => "Issued $item->{ 'title' } ( $item->{ 'barcode' } ) to $borrower->{ 'firstname' } $borrower->{ 'surename' } ( $borrower->{'cardnumber'} ) : $circ->{ 'datetime' }\n" } );
 276
 277       } 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.
 278 #warn "Current issue to another member is newer. Doing nothing";
 279         ## This situation should only happen of the Offline Circ data is *really* old.
 280         ## FIXME: write line to old_issues and statistics
 281       }
 282
 283     }
 284   } else { ## Item is not checked out to anyone at the moment, go ahead and issue it
 285       my $date_due_object = C4::Dates->new($date_due ,'iso');
 286       C4::Circulation::AddIssue( $borrower, $circ->{'barcode'}, $date_due_object ) unless ( DEBUG );
 287     push( @output, { message => "Issued $item->{ 'title' } ( $item->{ 'barcode' } ) to $borrower->{ 'firstname' } $borrower->{ 'surename' } ( $borrower->{'cardnumber'} ) : $circ->{ 'datetime' }\n" } );
 288   }
 289 }
 290
 291 sub kocReturnItem {
 292   my ( $circ ) = @_;
 293   my $item = GetBiblioFromItemNumber( undef, $circ->{ 'barcode' } );
 294   #warn( Data::Dumper->Dump( [ $circ, $item ], [ qw( circ item ) ] ) );
 295   my $borrowernumber = _get_borrowernumber_from_barcode( $circ->{'barcode'} );
 296   unless ( $borrowernumber ) {
 297       push( @output, { message => "Warning: unable to determine borrower from item ($item->{'barcode'}). Cannot mark returned\n" } );
 298   }
 299   C4::Circulation::MarkIssueReturned( $borrowernumber,
 300                                       $item->{'itemnumber'},
 301                                       undef,
 302                                       $circ->{'date'} );
 303
 304   push( @output, { message => "Returned $item->{ 'title' } ( $item->{ 'barcode' } ) From borrower number $borrowernumber : $circ->{ 'datetime' }\n" } );
 305 }
 306
 307 sub kocMakePayment {
 308   my ( $circ ) = @_;
 309   my $borrower = GetMember( $circ->{ 'cardnumber' }, 'cardnumber' );
 310   recordpayment( $borrower->{'borrowernumber'}, $circ->{'amount'} );
 311   push( @output, { message => "accepted payment ($circ->{'amount'}) from cardnumber ($circ->{'cardnumber'}), borrower ($borrower->{'borrowernumber'})" } );
 312 }
 313
 314 =head3 _get_borrowernumber_from_barcode
 315
 316 pass in a barcode
 317 get back the borrowernumber of the patron who has it checked out.
 318 undef if that can't be found
 319
 320 =cut
 321
 322 sub _get_borrowernumber_from_barcode {
 323     my $barcode = shift;
 324
 325     return unless $barcode;
 326
 327     my $item = GetBiblioFromItemNumber( undef, $barcode );
 328     return unless $item->{'itemnumber'};
 329
 330     my $issue = C4::Circulation::GetItemIssue( $item->{'itemnumber'} );
 331     return unless $issue->{'borrowernumber'};
 332     return $issue->{'borrowernumber'};
 333
 334 }