Merge branch 'bug_7228' into 3.14-master
[koha.git] / offline_circ / process_koc.pl
blob75ff31950b125788870000beb4e747655286ac04
1 #!/usr/bin/perl
3 # 2008 Kyle Hall <kyle.m.hall@gmail.com>
5 # This file is part of Koha.
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.
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.
16 # You should have received a copy of the GNU General Public License along
17 # with Koha; if not, write to the Free Software Foundation, Inc.,
18 # 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
21 use strict;
22 use warnings;
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::Items;
33 use C4::Members;
34 use C4::Stats;
35 use C4::UploadedFile;
36 use C4::BackgroundJob;
38 use Date::Calc qw( Add_Delta_Days Date_to_Days );
40 use constant DEBUG => 0;
42 # this is the file version number that we're coded against.
43 my $FILE_VERSION = '1.0';
45 our $query = CGI->new;
47 my ($template, $loggedinuser, $cookie) = get_template_and_user({
48 template_name => "offline_circ/process_koc.tmpl",
49 query => $query,
50 type => "intranet",
51 authnotrequired => 0,
52 flagsrequired => { circulate => "circulate_remaining_permissions" },
53 });
56 my $fileID=$query->param('uploadedfileid');
57 my $runinbackground = $query->param('runinbackground');
58 my $completedJobID = $query->param('completedJobID');
59 my %cookies = parse CGI::Cookie($cookie);
60 my $sessionID = $cookies{'CGISESSID'}->value;
61 ## 'Local' globals.
62 our $dbh = C4::Context->dbh();
63 our @output = (); ## For storing messages to be displayed to the user
66 if ($completedJobID) {
67 my $job = C4::BackgroundJob->fetch($sessionID, $completedJobID);
68 my $results = $job->results();
69 $template->param(transactions_loaded => 1);
70 $template->param(messages => $results->{results});
71 } elsif ($fileID) {
72 my $uploaded_file = C4::UploadedFile->fetch($sessionID, $fileID);
73 my $fh = $uploaded_file->fh();
74 my @input_lines = <$fh>;
76 my $filename = $uploaded_file->name();
77 my $job = undef;
79 if ($runinbackground) {
80 my $job_size = scalar(@input_lines);
81 $job = C4::BackgroundJob->new($sessionID, $filename, $ENV{'SCRIPT_NAME'}, $job_size);
82 my $jobID = $job->id();
84 # fork off
85 if (my $pid = fork) {
86 # parent
87 # return job ID as JSON
89 # prevent parent exiting from
90 # destroying the kid's database handle
91 # FIXME: according to DBI doc, this may not work for Oracle
92 $dbh->{InactiveDestroy} = 1;
94 my $reply = CGI->new("");
95 print $reply->header(-type => 'text/html');
96 print '{"jobID":"' . $jobID . '"}';
97 exit 0;
98 } elsif (defined $pid) {
99 # child
100 # close STDOUT to signal to Apache that
101 # we're now running in the background
102 close STDOUT;
103 close STDERR;
104 } else {
105 # fork failed, so exit immediately
106 # fork failed, so exit immediately
107 warn "fork failed while attempting to run $ENV{'SCRIPT_NAME'} as a background job";
108 exit 0;
111 # if we get here, we're a child that has detached
112 # itself from Apache
116 my $header_line = shift @input_lines;
117 my $file_info = parse_header_line($header_line);
118 if ($file_info->{'Version'} ne $FILE_VERSION) {
119 push @output, {
120 message => 1,
121 ERROR_file_version => 1,
122 upload_version => $file_info->{'Version'},
123 current_version => $FILE_VERSION
127 my $i = 0;
128 foreach my $line (@input_lines) {
129 $i++;
130 my $command_line = parse_command_line($line);
132 # map command names in the file to subroutine names
133 my %dispatch_table = (
134 issue => \&kocIssueItem,
135 'return' => \&kocReturnItem,
136 payment => \&kocMakePayment,
139 # call the right sub name, passing the hashref of command_line to it.
140 if ( exists $dispatch_table{ $command_line->{'command'} } ) {
141 $dispatch_table{ $command_line->{'command'} }->($command_line);
142 } else {
143 warn "unknown command: '$command_line->{command}' not processed";
146 if ($runinbackground) {
147 $job->progress($i);
151 if ($runinbackground) {
152 $job->finish({ results => \@output }) if defined($job);
153 } else {
154 $template->param(transactions_loaded => 1);
155 $template->param(messages => \@output);
159 output_html_with_http_headers $query, $cookie, $template->output;
161 =head1 FUNCTIONS
163 =head2 parse_header_line
165 parses the header line from a .koc file. This is the line that
166 specifies things such as the file version, and the name and version of
167 the offline circulation tool that generated the file. See
168 L<http://wiki.koha-community.org/wiki/Koha_offline_circulation_file_format>
169 for more information.
171 pass in a string containing the header line (the first line from th
172 file).
174 returns a hashref containing the information from the header.
176 =cut
178 sub parse_header_line {
179 my $header_line = shift;
180 chomp($header_line);
181 $header_line =~ s/\r//g;
183 my @fields = split( /\t/, $header_line );
184 my %header_info = map { split( /=/, $_ ) } @fields;
185 return \%header_info;
188 =head2 parse_command_line
190 =cut
192 sub parse_command_line {
193 my $command_line = shift;
194 chomp($command_line);
195 $command_line =~ s/\r//g;
197 my ( $timestamp, $command, @args ) = split( /\t/, $command_line );
198 my ( $date, $time, $id ) = split( /\s/, $timestamp );
200 my %command = (
201 date => $date,
202 time => $time,
203 id => $id,
204 command => $command,
207 # set the rest of the keys using a hash slice
208 my $argument_names = arguments_for_command($command);
209 @command{@$argument_names} = @args;
211 return \%command;
215 =head2 arguments_for_command
217 fetches the names of the columns (and function arguments) found in the
218 .koc file for a particular command name. For instance, the C<issue>
219 command requires a C<cardnumber> and C<barcode>. In that case this
220 function returns a reference to the list C<qw( cardnumber barcode )>.
222 parameters: the command name
224 returns: listref of column names.
226 =cut
228 sub arguments_for_command {
229 my $command = shift;
231 # define the fields for this version of the file.
232 my %format = (
233 issue => [qw( cardnumber barcode )],
234 return => [qw( barcode )],
235 payment => [qw( cardnumber amount )],
238 return $format{$command};
241 sub kocIssueItem {
242 my $circ = shift;
244 $circ->{ 'barcode' } = barcodedecode($circ->{'barcode'}) if( $circ->{'barcode'} && C4::Context->preference('itemBarcodeInputFilter'));
245 my $branchcode = C4::Context->userenv->{branch};
246 my $borrower = GetMember( 'cardnumber'=>$circ->{ 'cardnumber' } );
247 my $item = GetBiblioFromItemNumber( undef, $circ->{ 'barcode' } );
248 my $issue = GetItemIssue( $item->{'itemnumber'} );
250 if ( $issue->{ 'date_due' } ) { ## Item is currently checked out to another person.
251 #warn "Item Currently Issued.";
252 my $issue = GetOpenIssue( $item->{'itemnumber'} );
254 if ( $issue->{'borrowernumber'} eq $borrower->{'borrowernumber'} ) { ## Issued to this person already, renew it.
255 #warn "Item issued to this member already, renewing.";
257 C4::Circulation::AddRenewal(
258 $issue->{'borrowernumber'}, # borrowernumber
259 $item->{'itemnumber'}, # itemnumber
260 undef, # branch
261 undef, # datedue - let AddRenewal calculate it automatically
262 $circ->{'date'}, # issuedate
263 ) unless ($DEBUG);
265 push @output, {
266 renew => 1,
267 title => $item->{ 'title' },
268 biblionumber => $item->{'biblionumber'},
269 barcode => $item->{ 'barcode' },
270 firstname => $borrower->{ 'firstname' },
271 surname => $borrower->{ 'surname' },
272 borrowernumber => $borrower->{'borrowernumber'},
273 cardnumber => $borrower->{'cardnumber'},
274 datetime => $circ->{ 'datetime' }
277 } else {
278 #warn "Item issued to a different member.";
279 #warn "Date of previous issue: $issue->{'issuedate'}";
280 #warn "Date of this issue: $circ->{'date'}";
281 my ( $i_y, $i_m, $i_d ) = split( /-/, $issue->{'issuedate'} );
282 my ( $c_y, $c_m, $c_d ) = split( /-/, $circ->{'date'} );
284 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.
285 C4::Circulation::AddIssue( $borrower, $circ->{'barcode'}, undef, undef, $circ->{'date'} ) unless ( DEBUG );
286 push @output, {
287 issue => 1,
288 title => $item->{ 'title' },
289 biblionumber => $item->{'biblionumber'},
290 barcode => $item->{ 'barcode' },
291 firstname => $borrower->{ 'firstname' },
292 surname => $borrower->{ 'surname' },
293 borrowernumber => $borrower->{'borrowernumber'},
294 cardnumber => $borrower->{'cardnumber'},
295 datetime => $circ->{ 'datetime' }
298 } 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.
299 #warn "Current issue to another member is newer. Doing nothing";
300 ## This situation should only happen of the Offline Circ data is *really* old.
301 ## FIXME: write line to old_issues and statistics
304 } else { ## Item is not checked out to anyone at the moment, go ahead and issue it
305 C4::Circulation::AddIssue( $borrower, $circ->{'barcode'}, undef, undef, $circ->{'date'} ) unless ( DEBUG );
306 push @output, {
307 issue => 1,
308 title => $item->{ 'title' },
309 biblionumber => $item->{'biblionumber'},
310 barcode => $item->{ 'barcode' },
311 firstname => $borrower->{ 'firstname' },
312 surname => $borrower->{ 'surname' },
313 borrowernumber => $borrower->{'borrowernumber'},
314 cardnumber => $borrower->{'cardnumber'},
315 datetime =>$circ->{ 'datetime' }
320 sub kocReturnItem {
321 my ( $circ ) = @_;
322 $circ->{'barcode'} = barcodedecode($circ->{'barcode'}) if( $circ->{'barcode'} && C4::Context->preference('itemBarcodeInputFilter'));
323 my $item = GetBiblioFromItemNumber( undef, $circ->{ 'barcode' } );
324 #warn( Data::Dumper->Dump( [ $circ, $item ], [ qw( circ item ) ] ) );
325 my $borrowernumber = _get_borrowernumber_from_barcode( $circ->{'barcode'} );
326 if ( $borrowernumber ) {
327 my $borrower = GetMember( 'borrowernumber' => $borrowernumber );
328 C4::Circulation::MarkIssueReturned(
329 $borrowernumber,
330 $item->{'itemnumber'},
331 undef,
332 $circ->{'date'},
333 $borrower->{'privacy'}
336 ModItem({ onloan => undef }, $item->{'biblionumber'}, $item->{'itemnumber'});
337 ModDateLastSeen( $item->{'itemnumber'} );
339 push @output, {
340 return => 1,
341 title => $item->{ 'title' },
342 biblionumber => $item->{'biblionumber'},
343 barcode => $item->{ 'barcode' },
344 borrowernumber => $borrower->{'borrowernumber'},
345 firstname => $borrower->{'firstname'},
346 surname => $borrower->{'surname'},
347 cardnumber => $borrower->{'cardnumber'},
348 datetime => $circ->{ 'datetime' }
350 } else {
351 push @output, {
352 ERROR_no_borrower_from_item => 1,
353 badbarcode => $circ->{'barcode'}
358 sub kocMakePayment {
359 my ( $circ ) = @_;
360 my $borrower = GetMember( 'cardnumber'=>$circ->{ 'cardnumber' } );
361 recordpayment( $borrower->{'borrowernumber'}, $circ->{'amount'} );
362 push @output, {
363 payment => 1,
364 amount => $circ->{'amount'},
365 firstname => $borrower->{'firstname'},
366 surname => $borrower->{'surname'},
367 cardnumber => $circ->{'cardnumber'},
368 borrower => $borrower->{'borrowernumber'}
372 =head2 _get_borrowernumber_from_barcode
374 pass in a barcode
375 get back the borrowernumber of the patron who has it checked out.
376 undef if that can't be found
378 =cut
380 sub _get_borrowernumber_from_barcode {
381 my $barcode = shift;
383 return unless $barcode;
385 my $item = GetBiblioFromItemNumber( undef, $barcode );
386 return unless $item->{'itemnumber'};
388 my $issue = C4::Circulation::GetItemIssue( $item->{'itemnumber'} );
389 return unless $issue->{'borrowernumber'};
390 return $issue->{'borrowernumber'};