[Bast-commits] r5891 - in DBIx-Class-InflateColumn-FS/1.000/trunk: . lib/DBIx/Class/InflateColumn t

[semifor at dev.catalyst.perl.org]

Author: semifor
Date: 2009-04-18 00:25:03 +0100 (Sat, 18 Apr 2009)
New Revision: 5891

Modified:
   DBIx-Class-InflateColumn-FS/1.000/trunk/Changes
   DBIx-Class-InflateColumn-FS/1.000/trunk/lib/DBIx/Class/InflateColumn/FS.pm
   DBIx-Class-InflateColumn-FS/1.000/trunk/t/01-fs_columns.t
Log:
Fixed new 'copy' method and infinite recursion on create with fs_new_on_update column(s)

Modified: DBIx-Class-InflateColumn-FS/1.000/trunk/Changes
===================================================================
--- DBIx-Class-InflateColumn-FS/1.000/trunk/Changes	2009-04-17 08:10:19 UTC (rev 5890)
+++ DBIx-Class-InflateColumn-FS/1.000/trunk/Changes	2009-04-17 23:25:03 UTC (rev 5891)
@@ -1,4 +1,6 @@
-0.01003 2009-04-16
+0.01003 2009-04-17
+    - use DBIx::Class::UUIDColumns for get_uuid rather than inheriting from it
+    - fixed infinite recursion on create with fs_new_on_update column(s)
     - added copy method
 
 0.01002 2009-03-17

Modified: 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	2009-04-17 08:10:19 UTC (rev 5890)
+++ DBIx-Class-InflateColumn-FS/1.000/trunk/lib/DBIx/Class/InflateColumn/FS.pm	2009-04-17 23:25:03 UTC (rev 5891)
@@ -2,7 +2,7 @@
 
 use strict;
 use warnings;
-use base 'DBIx::Class::UUIDColumns';
+use DBIx::Class::UUIDColumns;
 use File::Spec;
 use File::Path;
 use File::Copy ();
@@ -95,7 +95,7 @@
 
 sub fs_file_name {
     my ($self, $column, $column_info) = @_;
-    return $self->get_uuid;
+    return DBIx::Class::UUIDColumns->get_uuid;
 }
 
 sub _fs_column_storage {
@@ -142,27 +142,25 @@
     my ($self, $changes) = @_;
 
     $changes ||= {};
-    my $col_data     = { %{$self->{_column_data}}     };
-    my $inflated_col = { %{$self->{_inflated_column}} };
+    my $col_data     = { %{$self->{_column_data}} };
 
     foreach my $col ( keys %$col_data ) {
         my $column_info = $self->result_source->column_info($col);
         if ( $column_info->{is_fs_column}
-             && defined $col_data->{$col}  # nothing special required for NULLs
-             && !exists $changes->{$col} ) {
+             && defined $col_data->{$col} ) {  # nothing special required for NULLs
             $col_data->{$col} = undef;
             
             # pass the original file to produce a copy on deflate
             my $accessor = $column_info->{accessor} || $col;
-            $changes->{$col} = $self->$accessor;
-
-            delete $inflated_col->{$col};
+            $changes->{$col} ||= $self->$accessor;
         }
     }
 
-    my $copy = bless { %$self, _column_data => $col_data, _inflated_column => $inflated_col }, ref $self;
-    $copy = $copy->next::method($changes);
+    my $temp = bless { _column_data => $col_data }, ref $self;
+    $temp->result_source($self->result_source);
 
+    my $copy = $temp->next::method($changes);
+
     # force reinflation of fs colmuns on next access
     delete $copy->{_inflated_column}{$_}
         for grep { $self->result_source->column_info($_)->{is_fs_column} }
@@ -254,7 +252,7 @@
     my $fs_new_on_update = $self->result_source->column_info($column)->{fs_new_on_update};
     my $file = $self->_fs_column_storage($column, 1);
     
-    if ( $fs_new_on_update && (my $oldfile = $self->get_column($column)) ) {
+    if ( $fs_new_on_update && (my $oldfile = $self->{_column_data}{$column}) ) {
         my $column_info = $self->result_source->column_info($column);
         Path::Class::File->new($column_info->{fs_column_path}, $oldfile)->remove;
     }

Modified: DBIx-Class-InflateColumn-FS/1.000/trunk/t/01-fs_columns.t
===================================================================
--- DBIx-Class-InflateColumn-FS/1.000/trunk/t/01-fs_columns.t	2009-04-17 08:10:19 UTC (rev 5890)
+++ DBIx-Class-InflateColumn-FS/1.000/trunk/t/01-fs_columns.t	2009-04-17 23:25:03 UTC (rev 5891)
@@ -1,8 +1,8 @@
-#!perl -wT
+#!perl -w
 use warnings;
 use strict;
 use DBICx::TestDatabase;
-use Test::More tests => 15;
+use Test::More tests => 19;
 use Path::Class qw/file/;
 use File::Compare;
 use lib qw(t/lib);
@@ -74,6 +74,28 @@
 $book->discard_changes;
 ok( -e $book->cover_image, 'storage renamed on PK change' );
 
+#--------------------------------- test copy ---------------------------------
+my $orig_column_data = { %{$book->{_column_data}} };
 my $copy = $book->copy;
 isnt( $copy->cover_image, $book->cover_image, 'copy has its own file backing' );
 ok( compare($copy->cover_image, $book->cover_image) == 0, 'copy contents correct' );
+
+# an update of book shouldn't change the source's _column_data
+is_deeply ( $book->{_column_data}, $orig_column_data, 'copy source unchanged' );
+
+# Regression test (failed on a prior implementation of copy)
+$book = $rs->find({ id => 1, });
+ok( eval{ $copy = $book->copy }, 'copy works with selected elements' );
+
+#----------------------------- infinite recursion ----------------------------
+$book = $rs->create({
+    name          => 'The Never Ending Story',
+    cover_image   => $file,
+    cover_image_2 => $file,
+});
+
+my $cover_image = $book->cover_image->stringify;
+my $cover_image_2 = $book->cover_image->stringify;
+$book->update({ cover_image => $file, cover_image_2 => $file });
+is( $book->cover_image, $cover_image, 'backing filename did not change' );
+isnt( $book->cover_image_2, $cover_image_2, 'backing filename did change for fs_new_on_update column' );