lib/DBIx/Class/FileColumn.pm

   1 package DBIx::Class::FileColumn;
   2
   3 use strict;
   4 use warnings;
   5 use base 'DBIx::Class';
   6 use File::Path;
   7 use File::Copy;
   8 use IO::File;
   9
  10 sub inflate_result {
  11     my $self = shift;
  12     my $ret = $self->next::method(@_);
  13
  14     $self->_inflate_file_column($ret);
  15     return $ret;
  16 }
  17
  18 sub insert {
  19     my ( $self, @rest ) = @_;
  20
  21     my ( $file, @column_names ) = $self->_load_file_column_information;
  22     my $ret = $self->next::method(@rest);
  23     $self->_save_file_column( $file, $ret, @column_names );
  24     return $ret;
  25 }
  26
  27 sub update {
  28     my ($self, @rest ) = @_;
  29
  30     my ( $file, @column_names ) = $self->_load_file_column_information;
  31     my $ret = $self->next::method(@rest);
  32     $self->_save_file_column( $file, $ret, @column_names );
  33     return $ret;
  34 }
  35
  36 sub delete {
  37     my ( $self, @rest ) = @_;
  38
  39     my @column_names = $self->columns;
  40     for (@column_names) {
  41         if ( $self->column_info($_)->{is_file_column} ) {
  42             my $path =
  43               File::Spec->catdir( $self->column_info($_)->{file_column_path},
  44                 $self->id );
  45             rmtree( [$path], 0, 0 );
  46         }
  47     }
  48
  49     my $ret = $self->next::method(@rest);
  50
  51     return $ret;
  52 }
  53
  54 sub _inflate_file_column {
  55     my $self = shift;
  56     my $ret  = shift;
  57
  58     my @column_names = $self->columns;
  59     for(@column_names) {
  60         if ( $ret->column_info($_)->{is_file_column} ) {
  61             # make sure everything checks out
  62             unless (defined $ret->$_) {
  63                 # if something is wrong set it to undef
  64                 $ret->$_(undef);
  65                 next;
  66             }
  67             my $fs_file =
  68               File::Spec->catfile( $ret->column_info($_)->{file_column_path},
  69                 $ret->id, $ret->$_ );
  70             $ret->$_({handle => new IO::File($fs_file, "r"), filename => $ret->$_});
  71         }
  72     }
  73 }
  74
  75 sub _load_file_column_information {
  76     my $self = shift;
  77
  78     my $file;
  79     my @column_names;
  80
  81     @column_names = $self->columns;
  82     for (@column_names) {
  83         if ( $self->column_info($_)->{is_file_column} ) {
  84             # make sure everything checks out
  85             unless ((defined $self->$_) ||
  86              (defined $self->$_->{filename} && defined $self->$_->{handle})) {
  87                 # if something is wrong set it to undef
  88                 $self->$_(undef);
  89                 next;
  90             }
  91             $file->{$_} = $self->$_;
  92             $self->$_( $self->$_->{filename} );
  93         }
  94     }
  95
  96     return ( $file, @column_names );
  97 }
  98
  99 sub _save_file_column {
 100     my ( $self, $file, $ret, @column_names ) = @_;
 101
 102     for (@column_names) {
 103         if ( $ret->column_info($_)->{is_file_column} ) {
 104             next unless (defined $ret->$_);
 105             my $file_path =
 106               File::Spec->catdir( $ret->column_info($_)->{file_column_path},
 107                 $ret->id );
 108             mkpath [$file_path];
 109
 110             my $outfile =
 111               File::Spec->catfile( $file_path, $file->{$_}->{filename} );
 112             File::Copy::copy( $file->{$_}->{handle}, $outfile );
 113
 114             $self->_file_column_callback($file->{$_},$ret,$_);
 115         }
 116     }
 117 }
 118
 119 =head1 METHODS
 120
 121 =cut
 122
 123
 124 =head2 _file_column_callback ($file,$ret,$target)
 125
 126 method made to be overridden for callback purposes.
 127
 128 =cut
 129
 130 sub _file_column_callback {
 131     my ($self,$file,$ret,$target) = @_;
 132 }
 133
 134 =head1 NAME
 135
 136 DBIx::Class::FileColumn - FileColumn map files from the Database to the filesystem.
 137
 138 =head1 DESCRIPTION
 139
 140 FileColumn
 141
 142 =head1 SYNOPSIS
 143
 144 In your L<DBIx::Class> table class:
 145
 146     __PACKAGE__->load_components( "PK::Auto", "FileColumn", "Core" );
 147
 148     # define your columns
 149     __PACKAGE__->add_columns(
 150         "id",
 151         {
 152             data_type         => "integer",
 153             is_auto_increment => 1,
 154             is_nullable       => 0,
 155             size              => 4,
 156         },
 157         "filename",
 158         {
 159             data_type           => "varchar",
 160             is_file_column      => 1,
 161             file_column_path    =>'/tmp/uploaded_files',
 162             # or for a Catalyst application
 163             # file_column_path  => MyApp->path_to('root','static','files'),
 164             default_value       => undef,
 165             is_nullable         => 1,
 166             size                => 255,
 167         },
 168     );
 169
 170
 171 In your L<Catalyst::Controller> class:
 172
 173 FileColumn requires a hash that contains L<IO::File> as handle and the file's name as name.
 174
 175     my $entry = $c->model('MyAppDB::Articles')->create({
 176         subject => 'blah',
 177         filename => {
 178             handle => $c->req->upload('myupload')->fh,
 179             filename => $c->req->upload('myupload')->basename
 180         },
 181         body => '....'
 182     });
 183     $c->stash->{entry}=$entry;
 184
 185
 186 And Place the following in your TT template
 187
 188     Article Subject: [% entry.subject %]
 189     Uploaded File:
 190     <a href="/static/files/[% entry.id %]/[% entry.filename.filename %]">File</a>
 191     Body: [% entry.body %]
 192
 193 The file will be stored on the filesystem for later retrieval.
 194 Calling delete on your resultset will delete the file from the filesystem.
 195 Retrevial of the record automatically inflates the column back to the set hash with the IO::File handle and filename.
 196
 197 =head1 AUTHOR
 198
 199 Victor Igumnov
 200
 201 =head1 LICENSE
 202
 203 This library is free software, you can redistribute it and/or modify
 204 it under the same terms as Perl itself.
 205
 206 =cut
 207
 208 1;