# ================================================================== # Gossamer Threads Module Library - http://gossamer-threads.com/ # # GT::SQL::File # Author : Aki Mimoto # $Id: File.pm,v 1.54 2002/10/31 20:11:32 bao Exp $ # # Copyright (c) 2000 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 $AUTOLOAD $ERROR_MESSAGE $PERMIT_REFS $ERROR_PACKAGE $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_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_PACKAGE = 'GT::SQL'; $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 size: %i exceeds max file size value: %i~, 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.~ }; @$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}); # 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', "$!" ); { local $/; print F <$fh> 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, ); # 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} ) 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, $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} ); unlink $fpath or $self->error( 'FILE_NOUNLINK', 'WARN', $fpath, "$!" ); if ( ref $fh ) { my $trec = $self->_file_getstats( $fname, $fdir, $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', "$!" ); { local $/; print F <$fh> 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 ); # 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}); 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 ); 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 ); 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 $fpath = $self->_file_full_path( $file_rec->{File_Name}, $file_rec->{File_Directory}, $file_rec->{ID}, $name, $fcols{$name}->{file_save_scheme}, 1 ); my $relpath = $self->_file_full_path( $file_rec->{File_Name}, '', $file_rec->{ID}, $name, $fcols{$name}->{file_save_scheme}, 1 ); $file_rec->{File_RelativePath} = $relpath; $file_rec->{File_URL} = $file_rec->{File_URL} . $relpath; 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 ) = @_; $fname = "$fid-$fname"; require GT::CGI; $fname = $enc ? GT::CGI->escape( $fname ) : GT::CGI->unescape( $fname ); return $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 => 'CHAR', size => 50 }, ForeignColKey => { pos => 3, type => 'CHAR', size => 50 }, File_Name => { pos => 4, type => 'CHAR', size => 255 }, File_Directory => { pos => 5, type => 'CHAR', size => 255 }, File_MimeType => { pos => 6, type => 'CHAR', size => 50 }, File_Size => { pos => 7, type => 'INT', not_null => 1, unsigned => 1, regex => '^\d+$' }, File_URL => { pos => 8, type => 'CHAR', 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 Table::insert or Table::update to setup all the # columns and run tests to ensure the file is appropropriate # my ( $package, $fcols, $set, $opts ) = @_; # check to make sure we have records foreach my $col_name ( keys %$fcols ) { defined $set->{$set} or next; ref $set->{$set} and next; $set->{$set} and -e $set->{$set} and next; delete $set->{$set}; } # now check to make sure records are of appropriate size foreach my $col_name ( grep $set->{$_}, keys %$fcols ) { if ( my $max_size = $fcols->{$col_name}->{file_max_size} || 0 ) { if ( $max_size < -s $set->{$col_name} ) { return $package->error( 'FILE_FILETOOBIG', 'WARN', "$set->{$col_name}", -s $set->{$col_name}, $max_size ); } } } # just make backup files my %fset; foreach my $key ( keys %$fcols ) { if ( $set->{$key} ) { my $tmp = $set->{$key}; $set->{$key} = $opts->{$key."_filename"} || $package->get_filename("$set->{$key}"); $fset{$key} = $tmp; } if ( my $val = $set->{$key."_del"} ) { $fset{$key."_del"} = $val; } }; # Remove any that have been deleted. foreach my $key ( keys %$fcols ) { if ( not $set->{$key."_del"} and exists $set->{$key} and not $set->{$key} ) { delete $set->{$key}; } elsif ( $set->{$key."_del"} ) { $set->{$key} = ''; delete $set->{$key."_del"}; } } 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 =head1 COPYRIGHT Copyright (c) 2002 Gossamer Threads Inc. All Rights Reserved. http://www.gossamer-threads.com/ =head1 VERSION Revision: $Id: File.pm,v 1.54 2002/10/31 20:11:32 bao Exp $ =cut