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);
  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   my %to_update = %{$upd || {}};
 108   $to_update{$_} = $self->get_column($_) for $self->is_changed;
 109   return -1 unless keys %to_update;
 110   my $rows = $self->storage->update($self->_table_name, \%to_update,
 111                                       $self->ident_condition);
 112   if ($rows == 0) {
 113     $self->throw( "Can't update ${self}: row not found" );
 114   } elsif ($rows > 1) {
 115     $self->throw("Can't update ${self}: updated more than one row");
 116   }
 117   $self->{_dirty_columns} = {};
 118   return $self;
 119 }
 120
 121 sub ident_condition {
 122   my ($self) = @_;
 123   my %cond;
 124   $cond{$_} = $self->get_column($_) for keys %{$self->_primaries};
 125   return \%cond;
 126 }
 127
 128 =item delete
 129
 130   $obj->delete
 131
 132 Deletes the object from the database. The object is still perfectly usable
 133 accessor-wise etc. but ->in_storage will now return 0 and the object must
 134 be re ->insert'ed before it can be ->update'ed
 135
 136 =cut
 137
 138 sub delete {
 139   my $self = shift;
 140   if (ref $self) {
 141     $self->throw( "Not in database" ) unless $self->in_storage;
 142     #warn $self->_ident_cond.' '.join(', ', $self->_ident_values);
 143     $self->storage->delete($self->_table_name, $self->ident_condition);
 144     $self->in_storage(undef);
 145     #$self->store_column($_ => undef) for $self->primary_columns;
 146       # Should probably also arrange to trash PK if auto
 147       # but if we do, post-delete cascade triggers fail :/
 148   } else {
 149     my $attrs = { };
 150     if (@_ > 1 && ref $_[$#_] eq 'HASH') {
 151       $attrs = { %{ pop(@_) } };
 152     }
 153     my $query = (ref $_[0] eq 'HASH' ? $_[0] : {@_});
 154     $self->storage->delete($self->_table_name, $query);
 155   }
 156   return $self;
 157 }
 158
 159 =item get_column
 160
 161   my $val = $obj->get_column($col);
 162
 163 Fetches a column value
 164
 165 =cut
 166
 167 sub get_column {
 168   my ($self, $column) = @_;
 169   $self->throw( "Can't fetch data as class method" ) unless ref $self;
 170   $self->throw( "No such column '${column}'" ) unless $self->_columns->{$column};
 171   return $self->{_column_data}{$column}
 172     if exists $self->{_column_data}{$column};
 173   return undef;
 174 }
 175
 176 =item set_column
 177
 178   $obj->set_column($col => $val);
 179
 180 Sets a column value; if the new value is different to the old the column
 181 is marked as dirty for when you next call $obj->update
 182
 183 =cut
 184
 185 sub set_column {
 186   my $self = shift;
 187   my ($column) = @_;
 188   my $old = $self->get_column($column);
 189   my $ret = $self->store_column(@_);
 190   $self->{_dirty_columns}{$column} = 1 unless defined $old && $old eq $ret;
 191   return $ret;
 192 }
 193
 194 =item store_column
 195
 196   $obj->store_column($col => $val);
 197
 198 Sets a column value without marking it as dirty
 199
 200 =cut
 201
 202 sub store_column {
 203   my ($self, $column, $value) = @_;
 204   $self->throw( "No such column '${column}'" )
 205     unless $self->_columns->{$column};
 206   $self->throw( "set_column called for ${column} without value" )
 207     if @_ < 3;
 208   return $self->{_column_data}{$column} = $value;
 209 }
 210
 211 sub _row_to_object {
 212   my ($class, $cols, $row) = @_;
 213   my %vals;
 214   $vals{$cols->[$_]} = $row->[$_] for 0 .. $#$cols;
 215   my $new = $class->new(\%vals);
 216   $new->in_storage(1);
 217   return $new;
 218 }
 219
 220 =item copy
 221
 222   my $copy = $orig->copy({ change => $to, ... });
 223
 224 =cut
 225
 226 sub copy {
 227   my ($self, $changes) = @_;
 228   my $new = bless({ _column_data => { %{$self->{_column_data}}} }, ref $self);
 229   $new->set_column($_ => $changes->{$_}) for keys %$changes;
 230   return $new->insert;
 231 }
 232
 233 =item insert_or_update
 234
 235   $obj->insert_or_update
 236
 237 Updates the object if it's already in the db, else inserts it
 238
 239 =cut
 240
 241 sub insert_or_update {
 242   my $self = shift;
 243   return ($self->in_storage ? $self->update : $self->insert);
 244 }
 245
 246 =item is_changed
 247
 248   my @changed_col_names = $obj->is_changed
 249
 250 =cut
 251
 252 sub is_changed {
 253   return keys %{shift->{_dirty_columns} || {}};
 254 }
 255
 256 1;
 257
 258 =back
 259
 260 =head1 AUTHORS
 261
 262 Matt S. Trout <mst@shadowcatsystems.co.uk>
 263
 264 =head1 LICENSE
 265
 266 You may distribute this code under the same terms as Perl itself.
 267
 268 =cut
 269