lib/DBIx/Class/Row.pm

   1 package DBIx::Class::Row;
   2
   3 use strict;
   4 use warnings;
   5
   6 use base qw/DBIx::Class/;
   7
   8 =head1 NAME
   9
  10 DBIx::Class::Row - Basic row methods
  11
  12 =head1 SYNOPSIS
  13
  14 =head1 DESCRIPTION
  15
  16 This class is responsible for defining and doing basic operations on rows
  17 derived from L<DBIx::Class::Table> objects.
  18
  19 =head1 METHODS
  20
  21 =head2 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       die "No such column $k on $class" unless $class->has_column($k);
  37       $new->store_column($k => $v);
  38     }
  39   }
  40   return $new;
  41 }
  42
  43 =head2 insert
  44
  45   $obj->insert;
  46
  47 Inserts an object into the database if it isn't already in there. Returns
  48 the object itself.
  49
  50 =cut
  51
  52 sub insert {
  53   my ($self) = @_;
  54   return $self if $self->in_storage;
  55   #use Data::Dumper; warn Dumper($self);
  56   my %in;
  57   $in{$_} = $self->get_column($_)
  58     for grep { defined $self->get_column($_) } $self->columns;
  59   my %out = %{ $self->storage->insert($self->_table_name, \%in) };
  60   $self->store_column($_, $out{$_})
  61     for grep { $self->get_column($_) ne $out{$_} } keys %out;
  62   $self->in_storage(1);
  63   $self->{_dirty_columns} = {};
  64   return $self;
  65 }
  66
  67 =head2 in_storage
  68
  69   $obj->in_storage; # Get value
  70   $obj->in_storage(1); # Set value
  71
  72 Indicated whether the object exists as a row in the database or not
  73
  74 =cut
  75
  76 sub in_storage {
  77   my ($self, $val) = @_;
  78   $self->{_in_storage} = $val if @_ > 1;
  79   return $self->{_in_storage};
  80 }
  81
  82 =head2 create
  83
  84   my $new = My::Class->create($attrs);
  85
  86 A shortcut for My::Class->new($attrs)->insert;
  87
  88 =cut
  89
  90 sub create {
  91   my ($class, $attrs) = @_;
  92   $class->throw( "create needs a hashref" ) unless ref $attrs eq 'HASH';
  93   return $class->new($attrs)->insert;
  94 }
  95
  96 =head2 update
  97
  98   $obj->update;
  99
 100 Must be run on an object that is already in the database; issues an SQL
 101 UPDATE query to commit any changes to the object to the db if required.
 102
 103 =cut
 104
 105 sub update {
 106   my ($self, $upd) = @_;
 107   $self->throw( "Not in database" ) unless $self->in_storage;
 108   my %to_update;
 109   $to_update{$_} = $self->get_column($_) for $self->is_changed;
 110   return -1 unless keys %to_update;
 111   my $rows = $self->storage->update($self->_table_name, \%to_update,
 112                                       $self->ident_condition);
 113   if ($rows == 0) {
 114     $self->throw( "Can't update ${self}: row not found" );
 115   } elsif ($rows > 1) {
 116     $self->throw("Can't update ${self}: updated more than one row");
 117   }
 118   $self->{_dirty_columns} = {};
 119   return $self;
 120 }
 121
 122 =head2 delete
 123
 124   $obj->delete
 125
 126 Deletes the object from the database. The object is still perfectly usable
 127 accessor-wise etc. but ->in_storage will now return 0 and the object must
 128 be re ->insert'ed before it can be ->update'ed
 129
 130 =cut
 131
 132 sub delete {
 133   my $self = shift;
 134   if (ref $self) {
 135     $self->throw( "Not in database" ) unless $self->in_storage;
 136     #warn $self->_ident_cond.' '.join(', ', $self->_ident_values);
 137     $self->storage->delete($self->_table_name, $self->ident_condition);
 138     $self->in_storage(undef);
 139     #$self->store_column($_ => undef) for $self->primary_columns;
 140       # Should probably also arrange to trash PK if auto
 141       # but if we do, post-delete cascade triggers fail :/
 142   } else {
 143     my $attrs = { };
 144     if (@_ > 1 && ref $_[$#_] eq 'HASH') {
 145       $attrs = { %{ pop(@_) } };
 146     }
 147     my $query = (ref $_[0] eq 'HASH' ? $_[0] : {@_});
 148     $self->storage->delete($self->_table_name, $query);
 149   }
 150   return $self;
 151 }
 152
 153 =head2 get_column
 154
 155   my $val = $obj->get_column($col);
 156
 157 Gets a column value from a row object. Currently, does not do
 158 any queries; the column must have already been fetched from
 159 the database and stored in the object.
 160
 161 =cut
 162
 163 sub get_column {
 164   my ($self, $column) = @_;
 165   $self->throw( "Can't fetch data as class method" ) unless ref $self;
 166   $self->throw( "No such column '${column}'" ) unless $self->has_column($column);
 167   return $self->{_column_data}{$column}
 168     if exists $self->{_column_data}{$column};
 169   return undef;
 170 }
 171
 172 =head2 get_columns
 173
 174   my %data = $obj->get_columns;
 175
 176 Does C<get_column>, for all column values at once.
 177
 178 =cut
 179
 180 sub get_columns {
 181   my $self = shift;
 182   return map { $_ => $self->get_column($_) } $self->columns;
 183 }
 184
 185 =head2 set_column
 186
 187   $obj->set_column($col => $val);
 188
 189 Sets a column value. If the new value is different from the old one,
 190 the column is marked as dirty for when you next call $obj->update.
 191
 192 =cut
 193
 194 sub set_column {
 195   my $self = shift;
 196   my ($column) = @_;
 197   my $old = $self->get_column($column);
 198   my $ret = $self->store_column(@_);
 199   $self->{_dirty_columns}{$column} = 1 unless defined $old && $old eq $ret;
 200   return $ret;
 201 }
 202
 203 =head2 set_columns
 204
 205   my $copy = $orig->set_columns({ $col => $val, ... });
 206
 207 Sets more than one column value at once.
 208
 209 =cut
 210
 211 sub set_columns {
 212   my ($self,$data) = @_;
 213   while (my ($col,$val) = each %$data) {
 214     $self->set_column($col,$val);
 215   }
 216 }
 217
 218 =head2 copy
 219
 220   my $copy = $orig->copy({ change => $to, ... });
 221
 222 Inserts a new row with the specified changes.
 223
 224 =cut
 225
 226 =head2 store_column
 227
 228   $obj->store_column($col => $val);
 229
 230 Sets a column value without marking it as dirty.
 231
 232 =cut
 233
 234 sub store_column {
 235   my ($self, $column, $value) = @_;
 236   $self->throw( "No such column '${column}'" )
 237     unless $self->has_column($column);
 238   $self->throw( "set_column called for ${column} without value" )
 239     if @_ < 3;
 240   return $self->{_column_data}{$column} = $value;
 241 }
 242
 243 =head2 inflate_result
 244
 245   Class->inflate_result(\%me, \%prefetch?)
 246
 247 Called by ResultSet to inflate a result from storage
 248
 249 =cut
 250
 251 sub inflate_result {
 252   my ($class, $me, $prefetch) = @_;
 253   #use Data::Dumper; print Dumper(@_);
 254   my $new = bless({ _column_data => $me }, ref $class || $class);
 255   $new->in_storage(1);
 256   PRE: foreach my $pre (keys %{$prefetch||{}}) {
 257     my $rel_obj = $class->_relationships->{$pre};
 258     my $pre_class = $class->resolve_class($rel_obj->{class});
 259     my $fetched = $pre_class->inflate_result(@{$prefetch->{$pre}});
 260     $class->throw("No accessor for prefetched $pre")
 261       unless defined $rel_obj->{attrs}{accessor};
 262     if ($rel_obj->{attrs}{accessor} eq 'single') {
 263       PRIMARY: foreach my $pri ($rel_obj->{class}->primary_columns) {
 264         unless (defined $fetched->get_column($pri)) {
 265           undef $fetched;
 266           last PRIMARY;
 267         }
 268       }
 269       $new->{_relationship_data}{$pre} = $fetched;
 270     } elsif ($rel_obj->{attrs}{accessor} eq 'filter') {
 271       $new->{_inflated_column}{$pre} = $fetched;
 272     } else {
 273       $class->throw("Don't know how to store prefetched $pre");
 274     }
 275   }
 276   return $new;
 277 }
 278
 279 sub copy {
 280   my ($self, $changes) = @_;
 281   my $new = bless({ _column_data => { %{$self->{_column_data}}} }, ref $self);
 282   $new->set_column($_ => $changes->{$_}) for keys %$changes;
 283   return $new->insert;
 284 }
 285
 286 =head2 insert_or_update
 287
 288   $obj->insert_or_update
 289
 290 Updates the object if it's already in the db, else inserts it.
 291
 292 =cut
 293
 294 sub insert_or_update {
 295   my $self = shift;
 296   return ($self->in_storage ? $self->update : $self->insert);
 297 }
 298
 299 =head2 is_changed
 300
 301   my @changed_col_names = $obj->is_changed
 302
 303 =cut
 304
 305 sub is_changed {
 306   return keys %{shift->{_dirty_columns} || {}};
 307 }
 308
 309 1;
 310
 311 =head1 AUTHORS
 312
 313 Matt S. Trout <mst@shadowcatsystems.co.uk>
 314
 315 =head1 LICENSE
 316
 317 You may distribute this code under the same terms as Perl itself.
 318
 319 =cut
 320