lib/DBIx/Class/InflateColumn/File.pm

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