[Bast-commits] r4883 - in DBIx-Class-InflateColumn-FS/1.000/trunk:
. lib lib/DBIx lib/DBIx/Class lib/DBIx/Class/InflateColumn
lib/DBIx/Class/InflateColumn/FS t t/lib t/lib/My t/lib/My/TestSchema
semifor at dev.catalyst.perl.org
semifor at dev.catalyst.perl.org
Sun Oct 5 19:47:40 BST 2008
Author: semifor
Date: 2008-10-05 19:47:40 +0100 (Sun, 05 Oct 2008)
New Revision: 4883
Added:
DBIx-Class-InflateColumn-FS/1.000/trunk/Changes
DBIx-Class-InflateColumn-FS/1.000/trunk/Makefile.PL
DBIx-Class-InflateColumn-FS/1.000/trunk/lib/
DBIx-Class-InflateColumn-FS/1.000/trunk/lib/DBIx/
DBIx-Class-InflateColumn-FS/1.000/trunk/lib/DBIx/Class/
DBIx-Class-InflateColumn-FS/1.000/trunk/lib/DBIx/Class/InflateColumn/
DBIx-Class-InflateColumn-FS/1.000/trunk/lib/DBIx/Class/InflateColumn/FS.pm
DBIx-Class-InflateColumn-FS/1.000/trunk/lib/DBIx/Class/InflateColumn/FS/
DBIx-Class-InflateColumn-FS/1.000/trunk/lib/DBIx/Class/InflateColumn/FS/ResultSet.pm
DBIx-Class-InflateColumn-FS/1.000/trunk/t/
DBIx-Class-InflateColumn-FS/1.000/trunk/t/00-load.t
DBIx-Class-InflateColumn-FS/1.000/trunk/t/01-schema.t
DBIx-Class-InflateColumn-FS/1.000/trunk/t/03podcoverage.t
DBIx-Class-InflateColumn-FS/1.000/trunk/t/lib/
DBIx-Class-InflateColumn-FS/1.000/trunk/t/lib/My/
DBIx-Class-InflateColumn-FS/1.000/trunk/t/lib/My/TestSchema.pm
DBIx-Class-InflateColumn-FS/1.000/trunk/t/lib/My/TestSchema/
DBIx-Class-InflateColumn-FS/1.000/trunk/t/lib/My/TestSchema/Author.pm
DBIx-Class-InflateColumn-FS/1.000/trunk/t/lib/My/TestSchema/Book.pm
Log:
Inflate columns to Path::Class::File objects: an alternative to BLOBs
Added: DBIx-Class-InflateColumn-FS/1.000/trunk/Changes
===================================================================
--- DBIx-Class-InflateColumn-FS/1.000/trunk/Changes (rev 0)
+++ DBIx-Class-InflateColumn-FS/1.000/trunk/Changes 2008-10-05 18:47:40 UTC (rev 4883)
@@ -0,0 +1,9 @@
+0.00000_03 2008-10-04 15:20:00
+ - store only the path name below fs_column_path
+
+0.00000_02 2008-10-04 11:25:00
+ - reimplemnted with UUID based filenames
+ - dropped ::SHA1
+
+0.00000_01 2008-09-30 08:45:00
+ - First development release
Added: DBIx-Class-InflateColumn-FS/1.000/trunk/Makefile.PL
===================================================================
--- DBIx-Class-InflateColumn-FS/1.000/trunk/Makefile.PL (rev 0)
+++ DBIx-Class-InflateColumn-FS/1.000/trunk/Makefile.PL 2008-10-05 18:47:40 UTC (rev 4883)
@@ -0,0 +1,22 @@
+use inc::Module::Install 0.67;
+use strict;
+use warnings;
+
+use 5.006001;
+
+name 'DBIx-Class-InflateColumn-FS';
+perl_version '5.006001';
+all_from 'lib/DBIx/Class/InflateColumn/FS.pm';
+
+requires 'DBIx::Class' => 0.08;
+requires 'File::Path' => 0;
+requires 'File::Copy' => 0;
+requires 'Path::Class' => 0;
+requires 'Data::UUID' => 0;
+
+test_requires 'DBD::SQLite' => 1.12;
+test_requires 'DBICx::TestDatabase' => 0;
+test_requires 'File::Compare' => 0;
+test_requires 'File::Temp' => 0;
+
+WriteAll;
Added: DBIx-Class-InflateColumn-FS/1.000/trunk/lib/DBIx/Class/InflateColumn/FS/ResultSet.pm
===================================================================
--- DBIx-Class-InflateColumn-FS/1.000/trunk/lib/DBIx/Class/InflateColumn/FS/ResultSet.pm (rev 0)
+++ DBIx-Class-InflateColumn-FS/1.000/trunk/lib/DBIx/Class/InflateColumn/FS/ResultSet.pm 2008-10-05 18:47:40 UTC (rev 4883)
@@ -0,0 +1,34 @@
+package DBIx::Class::InflateColumn::FS::ResultSet;
+use base qw/DBIx::Class::ResultSet/;
+
+=head1 NAME
+
+DBIx::Class::InflateColumn::FS::ResultSet - FS columns resultset class
+
+=head1 DESCIPTION
+
+Derive from this class if you intend to provide a custom resultset
+class for result sources including DBIx::Class::InflateColumn::FS
+columns.
+
+=head1 METHODS
+
+=head2 delete
+
+Delete each row in a resultset.
+
+=cut
+
+sub delete { shift->delete_all }
+
+=head1 AUTHOR
+
+Marc Mims <marc at questright.com>
+
+=head1 LICENSE
+
+You may distribute this code under the same terms as Perl itself.
+
+=cut
+
+1;
Added: DBIx-Class-InflateColumn-FS/1.000/trunk/lib/DBIx/Class/InflateColumn/FS.pm
===================================================================
--- DBIx-Class-InflateColumn-FS/1.000/trunk/lib/DBIx/Class/InflateColumn/FS.pm (rev 0)
+++ DBIx-Class-InflateColumn-FS/1.000/trunk/lib/DBIx/Class/InflateColumn/FS.pm 2008-10-05 18:47:40 UTC (rev 4883)
@@ -0,0 +1,245 @@
+package DBIx::Class::InflateColumn::FS;
+
+use strict;
+use warnings;
+use base 'DBIx::Class';
+use File::Spec;
+use File::Path;
+use File::Copy;
+use Path::Class;
+use Data::UUID;
+
+our $VERSION = '0.00000_03';
+
+=head1 NAME
+
+DBIx::Class::InflateColumn::FS - file columns stored in the file system
+
+=head1 SYNOPSIS
+
+ __PACKAGE__->load_components('InflateColumn::FS Core');
+ __PACKAGE__->add_columns(
+ id => {
+ data_type => 'INT',
+ is_auto_increment => 1,
+ },
+ file => {
+ data_type => 'TEXT',
+ is_fs_column => 1,
+ fs_column_path => '/var/lib/myapp/myfiles',
+ },
+ );
+ __PACKAGE__->set_primary_key('id');
+
+ # in application code
+ $rs->create({ file => $file_handle });
+
+ $row = $rs->find({ id => $id });
+ my $fh = $row->file->open('r');
+
+=head1 DESCRIPTION
+
+Provides inflation to a Path::Class::File object allowing storage an
+retreival of files in the file system.
+
+The path for storing files is specified for each column. Depending upon
+the file naming algorithm, a separate path may be needed for each table
+using InflateColumn::FS, or even for each individual column.
+
+By default, InflateColumn::FS creates a file in fs_column_path, in a
+subdirectory based on the row ID (assumed to be an integer), and the
+column, name. As an example, with fs_column_path set to 'var/foo',
+for a column named 'bar', with row ID 2192, will be saved as:
+
+ var/foo/92/2192_bar
+
+=cut
+
+=head1 METHODS
+
+=cut
+
+=head2 register_column
+
+=cut
+
+sub register_column {
+ my ($self, $column, $info, @rest) = @_;
+ $self->next::method($column, $info, @rest);
+ return unless defined($info->{is_fs_column});
+
+ $self->inflate_column($column => {
+ inflate => sub {
+ my ($value, $obj) = @_;
+ $obj->_inflate_fs_column($column, $value);
+ },
+ deflate => sub {
+ my ($value, $obj) = @_;
+ $obj->_deflate_fs_column($column, $value);
+ },
+ });
+}
+
+=head2 _fs_column_storage
+
+Provides the file naming alorithm. Override this method to change it.
+
+=cut
+
+sub _fs_column_storage {
+ my ( $self, $column ) = @_;
+
+ my $column_info = $self->column_info($column);
+ $self->throw_exception("$column is not an fs_column")
+ unless $column_info->{is_fs_column};
+
+ if ( my $filename = $self->{_column_data}{$column} ) {
+ return Path::Class::File->new($column_info->{fs_column_path}, $filename);
+ }
+ else {
+ $filename = Data::UUID->new->create_str;
+ return Path::Class::File->new(
+ $column_info->{fs_column_path},
+ $self->_fs_column_dirs($filename),
+ $filename
+ );
+ }
+}
+
+=head2 _fs_column_dirs
+
+Returns a list of directory components for a given file name
+
+=cut
+
+sub _fs_column_dirs {
+ shift;
+ my $filename = shift;
+
+ return $filename =~ /(..)/;
+}
+
+=head2 delete
+
+Deletes the associated file system storage when a row is deleted.
+
+=cut
+
+sub delete {
+ my ( $self, @rest ) = @_;
+
+ for ( $self->columns ) {
+ if ( $self->column_info($_)->{is_fs_column} ) {
+ $self->$_->remove;
+ }
+ }
+
+ return $self->next::method(@rest);
+}
+
+=head2 update
+
+Deletes file system storage when an fs_column is set to null.
+
+=cut
+
+sub update {
+ my ($self, $upd) = @_;
+
+ my %changed = ($self->get_dirty_columns, %{$upd || {}});
+
+ # cache existing fs_colums before update so we can delete storge afterwards if necessary
+ my %fs_column =
+ map { ($_, $self->$_) }
+ grep { $self->column_info($_)->{is_fs_column} }
+ keys %changed;
+
+ # attempt super update, first, so it can throw on DB errors
+ # and perform other checks
+ $self->next::method($upd);
+
+ while ( my ($column, $value) = each %changed ) {
+ if ( $self->column_info($column)->{is_fs_column} ) {
+ # remove the storage if the column was set to NULL
+ $fs_column{$column}->remove if !defined $value;
+
+ # force reinflation on next access
+ delete $self->{_inflated_column}{$column};
+ }
+ }
+ return $self;
+}
+
+=head2 _inflate_fs_column
+
+Inflates a file coulmn to a Path::Class::File object.
+
+=cut
+
+sub _inflate_fs_column {
+ my ( $self, $column, $value ) = @_;
+
+ return unless defined $value;
+
+ return $self->_fs_column_storage($column);
+}
+
+=head2 _deflate_fs_column
+
+Deflates a file column to the abitrary value, 1. In the database, a
+file column is just a place holder for inflation/deflation. The actual
+file lives in the file system.
+
+=cut
+
+sub _deflate_fs_column {
+ my ( $self, $column, $value ) = @_;
+
+ # already deflated?
+ return $value unless ref $value;
+
+ my $file = $self->_fs_column_storage($column);
+ if ( $value ne $file ) {
+ File::Path::mkpath([$file->dir]);
+
+ # get a filehandle if we were passed a Path::Class::File
+ my $fh1 = eval { $value->openr } || $value;
+ my $fh2 = $file->openw or die;
+ File::Copy::copy($fh1, $fh2);
+
+ # force re-inflation on next access
+ delete $self->{_inflated_column}{$column};
+ }
+ my $basename = $file->basename;
+ return File::Spec->catfile($self->_fs_column_dirs($basename), $basename);
+}
+
+=head2 table
+
+Overridden to provide a hook for specifying the resultset_class. If
+you provide your own resultset_class, inherit from
+InflateColumn::FS::ResultSet.
+
+=cut
+
+sub table {
+ my $self = shift;
+
+ my $ret = $self->next::method(@_);
+ if ( @_ && $self->result_source_instance->resultset_class eq 'DBIx::Class::ResultSet' ) {
+ $self->result_source_instance->resultset_class('DBIx::Class::InflateColumn::FS::ResultSet');
+ }
+ return $ret;
+}
+
+=head1 AUTHOR
+
+Marc Mims <marc at questright.com>
+
+=head1 LICENSE
+
+You may distribute this code under the same terms as Perl itself.
+
+=cut
+
+1;
Added: DBIx-Class-InflateColumn-FS/1.000/trunk/t/00-load.t
===================================================================
--- DBIx-Class-InflateColumn-FS/1.000/trunk/t/00-load.t (rev 0)
+++ DBIx-Class-InflateColumn-FS/1.000/trunk/t/00-load.t 2008-10-05 18:47:40 UTC (rev 4883)
@@ -0,0 +1,7 @@
+use warnings;
+use strict;
+use Test::More tests => 1;
+
+BEGIN {
+ use_ok('DBIx::Class::InflateColumn::FS');
+}
Added: DBIx-Class-InflateColumn-FS/1.000/trunk/t/01-schema.t
===================================================================
--- DBIx-Class-InflateColumn-FS/1.000/trunk/t/01-schema.t (rev 0)
+++ DBIx-Class-InflateColumn-FS/1.000/trunk/t/01-schema.t 2008-10-05 18:47:40 UTC (rev 4883)
@@ -0,0 +1,74 @@
+use warnings;
+use strict;
+use DBICx::TestDatabase;
+use Test::More tests => 13;
+use Path::Class qw/file/;
+use File::Compare;
+use lib qw(t/lib);
+
+my $schema = DBICx::TestDatabase->new('My::TestSchema');
+my $rs = $schema->resultset('Book');
+
+# we'll use *this* file as our content
+# TODO: Copy it or create something else so errant tests don't inadvertently
+# delete it!
+my $file = file($0);
+
+my $book = $rs->create({
+ name => 'Alice in Wonderland',
+ cover_image => $file,
+});
+
+isa_ok( $book->cover_image, 'Path::Class::File' );
+isnt( $book->cover_image, $file, 'storage is a different file' );
+ok( compare($book->cover_image, $file) == 0, 'file contents equivalent');
+
+# setting a file to itself should be a no-op
+my $storage = Path::Class::File->new($book->cover_image);
+$book->update({ cover_image => $storage });
+
+is( $storage, $book->cover_image, 'setting storage to self' );
+
+# deleting the row should delete the associated file
+$book->delete;
+ok( ! -e $storage, 'file successfully deleted' );
+
+# multiple rows
+my ($book1, $book2) = map {
+ $rs->create({ name => $_, cover_image => $file })
+} qw/Book1 Book2/;
+
+isnt( $book1->cover_image, $book2->cover_image, 'rows have different storage' );
+
+$rs->delete;
+ok ( ! -e $book1->cover_image, "storage deleted for row 1" );
+ok ( ! -e $book2->cover_image, "storage deleted for row 2" );
+
+
+# null fs_column
+$book = $rs->create({ name => 'No cover image', cover_image => undef });
+
+ok ( !defined $book->cover_image, 'null fs_column' );
+
+
+# file handle
+open my $fh, '<', $0 or die "failed to open $0 for read: $!\n";
+
+$book->cover_image($fh);
+$book->update;
+close $fh or die;
+
+ok( compare($book->cover_image, $0) == 0, 'store from filehandle' );
+
+# setting fs_column to null should delete storage
+$book = $rs->create({ name => 'Here today, gone tomorrow',
+ cover_image => $file });
+$storage = $book->cover_image;
+ok( -e $storage, 'storage exists before nulling' );
+$book->update({ cover_image => undef });
+ok( ! -e $storage, 'does not exist after nulling' );
+
+$book->update({ cover_image => $file });
+$book->update({ id => 999 });
+$book->discard_changes;
+ok( -e $book->cover_image, 'storage renamed on PK change' );
Added: DBIx-Class-InflateColumn-FS/1.000/trunk/t/03podcoverage.t
===================================================================
--- DBIx-Class-InflateColumn-FS/1.000/trunk/t/03podcoverage.t (rev 0)
+++ DBIx-Class-InflateColumn-FS/1.000/trunk/t/03podcoverage.t 2008-10-05 18:47:40 UTC (rev 4883)
@@ -0,0 +1,16 @@
+use Test::More;
+
+eval "use Pod::Coverage 0.19";
+plan skip_all => 'Pod::Coverage 0.19 required' if $@;
+eval "use Test::Pod::Coverage 1.04";
+plan skip_all => 'Test::Pod::Coverage 1.04 required' if $@;
+
+plan skip_all => 'set TEST_POD to enable this test'
+ unless ($ENV{TEST_POD} || -e 'MANIFEST.SKIP');
+
+my @modules = sort { $a cmp $b } (Test::Pod::Coverage::all_modules());
+plan tests => scalar(@modules);
+
+foreach my $module (@modules) {
+ pod_coverage_ok($module, "$module POD coverage");
+}
Added: DBIx-Class-InflateColumn-FS/1.000/trunk/t/lib/My/TestSchema/Author.pm
===================================================================
--- DBIx-Class-InflateColumn-FS/1.000/trunk/t/lib/My/TestSchema/Author.pm (rev 0)
+++ DBIx-Class-InflateColumn-FS/1.000/trunk/t/lib/My/TestSchema/Author.pm 2008-10-05 18:47:40 UTC (rev 4883)
@@ -0,0 +1,28 @@
+package # hide from PAUSE
+ My::TestSchema::Author;
+use warnings;
+use strict;
+use base qw/DBIx::Class/;
+use File::Temp qw/tempdir/;
+
+__PACKAGE__->load_components(qw/InflateColumn::FS Core/);
+__PACKAGE__->table('author');
+__PACKAGE__->add_columns(
+ id => {
+ data_type => 'INT',
+ is_auto_increment => 1,
+ },
+ name => {
+ data_type => 'VARCHAR',
+ size => 60,
+ },
+ photo => {
+ data_type => 'TEXT',
+ is_nullable => 1,
+ is_fs_column => 1,
+ fs_column_path => tempdir(CLEANUP => 1),
+ },
+);
+__PACKAGE__->set_primary_key(qw/id/);
+
+1;
Added: DBIx-Class-InflateColumn-FS/1.000/trunk/t/lib/My/TestSchema/Book.pm
===================================================================
--- DBIx-Class-InflateColumn-FS/1.000/trunk/t/lib/My/TestSchema/Book.pm (rev 0)
+++ DBIx-Class-InflateColumn-FS/1.000/trunk/t/lib/My/TestSchema/Book.pm 2008-10-05 18:47:40 UTC (rev 4883)
@@ -0,0 +1,28 @@
+package # hide from PAUSE
+ My::TestSchema::Book;
+use warnings;
+use strict;
+use base qw/DBIx::Class/;
+use File::Temp qw/tempdir/;
+
+__PACKAGE__->load_components(qw/InflateColumn::FS Core/);
+__PACKAGE__->table('book');
+__PACKAGE__->add_columns(
+ id => {
+ data_type => 'INT',
+ is_auto_increment => 1,
+ },
+ name => {
+ data_type => 'VARCHAR',
+ size => 60,
+ },
+ cover_image => {
+ data_type => 'TEXT',
+ is_nullable => 1,
+ is_fs_column => 1,
+ fs_column_path => tempdir(CLEANUP => 1),
+ },
+);
+__PACKAGE__->set_primary_key(qw/id/);
+
+1;
Added: DBIx-Class-InflateColumn-FS/1.000/trunk/t/lib/My/TestSchema.pm
===================================================================
--- DBIx-Class-InflateColumn-FS/1.000/trunk/t/lib/My/TestSchema.pm (rev 0)
+++ DBIx-Class-InflateColumn-FS/1.000/trunk/t/lib/My/TestSchema.pm 2008-10-05 18:47:40 UTC (rev 4883)
@@ -0,0 +1,9 @@
+package # hide from PAUSE
+ My::TestSchema;
+use warnings;
+use strict;
+use base qw/DBIx::Class::Schema/;
+
+__PACKAGE__->load_classes;
+
+1;
More information about the Bast-commits
mailing list