# ==================================================================
# Gossamer Threads Module Library - http://gossamer-threads.com/
#
#   GT::SQL::File
#   Author  : Aki Mimoto
#   CVS Info :                          
#   $Id: File.pm,v 1.60 2004/08/28 03:53:43 jagerman 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_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 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, $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', "$!" );
            { 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 &GT::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) 2004 Gossamer Threads Inc.  All Rights Reserved.
http://www.gossamer-threads.com/

=head1 VERSION

Revision: $Id: File.pm,v 1.60 2004/08/28 03:53:43 jagerman Exp $

=cut

