lib/DBIx/Class/Row.pm

   1 package DBIx::Class::Row;
   2
   3 use strict;
   4 use warnings;
   5
   6 =head1 NAME
   7
   8 DBIx::Class::Row - Basic row methods
   9
  10 =head1 SYNOPSIS
  11
  12 =head1 DESCRIPTION
  13
  14 This class is responsible for defining and doing basic operations on rows
  15 derived from L<DBIx::Class::Table> objects.
  16
  17 =head1 METHODS
  18
  19 =over 4
  20
  21 =item new
  22
  23   my $obj = My::Class->new($attrs);
  24
  25 Creates a new row object from column => value mappings passed as a hash ref
  26
  27 =cut
  28
  29 sub new {
  30   my ($class, $attrs) = @_;
  31   $class = ref $class if ref $class;
  32   my $new = bless({ _column_data => { } }, $class);
  33   if ($attrs) {
  34     $new->throw("attrs must be a hashref" ) unless ref($attrs) eq 'HASH';
  35     while (my ($k, $v) = each %{$attrs}) {
  36       $new->store_column($k => $v) if exists $class->_columns->{$k};
  37     }
  38   }
  39   return $new;
  40 }
  41
  42 =item insert
  43
  44   $obj->insert;
  45
  46 Inserts an object into the database if it isn't already in there. Returns
  47 the object itself.
  48
  49 =cut
  50
  51 sub insert {
  52   my ($self) = @_;
  53   return $self if $self->in_storage;
  54   #use Data::Dumper; warn Dumper($self);
  55   my %in;
  56   $in{$_} = $self->get_column($_)
  57     for grep { defined $self->get_column($_) } $self->columns;
  58   my %out = %{ $self->storage->insert($self->_table_name, \%in) };
  59   $self->store_column($_, $out{$_})
  60     for grep { $self->get_column($_) ne $out{$_} } keys %out;
  61   $self->in_storage(1);
  62   $self->{_dirty_columns} = {};
  63   return $self;
  64 }
  65
  66 =item in_storage
  67
  68   $obj->in_storage; # Get value
  69   $obj->in_storage(1); # Set value
  70
  71 Indicated whether the object exists as a row in the database or not
  72
  73 =cut
  74
  75 sub in_storage {
  76   my ($self, $val) = @_;
  77   $self->{_in_storage} = $val if @_ > 1;
  78   return $self->{_in_storage};
  79 }
  80
  81 =item create
  82
  83   my $new = My::Class->create($attrs);
  84
  85 A shortcut for My::Class->new($attrs)->insert;
  86
  87 =cut
  88
  89 sub create {
  90   my ($class, $attrs) = @_;
  91   $class->throw( "create needs a hashref" ) unless ref $attrs eq 'HASH';
  92   return $class->new($attrs)->insert;
  93 }
  94
  95 =item update
  96
  97   $obj->update;
  98
  99 Must be run on an object that is already in the database; issues an SQL
 100 UPDATE query to commit any changes to the object to the db if required.
 101
 102 =cut
 103
 104 sub update {
 105   my ($self, $upd) = @_;
 106   $self->throw( "Not in database" ) unless $self->in_storage;
 107   if (ref $upd eq 'HASH') {
 108     $self->$_($upd->{$_}) for keys %$upd;
 109   }
 110   my %to_update;
 111   $to_update{$_} = $self->get_column($_) for $self->is_changed;
 112   return -1 unless keys %to_update;
 113   my $rows = $self->storage->update($self->_table_name, \%to_update,
 114                                       $self->ident_condition);
 115   if ($rows == 0) {
 116     $self->throw( "Can't update ${self}: row not found" );
 117   } elsif ($rows > 1) {
 118     $self->throw("Can't update ${self}: updated more than one row");
 119   }
 120   $self->{_dirty_columns} = {};
 121   return $self;
 122 }
 123
 124 sub ident_condition {
 125   my ($self) = @_;
 126   my %cond;
 127   $cond{$_} = $self->get_column($_) for keys %{$self->_primaries};
 128   return \%cond;
 129 }
 130
 131 =item delete
 132
 133   $obj->delete
 134
 135 Deletes the object from the database. The object is still perfectly usable
 136 accessor-wise etc. but ->in_storage will now return 0 and the object must
 137 be re ->insert'ed before it can be ->update'ed
 138
 139 =cut
 140
 141 sub delete {
 142   my $self = shift;
 143   if (ref $self) {
 144     $self->throw( "Not in database" ) unless $self->in_storage;
 145     #warn $self->_ident_cond.' '.join(', ', $self->_ident_values);
 146     $self->storage->delete($self->_table_name, $self->ident_condition);
 147     $self->in_storage(undef);
 148     #$self->store_column($_ => undef) for $self->primary_columns;
 149       # Should probably also arrange to trash PK if auto
 150       # but if we do, post-delete cascade triggers fail :/
 151   } else {
 152     my $attrs = { };
 153     if (@_ > 1 && ref $_[$#_] eq 'HASH') {
 154       $attrs = { %{ pop(@_) } };
 155     }
 156     my $query = (ref $_[0] eq 'HASH' ? $_[0] : {@_});
 157     $self->storage->delete($self->_table_name, $query);
 158   }
 159   return $self;
 160 }
 161
 162 =item get_column
 163
 164   my $val = $obj->get_column($col);
 165
 166 Fetches a column value
 167
 168 =cut
 169
 170 sub get_column {
 171   my ($self, $column) = @_;
 172   $self->throw( "Can't fetch data as class method" ) unless ref $self;
 173   $self->throw( "No such column '${column}'" ) unless $self->_columns->{$column};
 174   return $self->{_column_data}{$column}
 175     if exists $self->{_column_data}{$column};
 176   return undef;
 177 }
 178
 179 =item set_column
 180
 181   $obj->set_column($col => $val);
 182
 183 Sets a column value; if the new value is different to the old the column
 184 is marked as dirty for when you next call $obj->update
 185
 186 =cut
 187
 188 sub set_column {
 189   my $self = shift;
 190   my ($column) = @_;
 191   my $old = $self->get_column($column);
 192   my $ret = $self->store_column(@_);
 193   $self->{_dirty_columns}{$column} = 1 unless defined $old && $old eq $ret;
 194   return $ret;
 195 }
 196
 197 =item store_column
 198
 199   $obj->store_column($col => $val);
 200
 201 Sets a column value without marking it as dirty
 202
 203 =cut
 204
 205 sub store_column {
 206   my ($self, $column, $value) = @_;
 207   $self->throw( "No such column '${column}'" )
 208     unless $self->_columns->{$column};
 209   $self->throw( "set_column called for ${column} without value" )
 210     if @_ < 3;
 211   return $self->{_column_data}{$column} = $value;
 212 }
 213
 214 sub _row_to_object {
 215   my ($class, $cols, $row) = @_;
 216   my %vals;
 217   $vals{$cols->[$_]} = $row->[$_] for 0 .. $#$cols;
 218   my $new = $class->new(\%vals);
 219   $new->in_storage(1);
 220   return $new;
 221 }
 222
 223 =item copy
 224
 225   my $copy = $orig->copy({ change => $to, ... });
 226
 227 =cut
 228
 229 sub copy {
 230   my ($self, $changes) = @_;
 231   my $new = bless({ _column_data => { %{$self->{_column_data}}} }, ref $self);
 232   $new->set_column($_ => $changes->{$_}) for keys %$changes;
 233   return $new->insert;
 234 }
 235
 236 =item insert_or_update
 237
 238   $obj->insert_or_update
 239
 240 Updates the object if it's already in the db, else inserts it
 241
 242 =cut
 243
 244 sub insert_or_update {
 245   my $self = shift;
 246   return ($self->in_storage ? $self->update : $self->insert);
 247 }
 248
 249 =item is_changed
 250
 251   my @changed_col_names = $obj->is_changed
 252
 253 =cut
 254
 255 sub is_changed {
 256   return keys %{shift->{_dirty_columns} || {}};
 257 }
 258
 259 1;
 260
 261 =back
 262
 263 =head1 AUTHORS
 264
 265 Matt S. Trout <mst@shadowcatsystems.co.uk>
 266
 267 =head1 LICENSE
 268
 269 You may distribute this code under the same terms as Perl itself.
 270
 271 =cut
 272