Allow CDBI objects to be accessed like hashes as people tend to do for

performance reasons.

diff --git a/lib/DBIx/Class/CDBICompat.pm b/lib/DBIx/Class/CDBICompat.pm
index 750b19c..74504b6 100644 (file)
--- a/lib/DBIx/Class/CDBICompat.pm
+++ b/lib/DBIx/Class/CDBICompat.pm
@@ -33,6 +33,7 @@ __PACKAGE__->load_own_components(qw/
   Retrieve
   Pager
   ColumnGroups
+  ColumnsAsHash
   AbstractSearch
   ImaDBI
   Iterator

diff --git a/lib/DBIx/Class/CDBICompat/ColumnsAsHash.pm b/lib/DBIx/Class/CDBICompat/ColumnsAsHash.pm
new file mode 100644 (file)
index 0000000..62f4773
--- /dev/null
+++ b/lib/DBIx/Class/CDBICompat/ColumnsAsHash.pm
@@ -0,0 +1,108 @@
+package
+    DBIx::Class::CDBICompat::ColumnsAsHash;
+
+use strict;
+use warnings;
+
+use Scalar::Defer;
+use Scalar::Util qw(weaken);
+use Carp;
+
+
+=head1 NAME
+
+DBIx::Class::CDBICompat::ColumnsAsHash
+
+=head1 SYNOPSIS
+
+See DBIx::Class::CDBICompat for directions for use.
+
+=head1 DESCRIPTION
+
+Emulates the I<undocumnted> behavior of Class::DBI where the object can be accessed as a hash of columns.  This is often used as a performance hack.
+
+    my $column = $row->{column};
+
+=head2 Differences from Class::DBI
+
+This will warn when a column is accessed as a hash key.
+
+=cut
+
+sub new {
+    my $class = shift;
+
+    my $new = $class->next::method(@_);
+
+    $new->_make_columns_as_hash;
+
+    return $new;
+}
+
+sub inflate_result {
+    my $class = shift;
+
+    my $new = $class->next::method(@_);
+    
+    $new->_make_columns_as_hash;
+    
+    return $new;
+}
+
+
+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();
+        };
+    }
+}
+
+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(@_);
+}
+
+sub _hash_changed {
+    my($self, $col) = @_;
+    
+    return 0 unless exists $self->{$col};
+    
+    my $hash = $self->_get_column_from_hash($col);
+    my $obj  = $self->$col();
+
+    return 1 if defined $hash xor defined $obj;
+    return 0 if !defined $hash and !defined $obj;
+    return 1 if $hash ne $obj;
+    return 0;
+}
+
+# get the column value without a warning
+sub _get_column_from_hash {
+    my($self, $col) = @_;
+    
+    local $SIG{__WARN__} = sub {};
+    return force $self->{$col};
+}
+
+1;

diff --git a/t/03podcoverage.t b/t/03podcoverage.t
index b9831ce..e8c0a0c 100644 (file)
--- a/t/03podcoverage.t
+++ b/t/03podcoverage.t
@@ -37,6 +37,9 @@ my $exceptions = {
     },
     'DBIx::Class::CDBICompat::AttributeAPI'             => { skip => 1 },
     'DBIx::Class::CDBICompat::AutoUpdate'               => { skip => 1 },
+    'DBIx::Class::CDBICompat::ColumnsAsHash' => {
+        ignore => [qw(inflate_result new update)]
+    },
     'DBIx::Class::CDBICompat::ColumnCase'               => { skip => 1 },
     'DBIx::Class::CDBICompat::ColumnGroups'             => { skip => 1 },
     'DBIx::Class::CDBICompat::Constraints'              => { skip => 1 },

diff --git a/t/cdbi-t/columns_as_hashes.t b/t/cdbi-t/columns_as_hashes.t
new file mode 100644 (file)
index 0000000..8b84337
--- /dev/null
+++ b/t/cdbi-t/columns_as_hashes.t
@@ -0,0 +1,39 @@
+#!/usr/bin/perl -w
+
+use strict;
+use Test::More;
+use Test::Warn;
+
+BEGIN {
+  eval "use DBIx::Class::CDBICompat;";
+  plan $@ ? (skip_all => "Class::Trigger and DBIx::ContextualFetch required: $@")
+          : (tests=> 6);
+}
+
+use lib 't/testlib';
+use Film;
+
+my $waves = Film->insert({
+    Title     => "Breaking the Waves",
+    Director  => 'Lars von Trier',
+    Rating    => 'R'
+});
+
+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 .*$};
+
+$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 .*$};
+
+$waves->{rating} = "PG";
+
+warnings_like {
+    $waves->update;
+} qr{^Column 'rating' of 'Film/$waves' was updated as a hash .*$};
+
+my @films = Film->search( Rating => "PG", Title => "Breaking the Waves" );
+is @films, 1, "column updated as hash was saved";