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         my $date_due_object = C4::Dates->new($date_due ,'iso');
 214         C4::Circulation::AddIssue( $borrower, $circ->{'barcode'}, $date_due_object ) unless ( DEBUG );
 215         push( @output, { message => "Issued $item->{ 'title' } ( $item->{ 'barcode' } ) to $borrower->{ 'firstname' } $borrower->{ 'surename' } ( $borrower->{'cardnumber'} ) : $circ->{ 'datetime' }\n" } );
 216
 217       } 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.
 218 #warn "Current issue to another member is newer. Doing nothing";
 219         ## This situation should only happen of the Offline Circ data is *really* old.
 220         ## FIXME: write line to old_issues and statistics
 221       }
 222
 223     }
 224   } else { ## Item is not checked out to anyone at the moment, go ahead and issue it
 225       my $date_due_object = C4::Dates->new($date_due ,'iso');
 226       C4::Circulation::AddIssue( $borrower, $circ->{'barcode'}, $date_due_object ) unless ( DEBUG );
 227     push( @output, { message => "Issued $item->{ 'title' } ( $item->{ 'barcode' } ) to $borrower->{ 'firstname' } $borrower->{ 'surename' } ( $borrower->{'cardnumber'} ) : $circ->{ 'datetime' }\n" } );
 228   }
 229 }
 230
 231 sub kocReturnItem {
 232   my ( $circ ) = @_;
 233   my $item = GetBiblioFromItemNumber( undef, $circ->{ 'barcode' } );
 234   #warn( Data::Dumper->Dump( [ $circ, $item ], [ qw( circ item ) ] ) );
 235   my $borrowernumber = _get_borrowernumber_from_barcode( $circ->{'barcode'} );
 236   unless ( $borrowernumber ) {
 237       push( @output, { message => "Warning: unable to determine borrower from item ($item->{'barcode'}). Cannot mark returned\n" } );
 238   }
 239   C4::Circulation::MarkIssueReturned( $borrowernumber,
 240                                       $item->{'itemnumber'},
 241                                       undef,
 242                                       $circ->{'date'} );
 243
 244   push( @output, { message => "Returned $item->{ 'title' } ( $item->{ 'barcode' } ) From borrower number $borrowernumber : $circ->{ 'datetime' }\n" } );
 245 }
 246
 247 sub kocMakePayment {
 248   my ( $circ ) = @_;
 249   my $borrower = GetMember( $circ->{ 'cardnumber' }, 'cardnumber' );
 250   recordpayment( $borrower->{'borrowernumber'}, $circ->{'amount'} );
 251   push( @output, { message => "accepted payment ($circ->{'amount'}) from cardnumber ($circ->{'cardnumber'}), borrower ($borrower->{'borrowernumber'})" } );
 252 }
 253
 254 =head3 _get_borrowernumber_from_barcode
 255
 256 pass in a barcode
 257 get back the borrowernumber of the patron who has it checked out.
 258 undef if that can't be found
 259
 260 =cut
 261
 262 sub _get_borrowernumber_from_barcode {
 263     my $barcode = shift;
 264
 265     return unless $barcode;
 266
 267     my $item = GetBiblioFromItemNumber( undef, $barcode );
 268     return unless $item->{'itemnumber'};
 269
 270     my $issue = C4::Circulation::GetItemIssue( $item->{'itemnumber'} );
 271     return unless $issue->{'borrowernumber'};
 272     return $issue->{'borrowernumber'};
 273
 274 }