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 DBIx::Class::Carp;
  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->result_source->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     my $colinfos = $self->result_source->columns_info;
  64
  65     for ( keys %$colinfos ) {
  66         if ( $colinfos->{$_}{is_file_column} ) {
  67             rmtree( [$self->_file_column_file($_)->dir], 0, 0 );
  68             last; # if we've deleted one, we've deleted them all
  69         }
  70     }
  71
  72     return $self->next::method(@rest);
  73 }
  74
  75 sub insert {
  76     my $self = shift;
  77
  78     # cache our file columns so we can write them to the fs
  79     # -after- we have a PK
  80     my $colinfos = $self->result_source->columns_info;
  81
  82     my %file_column;
  83     for ( keys %$colinfos ) {
  84         if ( $colinfos->{$_}{is_file_column} ) {
  85             $file_column{$_} = $self->$_;
  86             $self->store_column($_ => $self->$_->{filename});
  87         }
  88     }
  89
  90     $self->next::method(@_);
  91
  92     # write the files to the fs
  93     while ( my ($col, $file) = each %file_column ) {
  94         $self->_save_file_column($col, $file);
  95     }
  96
  97     return $self;
  98 }
  99
 100
 101 sub _inflate_file_column {
 102     my ( $self, $column, $value ) = @_;
 103
 104     my $fs_file = $self->_file_column_file($column, $value);
 105
 106     return { handle => $fs_file->open('r'), filename => $value };
 107 }
 108
 109 sub _save_file_column {
 110     my ( $self, $column, $value ) = @_;
 111
 112     return unless ref $value;
 113
 114     my $fs_file = $self->_file_column_file($column, $value->{filename});
 115     mkpath [$fs_file->dir];
 116
 117     # File::Copy doesn't like Path::Class (or any for that matter) objects,
 118     # thus ->stringify (http://rt.perl.org/rt3/Public/Bug/Display.html?id=59650)
 119     File::Copy::copy($value->{handle}, $fs_file->stringify);
 120
 121     $self->_file_column_callback($value, $self, $column);
 122
 123     return $value->{filename};
 124 }
 125
 126 =head1 NAME
 127
 128 DBIx::Class::InflateColumn::File -  DEPRECATED (superseded by DBIx::Class::InflateColumn::FS)
 129
 130 =head2 Deprecation Notice
 131
 132  This component has a number of architectural deficiencies that can quickly
 133  drive your filesystem and database out of sync and is not recommended for
 134  further use. It will be retained for backwards compatibility, but no new
 135  functionality patches will be accepted. Please consider using the much more
 136  mature and actively supported DBIx::Class::InflateColumn::FS. You can set
 137  the environment variable DBIC_IC_FILE_NOWARN to a true value to disable
 138  this warning.
 139
 140 =head1 SYNOPSIS
 141
 142 In your L<DBIx::Class> table class:
 143
 144     use base 'DBIx::Class::Core';
 145
 146     __PACKAGE__->load_components(qw/InflateColumn::File/);
 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
 174 name as name.
 175
 176     my $entry = $c->model('MyAppDB::Articles')->create({
 177         subject => 'blah',
 178         filename => {
 179             handle => $c->req->upload('myupload')->fh,
 180             filename => $c->req->upload('myupload')->basename
 181         },
 182         body => '....'
 183     });
 184     $c->stash->{entry}=$entry;
 185
 186
 187 And Place the following in your TT template
 188
 189     Article Subject: [% entry.subject %]
 190     Uploaded File:
 191     <a href="/static/files/[% entry.id %]/[% entry.filename.filename %]">File</a>
 192     Body: [% entry.body %]
 193
 194 The file will be stored on the filesystem for later retrieval.  Calling delete
 195 on your resultset will delete the file from the filesystem.  Retrevial of the
 196 record automatically inflates the column back to the set hash with the
 197 IO::File handle and filename.
 198
 199 =head1 DESCRIPTION
 200
 201 InflateColumn::File
 202
 203 =head1 METHODS
 204
 205 =head2 _file_column_callback ($file,$ret,$target)
 206
 207 Method made to be overridden for callback purposes.
 208
 209 =cut
 210
 211 sub _file_column_callback {}
 212
 213 =head1 AUTHOR
 214
 215 Victor Igumnov
 216
 217 =head1 LICENSE
 218
 219 This library is free software, you can redistribute it and/or modify
 220 it under the same terms as Perl itself.
 221
 222 =cut
 223
 224 1;