lib/DBIx/Class/InflateColumn/File.pm

   1 package DBIx::Class::InflateColumn::File;
   2
   3 use strict;
   4 use warnings;
   5 use base 'DBIx::Class';
   6 use File::Path;
   7 use File::Copy;
   8 use Path::Class;
   9 use Carp::Clan qw/^DBIx::Class/;
  10 use namespace::clean;
  11
  12 carp 'InflateColumn::File has entered a deprecation cycle. This component '
  13     .'has a number of architectural deficiencies that can quickly drive '
  14     .'your filesystem and database out of sync and is not recommended '
  15     .'for further use. It will be retained for backwards '
  16     .'compatibility, but no new functionality patches will be accepted. '
  17     .'Please consider using the much more mature and actively maintained '
  18     .'DBIx::Class::InflateColumn::FS. You can set the environment variable '
  19     .'DBIC_IC_FILE_NOWARN to a true value to disable  this warning.'
  20 unless $ENV{DBIC_IC_FILE_NOWARN};
  21
  22
  23
  24 __PACKAGE__->load_components(qw/InflateColumn/);
  25
  26 sub register_column {
  27     my ($self, $column, $info, @rest) = @_;
  28     $self->next::method($column, $info, @rest);
  29     return unless defined($info->{is_file_column});
  30
  31     $self->inflate_column($column => {
  32         inflate => sub {
  33             my ($value, $obj) = @_;
  34             $obj->_inflate_file_column($column, $value);
  35         },
  36         deflate => sub {
  37             my ($value, $obj) = @_;
  38             $obj->_save_file_column($column, $value);
  39         },
  40     });
  41 }
  42
  43 sub _file_column_file {
  44     my ($self, $column, $filename) = @_;
  45
  46     my $column_info = $self->column_info($column);
  47
  48     return unless $column_info->{is_file_column};
  49
  50     my $id = $self->id || $self->throw_exception(
  51         'id required for filename generation'
  52     );
  53
  54     $filename ||= $self->$column->{filename};
  55     return Path::Class::file(
  56         $column_info->{file_column_path}, $id, $filename,
  57     );
  58 }
  59
  60 sub delete {
  61     my ( $self, @rest ) = @_;
  62
  63     for ( $self->columns ) {
  64         if ( $self->column_info($_)->{is_file_column} ) {
  65             rmtree( [$self->_file_column_file($_)->dir], 0, 0 );
  66             last; # if we've deleted one, we've deleted them all
  67         }
  68     }
  69
  70     return $self->next::method(@rest);
  71 }
  72
  73 sub insert {
  74     my $self = shift;
  75
  76     # cache our file columns so we can write them to the fs
  77     # -after- we have a PK
  78     my %file_column;
  79     for ( $self->columns ) {
  80         if ( $self->column_info($_)->{is_file_column} ) {
  81             $file_column{$_} = $self->$_;
  82             $self->store_column($_ => $self->$_->{filename});
  83         }
  84     }
  85
  86     $self->next::method(@_);
  87
  88     # write the files to the fs
  89     while ( my ($col, $file) = each %file_column ) {
  90         $self->_save_file_column($col, $file);
  91     }
  92
  93     return $self;
  94 }
  95
  96
  97 sub _inflate_file_column {
  98     my ( $self, $column, $value ) = @_;
  99
 100     my $fs_file = $self->_file_column_file($column, $value);
 101
 102     return { handle => $fs_file->open('r'), filename => $value };
 103 }
 104
 105 sub _save_file_column {
 106     my ( $self, $column, $value ) = @_;
 107
 108     return unless ref $value;
 109
 110     my $fs_file = $self->_file_column_file($column, $value->{filename});
 111     mkpath [$fs_file->dir];
 112
 113     # File::Copy doesn't like Path::Class (or any for that matter) objects,
 114     # thus ->stringify (http://rt.perl.org/rt3/Public/Bug/Display.html?id=59650)
 115     File::Copy::copy($value->{handle}, $fs_file->stringify);
 116
 117     $self->_file_column_callback($value, $self, $column);
 118
 119     return $value->{filename};
 120 }
 121
 122 =head1 NAME
 123
 124 DBIx::Class::InflateColumn::File -  DEPRECATED (superseded by DBIx::Class::InflateColumn::FS)
 125
 126 =head2 Deprecation Notice
 127
 128  This component has a number of architectural deficiencies that can quickly
 129  drive your filesystem and database out of sync and is not recommended for
 130  further use. It will be retained for backwards compatibility, but no new
 131  functionality patches will be accepted. Please consider using the much more
 132  mature and actively supported DBIx::Class::InflateColumn::FS. You can set
 133  the environment variable DBIC_IC_FILE_NOWARN to a true value to disable
 134  this warning.
 135
 136 =head1 SYNOPSIS
 137
 138 In your L<DBIx::Class> table class:
 139
 140     use base 'DBIx::Class::Core';
 141
 142     __PACKAGE__->load_components(qw/InflateColumn::File/);
 143
 144     # define your columns
 145     __PACKAGE__->add_columns(
 146         "id",
 147         {
 148             data_type         => "integer",
 149             is_auto_increment => 1,
 150             is_nullable       => 0,
 151             size              => 4,
 152         },
 153         "filename",
 154         {
 155             data_type           => "varchar",
 156             is_file_column      => 1,
 157             file_column_path    =>'/tmp/uploaded_files',
 158             # or for a Catalyst application
 159             # file_column_path  => MyApp->path_to('root','static','files'),
 160             default_value       => undef,
 161             is_nullable         => 1,
 162             size                => 255,
 163         },
 164     );
 165
 166
 167 In your L<Catalyst::Controller> class:
 168
 169 FileColumn requires a hash that contains L<IO::File> as handle and the file's
 170 name as name.
 171
 172     my $entry = $c->model('MyAppDB::Articles')->create({
 173         subject => 'blah',
 174         filename => {
 175             handle => $c->req->upload('myupload')->fh,
 176             filename => $c->req->upload('myupload')->basename
 177         },
 178         body => '....'
 179     });
 180     $c->stash->{entry}=$entry;
 181
 182
 183 And Place the following in your TT template
 184
 185     Article Subject: [% entry.subject %]
 186     Uploaded File:
 187     <a href="/static/files/[% entry.id %]/[% entry.filename.filename %]">File</a>
 188     Body: [% entry.body %]
 189
 190 The file will be stored on the filesystem for later retrieval.  Calling delete
 191 on your resultset will delete the file from the filesystem.  Retrevial of the
 192 record automatically inflates the column back to the set hash with the
 193 IO::File handle and filename.
 194
 195 =head1 DESCRIPTION
 196
 197 InflateColumn::File
 198
 199 =head1 METHODS
 200
 201 =head2 _file_column_callback ($file,$ret,$target)
 202
 203 Method made to be overridden for callback purposes.
 204
 205 =cut
 206
 207 sub _file_column_callback {}
 208
 209 =head1 AUTHOR
 210
 211 Victor Igumnov
 212
 213 =head1 LICENSE
 214
 215 This library is free software, you can redistribute it and/or modify
 216 it under the same terms as Perl itself.
 217
 218 =cut
 219
 220 1;