From: Michael G Schwern <mschwern@cpan.org>
Date: Wed, 16 Jan 2008 05:56:23 +0000 (-0800)
Subject: mst pointed out that my $val = $obj->{col};  $obj->col(23); print $val; will reflect... 
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=ebe790dbc130d3604bb07e9636ff0458f8b464a9;p=dbsrgits%2FDBIx-Class-Historic.git

mst pointed out that my $val = $obj->{col};  $obj->col(23); print $val; will reflect the change because of the deferring.  Using a tied scalar as the value is much, much simpler.
---

diff --git a/lib/DBIx/Class/CDBICompat/ColumnsAsHash.pm b/lib/DBIx/Class/CDBICompat/ColumnsAsHash.pm
index 62f4773..9f265d6 100644
--- a/lib/DBIx/Class/CDBICompat/ColumnsAsHash.pm
+++ b/lib/DBIx/Class/CDBICompat/ColumnsAsHash.pm
@@ -4,10 +4,6 @@ package
 use strict;
 use warnings;
 
-use Scalar::Defer;
-use Scalar::Util qw(weaken);
-use Carp;
-
 
 =head1 NAME
 
@@ -53,56 +49,52 @@ sub inflate_result {
 sub _make_columns_as_hash {
     my $self = shift;
     
-    weaken $self;
     for my $col ($self->columns) {
         if( exists $self->{$col} ) {
             warn "Skipping mapping $col to a hash key because it exists";
         }
 
         next unless $self->can($col);
-        $self->{$col} = defer {
-            my $class = ref $self;
-            carp "Column '$col' of '$class/$self' was accessed as a hash";
-            $self->$col();
-        };
+        tie $self->{$col}, 'DBIx::Class::CDBICompat::Tied::ColumnValue',
+            $self, $col;
     }
 }
 
-sub update {
-    my $self = shift;
-    
-    for my $col ($self->columns) {
-        if( $self->_hash_changed($col) ) {
-            my $class = ref $self;
-            carp "Column '$col' of '$class/$self' was updated as a hash";
-            $self->$col($self->_get_column_from_hash($col));
-            $self->{$col} = defer { $self->$col() };
-        }
-    }
-    
-    return $self->next::method(@_);
+
+package DBIx::Class::CDBICompat::Tied::ColumnValue;
+
+use Carp;
+use Scalar::Util qw(weaken isweak);
+
+
+sub TIESCALAR {
+    my($class, $obj, $col) = @_;
+    my $self = [$obj, $col];
+    weaken $self->[0];
+
+    return bless $self, $_[0];
 }
 
-sub _hash_changed {
-    my($self, $col) = @_;
-    
-    return 0 unless exists $self->{$col};
-    
-    my $hash = $self->_get_column_from_hash($col);
-    my $obj  = $self->$col();
+sub FETCH {
+    my $self = shift;
+    my($obj, $col) = @$self;
 
-    return 1 if defined $hash xor defined $obj;
-    return 0 if !defined $hash and !defined $obj;
-    return 1 if $hash ne $obj;
-    return 0;
+    my $class = ref $obj;
+    my $id    = $obj->id;
+    carp "Column '$col' of '$class/$id' was fetched as a hash";
+
+    return $obj->$col();
 }
 
-# get the column value without a warning
-sub _get_column_from_hash {
-    my($self, $col) = @_;
-    
-    local $SIG{__WARN__} = sub {};
-    return force $self->{$col};
+sub STORE {
+    my $self = shift;
+    my($obj, $col) = @$self;
+
+    my $class = ref $obj;
+    my $id    = $obj->id;
+    carp "Column '$col' of '$class/$id' was stored as a hash";
+
+    $obj->$col(shift);
 }
 
 1;
diff --git a/t/cdbi-t/columns_as_hashes.t b/t/cdbi-t/columns_as_hashes.t
index 8b84337..5a5811f 100644
--- a/t/cdbi-t/columns_as_hashes.t
+++ b/t/cdbi-t/columns_as_hashes.t
@@ -7,7 +7,7 @@ use Test::Warn;
 BEGIN {
   eval "use DBIx::Class::CDBICompat;";
   plan $@ ? (skip_all => "Class::Trigger and DBIx::ContextualFetch required: $@")
-          : (tests=> 6);
+          : (tests=> 8);
 }
 
 use lib 't/testlib';
@@ -20,20 +20,26 @@ my $waves = Film->insert({
 });
 
 warnings_like {
+    my $rating = $waves->{rating};
+    $waves->Rating("PG");
+    is $rating, "R", 'evaluation of column value is not deferred';
+} qr{^Column 'rating' of 'Film/$waves' was fetched as a hash at \Q$0};
+
+warnings_like {
     is $waves->{title}, $waves->Title, "columns can be accessed as hashes";
-} qr{^Column 'title' of 'Film/$waves' was accessed as a hash at .*$};
+} qr{^Column 'title' of 'Film/$waves' was fetched as a hash at\b};
 
 $waves->Rating("G");
 
 warnings_like {
     is $waves->{rating}, "G", "updating via the accessor updates the hash";
-} qr{^Column 'rating' of 'Film/$waves' was accessed as a hash .*$};
+} qr{^Column 'rating' of 'Film/$waves' was fetched as a hash at\b};
 
-$waves->{rating} = "PG";
 
 warnings_like {
-    $waves->update;
-} qr{^Column 'rating' of 'Film/$waves' was updated as a hash .*$};
+    $waves->{rating} = "PG";
+} qr{^Column 'rating' of 'Film/$waves' was stored as a hash at\b};
 
+$waves->update;
 my @films = Film->search( Rating => "PG", Title => "Breaking the Waves" );
 is @films, 1, "column updated as hash was saved";