lib/DBIx/Class/CDBICompat/ColumnsAsHash.pm

   1 package
   2     DBIx::Class::CDBICompat::ColumnsAsHash;
   3
   4 use strict;
   5 use warnings;
   6
   7
   8 =head1 NAME
   9
  10 DBIx::Class::CDBICompat::ColumnsAsHash
  11
  12 =head1 SYNOPSIS
  13
  14 See DBIx::Class::CDBICompat for directions for use.
  15
  16 =head1 DESCRIPTION
  17
  18 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.
  19
  20     my $column = $row->{column};
  21
  22 =head2 Differences from Class::DBI
  23
  24 This will warn when a column is accessed as a hash key.
  25
  26 =cut
  27
  28 sub new {
  29     my $class = shift;
  30
  31     my $new = $class->next::method(@_);
  32
  33     $new->_make_columns_as_hash;
  34
  35     return $new;
  36 }
  37
  38 sub inflate_result {
  39     my $class = shift;
  40
  41     my $new = $class->next::method(@_);
  42
  43     $new->_make_columns_as_hash;
  44
  45     return $new;
  46 }
  47
  48
  49 sub _make_columns_as_hash {
  50     my $self = shift;
  51
  52     for my $col ($self->columns) {
  53         if( exists $self->{$col} ) {
  54             warn "Skipping mapping $col to a hash key because it exists";
  55         }
  56
  57         next unless $self->can($col);
  58         tie $self->{$col}, 'DBIx::Class::CDBICompat::Tied::ColumnValue',
  59             $self, $col;
  60     }
  61 }
  62
  63
  64 package DBIx::Class::CDBICompat::Tied::ColumnValue;
  65
  66 use Carp;
  67 use Scalar::Util qw(weaken isweak);
  68
  69
  70 sub TIESCALAR {
  71     my($class, $obj, $col) = @_;
  72     my $self = [$obj, $col];
  73     weaken $self->[0];
  74
  75     return bless $self, $_[0];
  76 }
  77
  78 sub FETCH {
  79     my $self = shift;
  80     my($obj, $col) = @$self;
  81
  82     my $class = ref $obj;
  83     my $id    = $obj->id;
  84     carp "Column '$col' of '$class/$id' was fetched as a hash";
  85
  86     return $obj->$col();
  87 }
  88
  89 sub STORE {
  90     my $self = shift;
  91     my($obj, $col) = @$self;
  92
  93     my $class = ref $obj;
  94     my $id    = $obj->id;
  95     carp "Column '$col' of '$class/$id' was stored as a hash";
  96
  97     $obj->$col(shift);
  98 }
  99
 100 1;