use strict;
use warnings;
+
+# check deps
+BEGIN {
+ require DBIx::Class::Optional::Dependencies;
+ if (my $missing = DBIx::Class::Optional::Dependencies->req_missing_for ('ic_file') ) {
+ die "The following extra modules are required for DBIx::Class::InflateColumn::File: $missing\n";
+ }
+}
+
use base 'DBIx::Class';
-use File::Path;
use File::Copy;
-use IO::File;
+use DBIx::Class::Carp;
+use namespace::clean;
-__PACKAGE__->load_components(qw/InflateColumn/);
+carp 'InflateColumn::File has entered a deprecation cycle. This component '
+ .'has a number of architectural deficiencies that can quickly drive '
+ .'your filesystem and database out of sync and is not recommended '
+ .'for further use. It will be retained for backwards '
+ .'compatibility, but no new functionality patches will be accepted. '
+ .'Please consider using the much more mature and actively maintained '
+ .'DBIx::Class::InflateColumn::FS. You can set the environment variable '
+ .'DBIC_IC_FILE_NOWARN to a true value to disable this warning.'
+unless $ENV{DBIC_IC_FILE_NOWARN};
+__PACKAGE__->load_components(qw/InflateColumn/);
+
sub register_column {
- my ($self, $column, $info, @rest) = @_;
- $self->next::method($column, $info, @rest);
- return unless defined($info->{is_file_column});
- $self->inflate_column(
- $column =>
- {
- inflate => sub {
+ my ($self, $column, $info, @rest) = @_;
+ $self->next::method($column, $info, @rest);
+ return unless defined($info->{is_file_column});
+
+ $self->inflate_column($column => {
+ inflate => sub {
my ($value, $obj) = @_;
- #$self->_inflate_file_column;
- },
- deflate => sub {
+ $obj->_inflate_file_column($column, $value);
+ },
+ deflate => sub {
my ($value, $obj) = @_;
- #my ( $file, @column_names ) = $self->_load_file_column_information;
- #$self->_save_file_column( $file, $self, @column_names );
- },
- }
- );
+ $obj->_save_file_column($column, $value);
+ },
+ });
}
+sub _file_column_file {
+ my ($self, $column, $filename) = @_;
+
+ my $column_info = $self->result_source->columns_info->{$column};
+
+ return unless $column_info->{is_file_column};
+
+ # DO NOT CHANGE
+ # This call to id() is generally incorrect - will not DTRT on
+ # multicolumn key. However changing this may introduce
+ # backwards-comp regressions, thus leaving as is
+ my $id = $self->id || $self->throw_exception(
+ 'id required for filename generation'
+ );
+
+ $filename ||= $self->$column->{filename};
+ return Path::Class::file(
+ $column_info->{file_column_path}, $id, $filename,
+ );
+}
sub delete {
my ( $self, @rest ) = @_;
- my @column_names = $self->columns;
- for (@column_names) {
- if ( $self->column_info($_)->{is_file_column} ) {
- my $path =
- File::Spec->catdir( $self->column_info($_)->{file_column_path},
- $self->id );
- rmtree( [$path], 0, 0 );
+ my $colinfos = $self->result_source->columns_info;
+
+ for ( keys %$colinfos ) {
+ if ( $colinfos->{$_}{is_file_column} ) {
+ $self->_file_column_file($_)->dir->rmtree;
+ last; # if we've deleted one, we've deleted them all
}
}
- my $ret = $self->next::method(@rest);
-
- return $ret;
+ return $self->next::method(@rest);
}
-sub _inflate_file_column {
+sub insert {
my $self = shift;
- my @column_names = $self->columns;
- for(@column_names) {
- if ( $self->column_info($_)->{is_file_column} ) {
- # make sure everything checks out
- unless (defined $self->$_) {
- # if something is wrong set it to undef
- $self->$_(undef);
- next;
- }
- my $fs_file =
- File::Spec->catfile( $self->column_info($_)->{file_column_path},
- $self->id, $self->$_ );
- $self->$_({handle => new IO::File($fs_file, "r"), filename => $self->$_});
+ # cache our file columns so we can write them to the fs
+ # -after- we have a PK
+ my $colinfos = $self->result_source->columns_info;
+
+ my %file_column;
+ for ( keys %$colinfos ) {
+ if ( $colinfos->{$_}{is_file_column} ) {
+ $file_column{$_} = $self->$_;
+ $self->store_column($_ => $self->$_->{filename});
}
}
-}
-sub _load_file_column_information {
- my $self = shift;
+ $self->next::method(@_);
- my $file;
- my @column_names;
-
- @column_names = $self->columns;
- for (@column_names) {
- if ( $self->column_info($_)->{is_file_column} ) {
- # make sure everything checks out
- unless ((defined $self->$_) ||
- (defined $self->$_->{filename} && defined $self->$_->{handle})) {
- # if something is wrong set it to undef
- $self->$_(undef);
- next;
- }
- $file->{$_} = $self->$_;
- $self->$_( $self->$_->{filename} );
- }
+ # write the files to the fs
+ while ( my ($col, $file) = each %file_column ) {
+ $self->_save_file_column($col, $file);
}
- return ( $file, @column_names );
+ return $self;
+}
+
+
+sub _inflate_file_column {
+ my ( $self, $column, $value ) = @_;
+
+ my $fs_file = $self->_file_column_file($column, $value);
+
+ return { handle => $fs_file->open('r'), filename => $value };
}
sub _save_file_column {
- my ( $self, $file, $ret, @column_names ) = @_;
-
- for (@column_names) {
- if ( $ret->column_info($_)->{is_file_column} ) {
- next unless (defined $ret->$_);
- my $file_path =
- File::Spec->catdir( $ret->column_info($_)->{file_column_path},
- $ret->id );
- mkpath [$file_path];
-
- my $outfile =
- File::Spec->catfile( $file_path, $file->{$_}->{filename} );
- File::Copy::copy( $file->{$_}->{handle}, $outfile );
-
- $self->_file_column_callback($file->{$_},$ret,$_);
- }
- }
+ my ( $self, $column, $value ) = @_;
+
+ return unless ref $value;
+
+ my $fs_file = $self->_file_column_file($column, $value->{filename});
+ $fs_file->dir->mkpath;
+
+ # File::Copy doesn't like Path::Class (or any for that matter) objects,
+ # thus ->stringify (http://rt.perl.org/rt3/Public/Bug/Display.html?id=59650)
+ File::Copy::copy($value->{handle}, $fs_file->stringify);
+
+ $self->_file_column_callback($value, $self, $column);
+
+ return $value->{filename};
}
=head1 NAME
-DBIx::Class::InflateColumn::File - map files from the Database to the filesystem.
+DBIx::Class::InflateColumn::File - DEPRECATED (superseded by DBIx::Class::InflateColumn::FS)
+
+=head2 Deprecation Notice
+
+ This component has a number of architectural deficiencies that can quickly
+ drive your filesystem and database out of sync and is not recommended for
+ further use. It will be retained for backwards compatibility, but no new
+ functionality patches will be accepted. Please consider using the much more
+ mature and actively supported DBIx::Class::InflateColumn::FS. You can set
+ the environment variable DBIC_IC_FILE_NOWARN to a true value to disable
+ this warning.
=head1 SYNOPSIS
In your L<DBIx::Class> table class:
- __PACKAGE__->load_components( "PK::Auto", "InflateColumn::File", "Core" );
-
+ use base 'DBIx::Class::Core';
+
+ __PACKAGE__->load_components(qw/InflateColumn::File/);
+
# define your columns
__PACKAGE__->add_columns(
"id",
data_type => "varchar",
is_file_column => 1,
file_column_path =>'/tmp/uploaded_files',
- # or for a Catalyst application
+ # or for a Catalyst application
# file_column_path => MyApp->path_to('root','static','files'),
default_value => undef,
is_nullable => 1,
size => 255,
},
);
-
+
In your L<Catalyst::Controller> class:
FileColumn requires a hash that contains L<IO::File> as handle and the file's
name as name.
- my $entry = $c->model('MyAppDB::Articles')->create({
+ my $entry = $c->model('MyAppDB::Articles')->create({
subject => 'blah',
- filename => {
- handle => $c->req->upload('myupload')->fh,
- filename => $c->req->upload('myupload')->basename
+ filename => {
+ handle => $c->req->upload('myupload')->fh,
+ filename => $c->req->upload('myupload')->basename
},
body => '....'
});
$c->stash->{entry}=$entry;
-
+
And Place the following in your TT template
-
+
Article Subject: [% entry.subject %]
- Uploaded File:
+ Uploaded File:
<a href="/static/files/[% entry.id %]/[% entry.filename.filename %]">File</a>
Body: [% entry.body %]
-
+
The file will be stored on the filesystem for later retrieval. Calling delete
on your resultset will delete the file from the filesystem. Retrevial of the
record automatically inflates the column back to the set hash with the
=head2 _file_column_callback ($file,$ret,$target)
-method made to be overridden for callback purposes.
+Method made to be overridden for callback purposes.
=cut
-sub _file_column_callback {
- my ($self,$file,$ret,$target) = @_;
-}
+sub _file_column_callback {}
-=head1 AUTHOR
+=head1 FURTHER QUESTIONS?
-Victor Igumnov
+Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
-=head1 LICENSE
+=head1 COPYRIGHT AND LICENSE
-This library is free software, you can redistribute it and/or modify
-it under the same terms as Perl itself.
+This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
+by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
+redistribute it and/or modify it under the same terms as the
+L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.
=cut
projects / dbsrgits/DBIx-Class.git / blobdiff