Koha/C4/UploadedFiles.pm

package C4::UploadedFiles;

# This file is part of Koha.
#
# Copyright (C) 2011-2012 BibLibre
#
# Koha is free software; you can redistribute it and/or modify it
# under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 3 of the License, or
# (at your option) any later version.
#
# Koha is distributed in the hope that it will be useful, but
# WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with Koha; if not, see <http://www.gnu.org/licenses>.

=head1 NAME

C4::UploadedFiles - Functions to deal with files uploaded with cataloging plugin upload.pl

=head1 SYNOPSIS

    use C4::UploadedFiles;

    my $filename = $cgi->param('uploaded_file');
    my $file = $cgi->upload('uploaded_file');
    my $dir = $input->param('dir');

    # upload file
    my $id = C4::UploadedFiles::UploadFile($filename, $dir, $file->handle);

    # retrieve file infos
    my $uploaded_file = C4::UploadedFiles::GetUploadedFile($id);

    # delete file
    C4::UploadedFiles::DelUploadedFile($id);

=head1 DESCRIPTION

This module provides basic functions for adding, retrieving and deleting files related to
cataloging plugin upload.pl.

It uses uploaded_files table.

It is not related to C4::UploadedFile

=head1 FUNCTIONS

=cut

use Modern::Perl;
use Digest::SHA;
use Fcntl;
use Encode;

use C4::Context;
use C4::Koha;

sub _get_file_path {
    my ($hash, $dirname, $filename) = @_;

    my $upload_path = C4::Context->config('upload_path');
    if( !-d "$upload_path/$dirname" ) {
        mkdir "$upload_path/$dirname";
    }
    my $filepath = "$upload_path/$dirname/${hash}_$filename";
    $filepath =~ s|/+|/|g;

    return $filepath;
}

=head2 GetUploadedFile

    my $file = C4::UploadedFiles::GetUploadedFile($id);

Returns a hashref containing infos on uploaded files.
Hash keys are:

=over 2

=item * id: id of the file (same as given in argument)

=item * filename: name of the file

=item * dir: directory where file is stored (relative to config variable 'upload_path')

=back

It returns undef if file is not found

=cut

sub GetUploadedFile {
    my ( $hashvalue ) = @_;

    return unless $hashvalue;

    my $dbh = C4::Context->dbh;
    my $query = qq{
        SELECT hashvalue, filename, dir
        FROM uploaded_files
        WHERE hashvalue = ?
    };
    my $sth = $dbh->prepare($query);
    $sth->execute( $hashvalue );
    my $file = $sth->fetchrow_hashref;
    if ($file) {
        $file->{filepath} = _get_file_path($file->{hashvalue}, $file->{dir},
            $file->{filename});
    }

    return $file;
}

=head2 UploadFile

    my $id = C4::UploadedFiles::UploadFile($filename, $dir, $io_handle);

Upload a new file and returns its id (its SHA-1 sum, actually).

Parameters:

=over 2

=item * $filename: name of the file

=item * $dir: directory where to store the file (path relative to config variable 'upload_path'

=item * $io_handle: valid IO::Handle object, can be retrieved with
$cgi->upload('uploaded_file')->handle;

=back

=cut

sub UploadFile {
    my ($filename, $dir, $handle) = @_;
    $filename = decode_utf8($filename);
    if($filename =~ m#(^|/)\.\.(/|$)# or $dir =~ m#(^|/)\.\.(/|$)#) {
        warn "Filename or dirname contains '..'. Aborting upload";
        return;
    }

    my $buffer;
    my $data = '';
    while($handle->read($buffer, 1024)) {
        $data .= $buffer;
    }
    $handle->close;

    my $sha = new Digest::SHA;
    $sha->add($data);
    $sha->add($filename);
    $sha->add($dir);
    my $hash = $sha->hexdigest;

    # Test if this id already exist
    my $file = GetUploadedFile($hash);
    if ($file) {
        return $file->{hashvalue};
    }

    my $file_path = _get_file_path($hash, $dir, $filename);

    my $out_fh;
    # Create the file only if it doesn't exist
    unless( sysopen($out_fh, $file_path, O_WRONLY|O_CREAT|O_EXCL) ) {
        warn "Failed to open file '$file_path': $!";
        return;
    }

    print $out_fh $data;
    my $size= tell($out_fh);
    close $out_fh;

    my $dbh = C4::Context->dbh;
    my $query = qq{
        INSERT INTO uploaded_files (hashvalue, filename, filesize, dir, categorycode, owner) VALUES (?,?,?,?,?,?);
    };
    my $sth = $dbh->prepare($query);
    my $uid= C4::Context->userenv? C4::Context->userenv->{number}: undef;
        # uid is null in unit test
    if($sth->execute($hash, $filename, $size, $dir, $dir, $uid)) {
        return $hash;
    }

    return;
}

=head2 DanglingEntry

    C4::UploadedFiles::DanglingEntry($id,$isfileuploadurl);

Determine if a entry is dangling.

Returns: 2 == no db entry
         1 == no plain file
         0 == both a file and db entry.
        -1 == N/A (undef id / non-file-upload URL)

=cut

sub DanglingEntry {
    my ($id,$isfileuploadurl) = @_;
    my $retval;

    if (defined($id)) {
        my $file = GetUploadedFile($id);
        if($file) {
            my $file_path = $file->{filepath};
            my $file_deleted = 0;
            unless( -f $file_path ) {
                $retval = 1;
            } else {
                $retval = 0;
            }
        }
        else {
            if ( $isfileuploadurl ) {
                $retval = 2;
            }
            else {
                $retval = -1;
            }
        }
    }
    else {
        $retval = -1;
    }
    return $retval;
}

=head2 DelUploadedFile

    C4::UploadedFiles::DelUploadedFile( $hash );

Remove a previously uploaded file, given its hash value.

Returns: 1 == file deleted
         0 == file not deleted
         -1== no file to delete / no meaninful id passed

=cut

sub DelUploadedFile {
    my ( $hashval ) = @_;
    my $retval;

    if ( $hashval ) {
        my $file = GetUploadedFile( $hashval );
        if($file) {
            my $file_path = $file->{filepath};
            my $file_deleted = 0;
            unless( -f $file_path ) {
                warn "Id $file->{hashvalue} is in database but no plain file found, removing id from database";
                $file_deleted = 1;
            } else {
                if(unlink $file_path) {
                    $file_deleted = 1;
                }
            }

            unless($file_deleted) {
                warn "File $file_path cannot be deleted: $!";
            }

            my $dbh = C4::Context->dbh;
            my $query = qq{
                DELETE FROM uploaded_files
                WHERE hashvalue = ?
            };
            my $sth = $dbh->prepare($query);
            my $numrows = $sth->execute( $hashval );
            # if either a DB entry or file was deleted,
            # then clearly we have a deletion.
            if ($numrows>0 || $file_deleted==1) {
                $retval = 1;
            }
            else {
                $retval = 0;
            }
        }
        else {
            warn "There was no file for hash $hashval.";
            $retval = -1;
        }
    }
    else {
        warn "DelUploadFile called without hash value.";
        $retval = -1;
    }
    return $retval;
}

=head2 getCategories

    getCategories returns a list of upload category codes and names

=cut

sub getCategories {
    my $cats = C4::Koha::GetAuthorisedValues('UPLOAD');
    [ map {{ code => $_->{authorised_value}, name => $_->{lib} }} @$cats ];
}

=head2 httpheaders

    httpheaders returns http headers for a retrievable upload
    Will be extended by report 14282

=cut

sub httpheaders {
    my $file= shift;
    return
        ( '-type' => 'application/octet-stream',
          '-attachment' => $file, );
}

1;