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