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