1133 lines
41 KiB
Perl
1133 lines
41 KiB
Perl
# ==================================================================
|
|
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
|
#
|
|
# GT::SQL::File
|
|
# Author : Aki Mimoto
|
|
# CVS Info : 087,071,086,086,085
|
|
# $Id: File.pm,v 1.70 2012/01/25 23:12:18 brewt Exp $
|
|
#
|
|
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
|
# ==================================================================
|
|
#
|
|
|
|
package GT::SQL::File;
|
|
|
|
use strict;
|
|
use GT::SQL;
|
|
use GT::SQL::Base;
|
|
use GT::AutoLoader;
|
|
use GT::Base;
|
|
use vars qw/@ISA $ERRORS $ATTRIBS $LOG $ERROR_MESSAGE $PERMIT_REFS $DEBUG/;
|
|
@ISA = qw/GT::SQL::Base/;
|
|
$DEBUG = 0;
|
|
$ATTRIBS = {
|
|
db => undef,
|
|
connect => undef,
|
|
def_path => undef,
|
|
table_name => '',
|
|
table_object => undef,
|
|
parent_table => undef,
|
|
parent_table_name => undef,
|
|
file_save_in => '',
|
|
file_log_path => '',
|
|
file_name => '',
|
|
file_path => '',
|
|
file_fpath => '',
|
|
|
|
File_Name => '',
|
|
ID => '',
|
|
ForeignColName => '',
|
|
ForeignColKey => '',
|
|
File_Name => '',
|
|
File_Directory => '',
|
|
File_MimeType => '',
|
|
File_Size => '',
|
|
File_RelativePath => '',
|
|
File_Binary => undef,
|
|
File_URL => '',
|
|
File_RelativeURL => '',
|
|
|
|
file_handle => undef,
|
|
};
|
|
|
|
# this allows calls to the individual attribs through GT::SQL::File::Fh method
|
|
$PERMIT_REFS = { map { $_ => 1 } keys %$ATTRIBS };
|
|
$LOG = {
|
|
ADDED => q~Added file %s to %s~,
|
|
REPLACE => q~Replaced file %s to %s~,
|
|
REMOVED => q~Deleted file %s~,
|
|
CREATEDDIR => q~Created directory %s~
|
|
};
|
|
|
|
$ERROR_MESSAGE = 'GT::SQL';
|
|
$ERRORS = {
|
|
FILE_PARENTTBL => q~Cannot load parent table! (%s)~,
|
|
FILE_FILETBL => q~Cannot load file table! (%s)~,
|
|
FILE_NOGLOBREF => q~Need a file glob reference in (%s)~,
|
|
FILE_FILETOOBIG => q~File %s (%i bytes) exceeds maximum file size (%i bytes)~,
|
|
FILE_NOOPEN => q~Problems opening %s for writing: %s~,
|
|
FILE_NOBINMODE => q~Could not set %s to binmode: %s~,
|
|
FILE_NOCLOSE => q~Had problems closing file %s: %s~,
|
|
FILE_NOFILE => q~Could not find file related by ForeignColName => %s, ForeignColKey => %s: %s~,
|
|
FILE_FDELETE => q~Problems deleting file %s: %s~,
|
|
FILE_NOUNLINK => q~Could not unlink file %s: %s~,
|
|
FILE_PKREQ => q~Primary Key required~,
|
|
FILE_PKSINGLE => q~Composite Primary Keys not supported~,
|
|
FILE_DBDELETE => q~Problems deleting record: %s~,
|
|
FILE_DBDELETEALL => q~Problems deleting all records~,
|
|
FILE_DBSELECT => q~Problems selecting %s~,
|
|
FILE_NOREC => q~Could not find file record~,
|
|
FILE_DBDROP => q~Could not drop table %s: %s~,
|
|
FILE_DBEDITOR => q~Could not get editor object for table %s: %s~,
|
|
FILE_DBUPDATE => q~Problems updating record: %s~,
|
|
FILE_DBADD => q~Problems adding record: %s~,
|
|
FILE_ILLEGALCHAR => q~Illegal character found in %s~,
|
|
FILE_NOOPEN => q~Could not open %s because %s~,
|
|
FILE_NOWRITE => q~Could not write data into %s because %s~,
|
|
FILE_MKDIRFAIL => q~Couldn't create directory %s, because %s~,
|
|
FILE_UNKNOWNREF => q~Reference call '%s' does not refer to a method in GT::SQL::File or an allowed attribute.~,
|
|
FILE_NOTNULL => q~A file must be uploaded for the %s column~,
|
|
FILE_NULLDELETE => q~Cannot delete file, as a file is required for the %s column~,
|
|
FILE_NULLUPDATE => q~A file must be uploaded for the %s column~,
|
|
};
|
|
|
|
@$GT::SQL::ERRORS{keys %$ERRORS} = values %$ERRORS;
|
|
|
|
use constant ENCODE => 1;
|
|
|
|
$COMPILE{rescan} = __LINE__ . <<'END_OF_SUB';
|
|
sub rescan {
|
|
#-------------------------------------------------------------------------------
|
|
# $obj->rescan();
|
|
#----------
|
|
# Rebuilds the database and attempts to ensure that database records are
|
|
# correct. This does not update the parent tables
|
|
#
|
|
my ($self) = @_;
|
|
|
|
my %errs = ();
|
|
my %mods = ();
|
|
my $tbl = $self->_tbl() or return $self->error('FILE_FILETBL', 'WARN', $GT::SQL::error);
|
|
my $ptbl = $self->_parent_tbl() or return $self->error('FILE_PARENTTBL', 'WARN', $GT::SQL::error);
|
|
my %fcols = $ptbl->_file_cols();
|
|
my $sth = $tbl->select() or return $self->error('FILE_DBSELECT', 'WARN', $GT::SQL::error);
|
|
while (my $href = $sth->fetchrow_hashref()) {
|
|
my $fpath = $self->_file_full_path($href->{File_Name}, $href->{File_Directory}, $href->{ID}, $href->{ForeignColName}, $fcols{$href->{ForeignColName}}->{file_save_scheme}, ENCODE);
|
|
|
|
# does this file still exist?
|
|
if (! -e $fpath) {
|
|
$errs{$href->{ID}} = "NOFILE";
|
|
$self->error('FILE_NOFILE', 'WARN', $href->{ForeignColName}, $href->{ForeignColKey}, "FILENOEXIST");
|
|
$tbl->delete({ ForeignColName => $href->{ForeignColName}, ForeignColKey => "$href->{ForeignColKey}" });
|
|
}
|
|
|
|
# is it still the same file size?
|
|
elsif (-s _ != $href->{File_Size}) {
|
|
$mods{$href->{ID}} = "NEWSIZE";
|
|
$href->{File_Size} = -s _;
|
|
$tbl->modify($href) or $errs{$href->{ID}} = "CANTMODIFY";
|
|
}
|
|
}
|
|
|
|
return \%errs, \%mods;
|
|
}
|
|
END_OF_SUB
|
|
|
|
$COMPILE{log} = __LINE__ . <<'END_OF_SUB';
|
|
sub log {
|
|
#-------------------------------------------------------------------------------
|
|
# $obj->log( $code, LIST );
|
|
#----------
|
|
# puts a log message into the logs file if the path has been set
|
|
#
|
|
my $self = shift;
|
|
my $code = shift;
|
|
my $logpath = $self->{file_log_path} or return;
|
|
|
|
$self->_check_file_chars( $logpath ) or return $self->error( 'FILE_ILLEGALCHAR', 'WARN', $logpath );
|
|
CORE::open( LOG, ">>$logpath" );
|
|
print LOG sprintf($LOG->{$code}, @_);
|
|
close( LOG );
|
|
}
|
|
END_OF_SUB
|
|
|
|
$COMPILE{add_file} = __LINE__ . <<'END_OF_SUB';
|
|
sub add_file {
|
|
#-------------------------------------------------------------------------------
|
|
# $obj->addfile( $new_record, $new_record_id )
|
|
#----------
|
|
# puts a file away into the database
|
|
#
|
|
my ($self, $rec, $recid ) = @_;
|
|
return $self->replace_file( $rec, $recid );
|
|
}
|
|
END_OF_SUB
|
|
|
|
$COMPILE{replace_file} = __LINE__ . <<'END_OF_SUB';
|
|
sub replace_file {
|
|
# --------------------------------------------------------------------------------------
|
|
# $obj->replace_file( $new_record, $new_record_id )
|
|
#----------
|
|
# puts a file away into the database, if a file already exists in place, delete it
|
|
#
|
|
my ($self, $rec, $recid ) = @_;
|
|
my $ptable = $self->_parent_tbl() or return $self->error( 'FILE_PARENTTBL', 'WARN', $GT::SQL::error );
|
|
my $fcols = { $ptable->_file_cols() };
|
|
my $ftable = $self->_tbl() or return $self->error( 'FILE_FILETBL', 'WARN', $GT::SQL::error );
|
|
|
|
foreach my $col_name ( keys %$fcols ) {
|
|
|
|
# basic tests
|
|
my $col = $fcols->{$col_name};
|
|
my $ref = ref $rec->{$col_name};
|
|
my $fh = ( ( $ref and $ref !~ /SCALAR|ARRAY|HASH/ ) ? $rec->{$col_name} : $self->get_fh( $col_name, $rec ) ) or next;
|
|
$col->{file_max_size} and ( ( -s $fh ) <= $col->{file_max_size} or return $self->error( 'FILE_FILETOOBIG', 'WARN', "$fh", -s $fh, $col->{file_max_size} ) );
|
|
|
|
# now, delete the previous entry
|
|
if ( $ftable->count({ ForeignColName => $col_name, ForeignColKey => "$recid" }) ) {
|
|
ref $fh or $rec->{$col_name."_del"} and $self->delete_file( $col_name, $recid, $col->{file_save_scheme} );
|
|
}
|
|
|
|
# find out if we're simply going to skip the action here
|
|
not ref $fh and not $fh eq 'delete' and next;
|
|
|
|
# get basic information setup
|
|
my @paths = split m.(/|\\)., "$fh"; #/\
|
|
my $fname = $rec->{$col_name."_filename"} || pop @paths;
|
|
my $fdir = $col->{file_save_in};
|
|
|
|
# now that we have saved the information, add the record to the database
|
|
my $new_rec = $self->_file_getstats( $fname, $fdir, $col->{file_save_url}, -s $fh );
|
|
|
|
$new_rec->{ForeignColName} = $col_name;
|
|
$new_rec->{ForeignColKey} = $recid;
|
|
my $fid = $ftable->add($new_rec) or return $self->error( 'FILE_DBADD', 'WARN', $GT::SQL::error );
|
|
|
|
# now try to save
|
|
my $fpath = $self->_file_full_path( $fname, $fdir, $fid, $col_name, $col->{file_save_scheme}, ENCODE );
|
|
|
|
$self->_check_file_chars($fpath) or return $self->error( 'FILE_ILLEGALCHAR', 'WARN', $fpath );
|
|
CORE::open( F, ">$fpath" ) or return $self->error( 'FILE_NOOPEN', 'WARN', $fpath, "$!" );
|
|
binmode(F) or return $self->error( 'FILE_NOBINMODE', 'WARN', 'output file', "$!" );
|
|
binmode $fh or return $self->error( 'FILE_NOBINMODE', 'WARN', 'input file', "$!" );
|
|
while (read($fh, my $buf, 512 * 1024)) {
|
|
print F $buf or return $self->error( 'FILE_NOWRITE', 'WARN', $fpath, "$!" );
|
|
}
|
|
close F or return $self->error( 'FILE_NOCLOSE', 'WARN', $fpath, "$!" );
|
|
|
|
$self->log( 'ADDED', $fname, $fdir );
|
|
|
|
}
|
|
|
|
return 1;
|
|
}
|
|
END_OF_SUB
|
|
|
|
$COMPILE{delete_file} = __LINE__ . <<'END_OF_SUB';
|
|
sub delete_file {
|
|
# --------------------------------------------------------------------------------------
|
|
# $obj->delete_file( $col_name, $recid, $save_scheme );
|
|
#----------
|
|
# deletes the files and records associated
|
|
# function that is usually used internally
|
|
#
|
|
my ( $self, $col_name, $recid, $save_scheme ) = @_;
|
|
|
|
# get the path to the file
|
|
my $tbl = $self->_tbl();
|
|
my $rec = $tbl->get({ ForeignColName => $col_name, ForeignColKey => "$recid" }) or return $self->error( 'FILE_NOFILE', 'WARN', $col_name, $recid, $GT::SQL::error );
|
|
my $fpath = $self->_file_full_path(
|
|
$rec->{File_Name},
|
|
$rec->{File_Directory},
|
|
$rec->{ID},
|
|
$col_name,
|
|
$save_scheme,
|
|
ENCODE
|
|
);
|
|
|
|
# nuke the database record
|
|
$tbl->delete({ ForeignColName => $col_name, ForeignColKey => "$recid" }) or return $self->error( 'FILE_FDELETE', 'WARN', $rec->{File_Name}, $GT::SQL::error);
|
|
|
|
# nuke the file
|
|
unlink $fpath or return $self->error( 'FILE_NOUNLINK', 'WARN', $fpath, "$!" );
|
|
|
|
$self->log( 'REMOVED', $rec->{File_Name} );
|
|
|
|
return 1;
|
|
}
|
|
END_OF_SUB
|
|
|
|
$COMPILE{delete_records} = __LINE__ . <<'END_OF_SUB';
|
|
sub delete_records {
|
|
# --------------------------------------------------------------------------------------
|
|
# $obj->delete_records( $condition )
|
|
#----------
|
|
# deletes all records addressed by the condition.
|
|
# usually used in conjunction with a delete of the parent table elements.
|
|
# BUT must be called before parent table is deleted
|
|
#
|
|
my ($self, $where) = @_;
|
|
my $ptbl = $self->_parent_tbl() or return $self->error('FILE_PARENTTBL', 'WARN', $GT::SQL::error);
|
|
my @pk = $ptbl->pk() or return $self->error('FILE_PKREQ', 'WARN');
|
|
@pk == 1 or return $self->error('FILE_PKSINGLE', 'WARN');
|
|
my $pk = $pk[0];
|
|
my %fcols = $ptbl->_file_cols();
|
|
my $sth = $ptbl->select([$pk], $where);
|
|
my $tbl = $self->_tbl() or return $self->error('FILE_FILETBL', 'WARN', $GT::SQL::error);
|
|
|
|
while (my $raref = $sth->fetchrow_arrayref()) {
|
|
my $col_key = $raref->[0];
|
|
my $fsth = $tbl->select([qw(ID ForeignColName File_Directory File_Name)], { ForeignColKey => "$col_key" });
|
|
|
|
while ( my $aref = $fsth->fetchrow_arrayref() ) {
|
|
my $fpath = $self->_file_full_path(map({$aref->[$_]} qw(3 2 0 1)), $fcols{$aref->[1]}->{file_save_scheme}, ENCODE) or next;
|
|
unlink $fpath or $self->error('FILE_NOUNLINK', 'WARN', $fpath, "$!"), next;
|
|
$self->log('REMOVED', $aref->[3]);
|
|
}
|
|
|
|
$tbl->delete({ ForeignColKey => "$col_key" }) or $self->error('FILE_DBDELETE', 'WARN', $GT::SQL::error);
|
|
}
|
|
}
|
|
END_OF_SUB
|
|
|
|
$COMPILE{update_records} = __LINE__ . <<'END_OF_SUB';
|
|
sub update_records {
|
|
# --------------------------------------------------------------------------------------
|
|
# $obj->update_records( $set, $condition );
|
|
#----------
|
|
# treated like $tbl->modify. will update all records with new files if required.
|
|
# if multiple records are to receive copies of the file, multiple copies of the files
|
|
# will be created on disk
|
|
#
|
|
my $self = shift;
|
|
my $set = shift or return $self->error ('BADARGS', 'FATAL', "First argument to update_records must be \$set of what was set.");
|
|
my $cond = shift or return $self->error ('BADARGS', 'FATAL', "Condition object must be passed as second argument.");
|
|
|
|
# init variables
|
|
my $ptbl = $self->_parent_tbl();
|
|
my @pk = $ptbl->pk() or return $self->error( 'FILE_PKREQ', 'WARN' );
|
|
@pk == 1 or return $self->error( 'FILE_PKSINGLE', 'WARN' );
|
|
my %fcols = $ptbl->_file_cols() or return $self->error ('BADARGS', 'FATAL', "update_records was called when there are no file columns, possibly corrupt def file.");
|
|
my %flocs = ();
|
|
|
|
# find out which columns need to be updated
|
|
my @rcols = grep( defined ( $set->{$_} || $set->{$_."_del"} ), keys %fcols ) or return 1; # Nothing to do.
|
|
my $tbl = $self->_tbl();
|
|
|
|
# find out what records need to be updated
|
|
my $sth = $ptbl->select( [ $pk[0] ], $cond );
|
|
while ( my $aref = $sth->fetchrow_arrayref() ) {
|
|
my $col_key = $aref->[0];
|
|
|
|
# now for each of the record's columns do what has to be done... delete, update, nothing?
|
|
foreach my $col ( @rcols ) {
|
|
|
|
my $tmp = $flocs{$col} ||= {};
|
|
my $fh = $tmp->{name} ? do { CORE::open SOURCE, "<$tmp->{path}"; \*SOURCE } : $self->get_fh( $col, $set );
|
|
|
|
( not ref $fh and not $set->{$col."_del"} ) and ( $self->error( 'FILE_NOGLOBREF', 'WARN', $col ), next );
|
|
|
|
|
|
my $fname = $tmp->{name} ||= ( $set->{$col."_filename"} || $self->get_filename( "$fh" ) );
|
|
my $fdir = $tmp->{dir} ||= $fcols{$col}->{file_save_in};
|
|
|
|
my $rec;
|
|
if ( not $rec = $tbl->get({ ForeignColName => $col, ForeignColKey => "$col_key" }) ) {
|
|
$rec = $self->_file_getstats( $fname, $fdir, $fcols{$col}->{file_save_url}, ( -s $fh ) );
|
|
$rec->{ForeignColKey} = $col_key;
|
|
$rec->{ForeignColName} = $col;
|
|
$rec->{ID} = $tbl->add( $rec ) or $self->error( 'FILE_DBADD', 'WARN', $GT::SQL::error ),next;
|
|
}
|
|
else {
|
|
|
|
my $fpath = $self->_file_full_path(
|
|
$rec->{File_Name},
|
|
$rec->{File_Directory},
|
|
$rec->{ID},
|
|
$col,
|
|
$fcols{$col}->{file_save_scheme},
|
|
ENCODE
|
|
);
|
|
|
|
unlink $fpath or $self->error( 'FILE_NOUNLINK', 'WARN', $fpath, "$!" );
|
|
|
|
if ( ref $fh ) {
|
|
my $trec = $self->_file_getstats( $fname, $fdir, $fcols{$col}->{file_save_url}, ( -s $fh ) );
|
|
for ( keys %$trec ) { $rec->{$_} = $trec->{$_} };
|
|
$tbl->modify($rec) or ( $self->error( 'FILE_DBUPDATE', 'WARN', $GT::SQL::error ),next );
|
|
}
|
|
elsif ( $set->{$col."_del"} ) {
|
|
$tbl->delete({ ForeignColName => $col, ForeignColKey => "$col_key" }) or $self->error( 'FILE_DBDELETE', 'WARN', $GT::SQL::error );
|
|
next;
|
|
};
|
|
|
|
}
|
|
|
|
my $fpath = $tmp->{path} ||= $self->_file_full_path(
|
|
( $rec->{File_Name} = $tmp->{name} ),
|
|
$fdir,
|
|
$rec->{ID},
|
|
$col,
|
|
$fcols{$col}->{file_save_scheme},
|
|
ENCODE
|
|
);
|
|
|
|
$self->_check_file_chars($fpath) or return $self->error( 'FILE_ILLEGALCHAR', 'WARN', $fpath );
|
|
CORE::open( F, ">$fpath" ) or return $self->error( 'FILE_NOOPEN', 'WARN', $fpath, "$!" );
|
|
binmode $fh or return $self->error( 'FILE_NOBINMODE', 'WARN', 'input file', "$!" );
|
|
binmode(F) or return $self->error( 'FILE_NOBINMODE', 'WARN', 'output file', "$!" );
|
|
while (read($fh, my $buf, 512 * 1024)) {
|
|
print F $buf or return $self->error( 'FILE_NOWRITE', 'WARN', $fpath, "$!" );
|
|
}
|
|
close F or return $self->error( 'FILE_NOCLOSE', 'WARN', $fpath, "$!" );
|
|
close $fh;
|
|
|
|
$self->log( 'ADDED', $rec->{File_Name}, $fdir );
|
|
}
|
|
}
|
|
|
|
return 1;
|
|
}
|
|
END_OF_SUB
|
|
|
|
$COMPILE{_delete_record} = __LINE__ . <<'END_OF_SUB';
|
|
sub _delete_record {
|
|
# --------------------------------------------------------------------------------------
|
|
# $obj->_delete_record( $columnname, $columnkey, $save_scheme );
|
|
#----------
|
|
# takes the parameters that identify a record in the _File uniquely and deletes
|
|
# record and file
|
|
#
|
|
my $self = shift;
|
|
my $col_name = shift or return;
|
|
my $col_key = shift or return;
|
|
my $save_scheme = shift or return;;
|
|
|
|
my $tbl = $self->_tbl() or return $self->error( 'FILE_FILETBL', 'WARN', $GT::SQL::error );
|
|
|
|
# get the column information
|
|
my $href = $tbl->get({
|
|
ForeignColName => $col_name,
|
|
ForeignColKey => "$col_key",
|
|
}) or return $self->error( 'FILE_NOREC', 'WARN', $GT::SQL::error );
|
|
|
|
my $ptbl = $self->_parent_tbl() or return $self->error( 'FILE_PARENTTBL', 'WARN', $GT::SQL::error );
|
|
my %fcols = $ptbl->_file_cols() or return;
|
|
|
|
# get the filename of the record
|
|
my $fname = $self->_file_full_path( $href->{File_Name}, $href->{File_Directory}, $col_key, $col_name, $save_scheme, ENCODE);
|
|
|
|
# delete the file now that we have the file path
|
|
unlink $fname or return $self->error( 'FILE_NOUNLINK', 'WARN', $fname, "$!" );
|
|
|
|
# nuke the record
|
|
$tbl->delete({
|
|
ForeignColName => $col_name,
|
|
ForeignColKey => "$col_key",
|
|
}) or return $self->error( 'FILE_DBDELETE', 'WARN', $GT::SQL::error );
|
|
|
|
return 1;
|
|
}
|
|
END_OF_SUB
|
|
|
|
$COMPILE{delete_all} = __LINE__ . <<'END_OF_SUB';
|
|
sub delete_all {
|
|
# --------------------------------------------------------------------------------------
|
|
# $obj->delete_call( $col_name )
|
|
#----------
|
|
# takes the name of a file column from the parent and deletes all files and records
|
|
# associated
|
|
#
|
|
my $self = shift;
|
|
my $name = shift;
|
|
|
|
my $tbl = $self->_tbl() or return $self->error( 'FILE_FILETBL', 'WARN', $GT::SQL::error );
|
|
my $ptbl = $self->_parent_tbl() or return $self->error( 'FILE_PARENTTBL', 'WARN', $GT::SQL::error );
|
|
my %fcols = $ptbl->_file_cols();
|
|
|
|
my $sth = $tbl->select() or return $self->error( 'FILE_DBSELECT', 'WARN', $GT::SQL::error );
|
|
|
|
while ( my $href = $sth->fetchrow_hashref() ) {
|
|
my $fpath = $self->_file_full_path( $href->{File_Name}, $href->{File_Directory}, $href->{ID}, $href->{ForeignColName}, $fcols{$href->{ForeignColName}}->{file_save_scheme}, ENCODE);
|
|
unlink $fpath or return $self->error( 'FILE_NOUNLINK', 'WARN', $fpath, "$!" );
|
|
}
|
|
|
|
$tbl->delete_all() or return $self->error( 'FILE_DBDELETEALL', 'WARN', $GT::SQL::error );
|
|
|
|
return 1;
|
|
}
|
|
END_OF_SUB
|
|
|
|
$COMPILE{drop_col} = __LINE__ . <<'END_OF_SUB';
|
|
sub drop_col {
|
|
# --------------------------------------------------------------------------------------
|
|
# $obj->drop_col( $name )
|
|
# -----
|
|
# $name : name of column to drop
|
|
# -----
|
|
# Will remove all files associated to that particular column. If there are no more
|
|
# file columns, as it is no longer required, drop the file table .
|
|
#
|
|
my $self = shift;
|
|
my $name = shift;
|
|
|
|
my $tbl = $self->_tbl() or return 1;
|
|
my $ptbl = $self->_parent_tbl();
|
|
my %fcols = $ptbl->_file_cols();
|
|
my $save_scheme = shift || $fcols{$name}->{file_save_scheme};
|
|
my $sth = $tbl->select({ ForeignColName => $name }) or return $self->error( 'FILE_DBSELECT', 'WARN', $GT::SQL::error );
|
|
|
|
while ( my $href = $sth->fetchrow_hashref() ) {
|
|
my $fpath = $self->_file_full_path( $href->{File_Name}, $href->{File_Directory}, $href->{ID}, $name, $save_scheme, ENCODE);
|
|
unlink $fpath or $self->error( 'FILE_NOUNLINK', 'WARN', $fpath, "$!" );
|
|
}
|
|
|
|
$tbl->delete({ ForeignColName => $name }) or return $self->error( 'FILE_DBDELETE', 'WARN', $GT::SQL::error );
|
|
|
|
delete $fcols{$name};
|
|
|
|
# if there are no file based columns left, we can drop the file support table
|
|
require GT::SQL::Editor;
|
|
if ( not %fcols ) {
|
|
my $e = GT::SQL::Editor->new( debug => $self->{_debug}, table => $tbl, connect => $self->{connect}) or return $self->error( 'FILE_DBEDITOR', 'WARN', $tbl->name(), $GT::SQL::error );
|
|
$e->drop_table('remove') or return $self->error( 'FILE_DBDROP', 'WARN', $tbl->name(), $GT::SQL::error );
|
|
}
|
|
|
|
return 1;
|
|
}
|
|
END_OF_SUB
|
|
|
|
$COMPILE{drop_table} = __LINE__ . <<'END_OF_SUB';
|
|
sub drop_table {
|
|
# --------------------------------------------------------------------------------------
|
|
# $obj->drop_table();
|
|
#----------
|
|
# deletes all files in the table and drops the table (including records)
|
|
#
|
|
my $self = shift;
|
|
|
|
my $tbl = $self->_tbl() or return $self->error( 'FILE_FILETBL', 'WARN', $GT::SQL::error );
|
|
my %fcols = $self->_parent_tbl()->_file_cols() or return;
|
|
my $sth = $tbl->select() or return $self->error( 'FILE_DBSELECT', 'WARN', $GT::SQL::error );
|
|
|
|
while ( my $href = $sth->fetchrow_hashref() ) {
|
|
my $save_scheme = $fcols{$href->{ForeignColName}}->{file_save_scheme};
|
|
my $fpath = $self->_file_full_path( $href->{File_Name}, $href->{File_Directory}, $href->{ID}, $href->{ForeignColName}, $save_scheme, ENCODE);
|
|
unlink $fpath or return $self->error( 'FILE_NOUNLINK', 'WARN', $fpath, "$!" );
|
|
}
|
|
|
|
require GT::SQL::Editor;
|
|
my $e = GT::SQL::Editor->new( debug => $self->{_debug}, table => $tbl, connect => $self->{connect}) or return $self->error( 'FILE_DBEDITOR', 'WARN', $tbl->name(), $GT::SQL::error );
|
|
$e->drop_table() or return $self->error( 'FILE_DBDROP', 'WARN', $tbl->name(), $GT::SQL::error );
|
|
|
|
return 1;
|
|
}
|
|
END_OF_SUB
|
|
|
|
$COMPILE{open} = __LINE__ . <<'END_OF_SUB';
|
|
sub open {
|
|
# --------------------------------------------------------------------------------------
|
|
# $obj->open( $path_to_file );
|
|
#----------
|
|
# creates a GT::SQL::File::Fh Filehandle object
|
|
#
|
|
my $self = shift;
|
|
return GT::SQL::File::Fh->new(@_);
|
|
}
|
|
END_OF_SUB
|
|
|
|
$COMPILE{file_info} = __LINE__ . <<'END_OF_SUB';
|
|
sub file_info {
|
|
# --------------------------------------------------------------------------------------
|
|
# $obj->file_info( $columnname, $primarykeyvalue );
|
|
#----------
|
|
# returns a filehandle to file stored in database. if there is none, returns
|
|
# undef with an error set in $GT::SQL::error
|
|
#
|
|
my $self = shift;
|
|
my $name = shift or return;
|
|
my $key = shift or return;
|
|
|
|
my $tbl = $self->_tbl() or return $self->error( 'FILE_PARENTTBL', 'WARN', $GT::SQL::error );
|
|
my $ptable = $self->_parent_tbl() or return $self->error( 'FILE_FILETBL', 'WARN', $GT::SQL::error );
|
|
my %fcols = $ptable->_file_cols();
|
|
my $file_rec = $tbl->get({ ForeignColName => $name , ForeignColKey => $key }) or return $self->error( 'FILE_NOFILE', 'WARN', $name, $key, $GT::SQL::error );
|
|
|
|
my $relpath = $self->_file_full_path(
|
|
$file_rec->{File_Name},
|
|
'',
|
|
$file_rec->{ID},
|
|
$name,
|
|
$fcols{$name}->{file_save_scheme},
|
|
ENCODE
|
|
);
|
|
my $fpath = $file_rec->{File_Directory} . $relpath;
|
|
$file_rec->{File_RelativePath} = $relpath;
|
|
|
|
# Files written to disk are escaped. They need to be escaped again for URLs.
|
|
require GT::CGI;
|
|
(my $relurl = $relpath) =~ s{([\\/])([^\\/]+)$}{$1 . GT::CGI->escape($2)}e;
|
|
$file_rec->{File_RelativeURL} = $relurl;
|
|
$file_rec->{File_URL} = $file_rec->{File_URL} . $relurl;
|
|
|
|
return GT::SQL::File::Fh->new( $fpath, $file_rec );
|
|
}
|
|
END_OF_SUB
|
|
|
|
$COMPILE{_file_full_path} = __LINE__ . <<'END_OF_SUB';
|
|
sub _file_full_path {
|
|
# --------------------------------------------------------------------------------------
|
|
# GT::SQL::File->_file_full_path( $fname, $fdir, $fid, $fcol, $save_scheme, $enc )
|
|
#----------
|
|
# $fname : filename
|
|
# $fdir : directory of file
|
|
# $fid : id of the parent record
|
|
# $save_scheme : hashed or simple
|
|
# $enc : if we should encode the filepath or try to decode it
|
|
#----------
|
|
# returns the full path to the storeage location and name of the file the record
|
|
# points at
|
|
# the filename is typically encoded for the sake of special characters
|
|
#
|
|
my ( $self, $fname, $fdir, $fid, $fcol, $save_scheme, $enc ) = @_;
|
|
|
|
$save_scheme ||= 'HASHED';
|
|
|
|
# build paths to which we'll save all the information
|
|
$fdir = $self->_filepath_munge( $fdir, $fid, $save_scheme );
|
|
$fname = $self->_filename_munge( $fname, $fid, $fcol, $save_scheme, $enc );
|
|
my $fpath = "$fdir/$fname";
|
|
|
|
return $fpath;
|
|
}
|
|
END_OF_SUB
|
|
|
|
$COMPILE{_file_getstats} = __LINE__ . <<'END_OF_SUB';
|
|
sub _file_getstats {
|
|
# --------------------------------------------------------------------------------------
|
|
# GT::SQL::File->_file_getstats( $fname, $fpath, $fsize );
|
|
#----------
|
|
# starts to build a record to be used for inserts/modifies into
|
|
# the _File database table
|
|
#
|
|
my ( $self, $fname, $fpath, $furl, $fsize ) = @_;
|
|
require GT::MIMETypes;
|
|
my $rec = {
|
|
File_Name => $fname || '',
|
|
File_Directory => $fpath || '',
|
|
File_MimeType => GT::MIMETypes->guess_type($fname),
|
|
File_Size => defined $fsize ? $fsize : '',
|
|
File_URL => $furl || ''
|
|
};
|
|
|
|
return $rec;
|
|
}
|
|
END_OF_SUB
|
|
|
|
$COMPILE{_filename_munge} = __LINE__ . <<'END_OF_SUB';
|
|
sub _filename_munge {
|
|
# --------------------------------------------------------------------------------------
|
|
# GT::SQL::File->_filename_munge( $fname, $fid, $fcol, $method, $enc )
|
|
#----------
|
|
# should only be called internally. changes the filename so it can be saved without
|
|
# name conflicts
|
|
#
|
|
my ( $self, $fname, $fid, $fcol, $method, $enc ) = @_;
|
|
|
|
if ($enc) {
|
|
$fname =~ s/([^\w.,-])/sprintf("%%%02X",ord($1))/ge;
|
|
}
|
|
else {
|
|
$fname =~ s/%([0-9a-fA-F]{2})/chr(hex($1))/ge;
|
|
}
|
|
|
|
# Most filesystems have a maximum filename length of 255 characters
|
|
if (length $fname > 255) {
|
|
# Keep the filename extension
|
|
my ($ext) = $fname =~ /(\.\w+)$/;
|
|
$ext ||= '';
|
|
require GT::MD5;
|
|
$fname = GT::MD5::md5_hex($fname) . $ext;
|
|
}
|
|
|
|
return "$fid-$fname";
|
|
}
|
|
END_OF_SUB
|
|
|
|
$COMPILE{_filepath_munge} = __LINE__ . <<'END_OF_SUB';
|
|
sub _filepath_munge {
|
|
# --------------------------------------------------------------------------------------
|
|
# GT::SQL::File->_filepath_munge();
|
|
#----------
|
|
# sets up the path directory where the file should be saved.
|
|
#
|
|
my ( $self, $fpath, $fid, $method ) = @_;
|
|
|
|
if ( $method =~ /hashed/i ) {
|
|
my $fletter = ( reverse split //, $fid )[0];
|
|
my $nfpath = "$fpath/$fletter";
|
|
if ( $fpath ) {
|
|
-e $nfpath or mkdir $nfpath, 0777 or return warn "Couldn't make directory $nfpath because $!";
|
|
}
|
|
$fpath = $nfpath;
|
|
}
|
|
|
|
return $fpath;
|
|
}
|
|
END_OF_SUB
|
|
|
|
$COMPILE{_check_file_chars} = __LINE__ . <<'END_OF_SUB';
|
|
sub _check_file_chars {
|
|
#-------------------------------------------------------------------------------
|
|
# $obj->_check_file_chars( $fpath );
|
|
#----------
|
|
# return true if file path is ok
|
|
#
|
|
return $_[1] =~ /^[\w\/\\\-\.\:%]+$/;
|
|
}
|
|
END_OF_SUB
|
|
|
|
$COMPILE{install} = __LINE__ . <<'END_OF_SUB';
|
|
sub install {
|
|
#-------------------------------------------------------------------------------
|
|
# $obj->install( $options );
|
|
#----------
|
|
# creates the associate file parameter storage table
|
|
# $tops is passed into the creation option database
|
|
#
|
|
my ( $self, $opts ) = @_;
|
|
|
|
# get the name of the table
|
|
my $ptbl_name = $opts->{parent_tablename} || $self->{parent_tablename};
|
|
my $tb_name = $ptbl_name . '_Files';
|
|
|
|
# create the table
|
|
my $c = $self->creator( $tb_name );
|
|
$c->cols({
|
|
ID => { pos => 1, type => 'INT', not_null => 1, unsigned => 1, regex => '^\d+$' },
|
|
ForeignColName => { pos => 2, type => 'VARCHAR', size => 50 },
|
|
ForeignColKey => { pos => 3, type => 'VARCHAR', size => 50 },
|
|
File_Name => { pos => 4, type => 'VARCHAR', size => 255 },
|
|
File_Directory => { pos => 5, type => 'VARCHAR', size => 255 },
|
|
File_MimeType => { pos => 6, type => 'VARCHAR', size => 50 },
|
|
File_Size => { pos => 7, type => 'INT', not_null => 1, unsigned => 1, regex => '^\d+$' },
|
|
File_URL => { pos => 8, type => 'VARCHAR', size => 255 },
|
|
|
|
# under consideration....
|
|
# File_Width => { pos => 8, type => 'INT', unsigned => 1, regex => '^\d+$' },
|
|
# File_Height => { pos => 9, type => 'INT', unsigned => 1, regex => '^\d+$' },
|
|
|
|
});
|
|
$c->pk('ID');
|
|
$c->ai('ID');
|
|
$c->index({ fk_lookup => [ 'ForeignColName', 'ForeignColKey' ] });
|
|
$c->create( $opts->{action} || 'force' ) or return;
|
|
|
|
return 1;
|
|
|
|
}
|
|
END_OF_SUB
|
|
|
|
$COMPILE{_tbl} = __LINE__ . <<'END_OF_SUB';
|
|
sub _tbl {
|
|
#-------------------------------------------------------------------------------
|
|
# $obj->_tbl( $options )
|
|
#----------
|
|
# returns GT::SQL::Table for _File table
|
|
#
|
|
my ( $self, $opts ) = @_;
|
|
|
|
$self->{table_object} and return $self->{table_object};
|
|
|
|
my $tbl = eval {
|
|
$self->new_table( $opts->{table} || (
|
|
(
|
|
$opts->{parent_tablename}
|
|
|| $self->{parent_tablename}
|
|
|| ( ref $self->{parent_table} ?
|
|
do {
|
|
my $prefix = $self->{connect}->{PREFIX};
|
|
my $name = $self->{parent_table}->name();
|
|
$name =~ s,^$prefix,,;
|
|
$name;
|
|
}
|
|
:
|
|
''
|
|
) ) . '_Files'
|
|
) );
|
|
};
|
|
|
|
return $self->{table_object} = $tbl;
|
|
}
|
|
END_OF_SUB
|
|
|
|
$COMPILE{_parent_tbl} = __LINE__ . <<'END_OF_SUB';
|
|
sub _parent_tbl {
|
|
# -------------------------------------------------------------
|
|
# $obj->_parent_tbl( $options );
|
|
#----------
|
|
# return the Table object for the parent table
|
|
#
|
|
my ( $self, $opts ) = @_;
|
|
$self->{parent_table} and return $self->{parent_table};
|
|
return $self->_tbl( $self->{parent_table_name} || return );
|
|
}
|
|
END_OF_SUB
|
|
|
|
$COMPILE{File_Binary} = __LINE__ . <<'END_OF_SUB';
|
|
sub File_Binary {
|
|
# -------------------------------------------------------------------
|
|
# just returns true if the file is of binary type
|
|
#
|
|
my $self = shift;
|
|
defined $self->{File_Binary} and return $self->{File_Binary};
|
|
$self->{file_fpath} and return $self->{File_Binary} = -B $self->{file_fpath};
|
|
$self->{file_handle} and return $self->{File_Binary} = -B $self->{file_handle};
|
|
}
|
|
END_OF_SUB
|
|
|
|
$COMPILE{compare} = __LINE__ . <<'END_OF_SUB';
|
|
sub compare {
|
|
# -------------------------------------------------------------------
|
|
# Do comparisions, uses as_string to get file name first.
|
|
#
|
|
my $self = shift;
|
|
my $value = shift;
|
|
return "$self" cmp $value;
|
|
}
|
|
END_OF_SUB
|
|
|
|
$COMPILE{get_filename} = __LINE__ . <<'END_OF_SUB';
|
|
sub get_filename {
|
|
# -------------------------------------------------------------------
|
|
my ($self, $fpath) = @_;
|
|
return +($fpath =~ /([^\\\/]+)$/)[0];
|
|
}
|
|
END_OF_SUB
|
|
|
|
$COMPILE{get_fh} = __LINE__ . <<'END_OF_SUB';
|
|
sub get_fh {
|
|
# -------------------------------------------------------------------
|
|
my ($self, $col, $values) = @_;
|
|
$values ||= {};
|
|
|
|
ref $values->{$col} and ref $values->{$col} ne 'SCALAR' and return $values->{$col};
|
|
ref $values->{$col} eq 'SCALAR' and -f ${$values->{$col}} and -r _ and return GT::SQL::File->open(${$values->{$col}});
|
|
return;
|
|
}
|
|
END_OF_SUB
|
|
|
|
$COMPILE{pre_file_actions} = __LINE__ . <<'END_OF_SUB';
|
|
sub pre_file_actions {
|
|
# -------------------------------------------------------------------
|
|
# GT::SQL::File->pre_file_actions();
|
|
#----------
|
|
# Called before GT::SQL::Table::insert or GT::SQL::Table::update to setup all
|
|
# the columns and run tests to ensure the file is appropriate. Note that the
|
|
# $set hash will be modified (file columns are removed and/or modified and are
|
|
# returned).
|
|
#
|
|
# The $modify_ids (a single id or array ref of ids) argument is required for
|
|
# update()'s to verify that updates aren't made on rows that have file columns
|
|
# with not_null set and are currently empty. In addition to passing in to
|
|
# passing $modify_ids in, the GT::SQL::File object should also have the
|
|
# parent_table and connect options configured. For example,
|
|
#
|
|
# my $file = GT::SQL::File->new({
|
|
# parent_table => $DB->table('Links'),
|
|
# connect => $DB->{connect}
|
|
# });
|
|
#
|
|
# If $modify_ids is not passed in, then it is assumed the query will be an
|
|
# insert and all file columns with not_null set will be required.
|
|
#
|
|
my ($self, $fcols, $set, $opts, $modify_ids) = @_;
|
|
|
|
$modify_ids = [$modify_ids] if ref $modify_ids ne 'ARRAY' and $modify_ids;
|
|
|
|
my %fset;
|
|
for my $col (keys %$fcols) {
|
|
# insert() passes in through $opts, while modify passes them in through $set
|
|
my $delete = $opts->{"${col}_del"} || $set->{"${col}_del"};
|
|
my $filename = $opts->{"${col}_filename"} || $set->{"${col}_filename"};
|
|
my $fh = $set->{$col};
|
|
|
|
# Clean up the file columns (these will get set accordingly further down).
|
|
# This really doesn't have to be done since insert() and update() will only use
|
|
# valid columns, but we'll do it anyways.
|
|
delete $set->{"${col}_del"};
|
|
delete $set->{"${col}_filename"};
|
|
delete $set->{$col};
|
|
|
|
# A file has been uploaded, ignore requests to delete the file
|
|
if (ref $fh and -e $fh) {
|
|
$delete = undef;
|
|
}
|
|
# No or non-existent file passed in, make sure the file data isn't set
|
|
else {
|
|
$fh = undef;
|
|
$filename = undef;
|
|
}
|
|
|
|
# Uploading a new file
|
|
if ($fh) {
|
|
my $max_size = $fcols->{$col}->{file_max_size} || 0;
|
|
return $self->warn('FILE_FILETOOBIG', $fh, -s $fh, $max_size) if $max_size and $max_size < -s $fh;
|
|
|
|
$set->{$col} = $filename || $self->get_filename($fh);
|
|
$fset{$col} = $fh;
|
|
$fset{"${col}_filename"} = $filename if defined $filename and length $filename;
|
|
}
|
|
# Do our own not null checks here, so we can return a relevant error
|
|
elsif ($fcols->{$col}->{not_null}) {
|
|
|
|
# You cannot delete a file from a not_null column during an update() - it must be replaced
|
|
if ($modify_ids and $delete) {
|
|
return $self->warn('FILE_NULLDELETE', $col);
|
|
}
|
|
elsif ($modify_ids) {
|
|
# The file column can be left blank on an update only if a file has already been uploaded
|
|
for (@$modify_ids) {
|
|
return $self->warn('FILE_NULLUPDATE', $col) unless $self->file_info($col, $_);
|
|
}
|
|
}
|
|
# This is an insert() - all not_null file columns should have a value set
|
|
else {
|
|
return $self->warn('FILE_NOTNULL', $col);
|
|
}
|
|
}
|
|
|
|
if ($delete) {
|
|
# Deleting the file, so update the column in the parent table to ''
|
|
$set->{$col} = '';
|
|
$fset{"${col}_del"} = $delete;
|
|
}
|
|
}
|
|
|
|
return wantarray ? %fset : \%fset;
|
|
}
|
|
END_OF_SUB
|
|
|
|
package GT::SQL::File::Fh;
|
|
|
|
# ===================================================================
|
|
# Magic File Handle, lets you print the file name, but also act like
|
|
# a file handle for read, just like CGI.pm.
|
|
#
|
|
use strict qw/vars subs/;
|
|
no strict 'refs';
|
|
use vars qw/$FH %FH_Conns $AUTOLOAD/;
|
|
use overload
|
|
'""' => \&as_string,
|
|
'cmp' => \&compare,
|
|
'fallback' => 1;
|
|
$FH = 1;
|
|
%FH_Conns = ();
|
|
|
|
sub open {
|
|
# -------------------------------------------------------------------
|
|
# Create a new filehandle based on a counter, and the filename.
|
|
#
|
|
goto >::SQL::File::Fh::new;
|
|
}
|
|
|
|
sub new {
|
|
# -------------------------------------------------------------------
|
|
# Create a new filehandle based on a counter, and the filename.
|
|
#
|
|
my ( $pkg, $file, $opt ) = @_;
|
|
$file or return;
|
|
|
|
my $fid = $FH++;
|
|
my $fname = sprintf( "FH%05d", $fid );
|
|
my $fh = \do { local *{$fname}; *{$fname} };
|
|
|
|
CORE::open ($fh, $file || '') or return;
|
|
|
|
bless $fh, $pkg;
|
|
|
|
my $obj = GT::SQL::File->new({
|
|
%{$opt||{}},
|
|
file_name => GT::SQL::File->get_filename( $file ),
|
|
file_fpath => $file,
|
|
}) or return;
|
|
|
|
$obj->File_Binary() and binmode $fh;
|
|
|
|
$FH_Conns{$$fh} = $obj;
|
|
|
|
return $fh;
|
|
}
|
|
|
|
sub as_string {
|
|
# -------------------------------------------------------------------
|
|
# Return the filename, strip off leading junk first.
|
|
#
|
|
my $self = shift;
|
|
return $FH_Conns{$$self}->{file_fpath};
|
|
}
|
|
|
|
sub compare {
|
|
# -------------------------------------------------------------------
|
|
# Do comparisions, uses as_string to get file name first.
|
|
#
|
|
my $self = shift;
|
|
my $value = shift;
|
|
return "$self" cmp $value;
|
|
}
|
|
|
|
|
|
sub AUTOLOAD {
|
|
# -------------------------------------------------------------------
|
|
my $self = shift;
|
|
my ($pkg, $what) = $AUTOLOAD =~ /^(.*)::([^:]+)$/;
|
|
|
|
my $fh_ref = $FH_Conns{$$self} or return;
|
|
|
|
if ( $fh_ref->can($what) ) {
|
|
return $fh_ref->$what(@_)
|
|
}
|
|
elsif ($GT::SQL::File::PERMIT_REFS->{$what}) {
|
|
$fh_ref->{$what} = shift if @_;
|
|
return $fh_ref->{$what};
|
|
}
|
|
else {
|
|
return $fh_ref->error('FILE_UNKNOWNREF', 'FATAL', $what);
|
|
}
|
|
}
|
|
|
|
sub DESTROY {
|
|
# -------------------------------------------------------------------
|
|
# Close file handle.
|
|
#
|
|
my $self = shift;
|
|
delete $FH_Conns{$$self};
|
|
close $self;
|
|
}
|
|
|
|
1;
|
|
|
|
__END__
|
|
|
|
=head1 NAME
|
|
|
|
GT::SQL::File - adds file upload and download abilities to GT::SQL
|
|
|
|
GT::SQL::File::Fh - basic file object
|
|
|
|
=head1 DESCRIPTION
|
|
|
|
GT::SQL::File is not created directly by the user. This module is an
|
|
internal module for GT::SQL to provide the abilty to upload/download
|
|
files into a database column (or so it seems).
|
|
|
|
GT::SQL::File::Fh is often accessed by the user as well as created
|
|
by the user whenever the user wants to store a file in the database.
|
|
|
|
=head2 Creating a new FILE Column
|
|
|
|
When a new table is created or a column is converted into 'FILE'
|
|
type, two things are created. First a column of type text which will
|
|
save the name of the file that is being stored. Secondly, a
|
|
piggy-back table will be greated under the name
|
|
"parent_table_name_File". This new table will store the location of
|
|
the uploaded/stored file and various associated file attributes.
|
|
|
|
To create a new file table, include a column something like the
|
|
following.
|
|
|
|
File_Col_Name => {
|
|
|
|
# common parameters
|
|
pos => 2,
|
|
type => 'FILE',
|
|
|
|
# location of the directory where
|
|
# all the files should be saved
|
|
file_save_in => '/tmp',
|
|
|
|
# the method all the files are saved
|
|
# 'hashed', or 'simple'
|
|
#
|
|
# Defaults to hashed, and stores files in:
|
|
# file_save_in/hashed_letter/ID
|
|
# Simple stores files in:
|
|
# file_save_in/ID_OwnName.OwnExt
|
|
file_save_scheme => 'hashed',
|
|
} ...
|
|
|
|
=head2 Inserting into the Column
|
|
|
|
Once you have the table created, to insert:
|
|
|
|
# Include all the modules
|
|
use GT::SQL;
|
|
use GT::SQL::File;
|
|
|
|
# First create a file object pointing to the file
|
|
$f = GT::SQL::File->open('/path/to/file.txt');
|
|
|
|
# Then create a table object
|
|
$DB = GT::SQL->new('path/to/defs');
|
|
$tbl = $DB->table();
|
|
|
|
# Create the record
|
|
# the file field can also be GT::CGI::Fh type
|
|
$rec = {
|
|
File_Column => $f,
|
|
# ... and all the other columns
|
|
};
|
|
|
|
# optionally, if you know the path to the file, you can provide
|
|
# a scalar ref of the path and the module will autoload
|
|
# the values
|
|
# simple scalar values will be dropped
|
|
$rec = {
|
|
File_Column => \"/path/to/file.txt"
|
|
# ... and all the other columns
|
|
};
|
|
|
|
# Then to store the file
|
|
$id = $tbl->add( $rec );
|
|
|
|
=head2 Retreiving from Column
|
|
|
|
When a file has been stored. A standard select will only return
|
|
the name of the file.
|
|
|
|
To get a filehandle, taking the previous example, if we know the
|
|
unique id, you can do the following.
|
|
|
|
$fh = $tbl->file_info( 'File_Column', $id );
|
|
|
|
You can use this file handle just like any other, however hidden
|
|
behind are special functions that can be used as follows:
|
|
|
|
print "Content-type: ", $fh->File_MimeType(), "\n\n";
|
|
print <$fh>;
|
|
|
|
The following is a partial list of special functions you may access.
|
|
|
|
|
|
Method Returns
|
|
------ -------
|
|
File_Name the basic filename
|
|
File_Directory path to the file
|
|
File_MimeType mimetype of the file
|
|
File_Size site of the file
|
|
File_RelativePath the permuted file and directory without root
|
|
File_URL if possible, the URL to the requested file
|
|
File_RelativeURL the relative URL to the requested file
|
|
|
|
=head1 COPYRIGHT
|
|
|
|
Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
|
http://www.gossamer-threads.com/
|
|
|
|
=head1 VERSION
|
|
|
|
Revision: $Id: File.pm,v 1.70 2012/01/25 23:12:18 brewt Exp $
|
|
|
|
=cut
|
|
|