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 get_columns
 180
 181   my %data = $obj->get_columns;
 182
 183 Fetch all column values at once.
 184
 185 =cut
 186
 187 sub get_columns {
 188   my $self = shift;
 189   return map { $_ => $self->get_column($_) } $self->columns;
 190 }
 191
 192 =item set_column
 193
 194   $obj->set_column($col => $val);
 195
 196 Sets a column value; if the new value is different to the old the column
 197 is marked as dirty for when you next call $obj->update
 198
 199 =cut
 200
 201 sub set_column {
 202   my $self = shift;
 203   my ($column) = @_;
 204   my $old = $self->get_column($column);
 205   my $ret = $self->store_column(@_);
 206   $self->{_dirty_columns}{$column} = 1 unless defined $old && $old eq $ret;
 207   return $ret;
 208 }
 209
 210 =item set_columns
 211
 212   my $copy = $orig->set_columns({ $col => $val, ... });
 213
 214 Set more than one column value at once.
 215
 216 =cut
 217
 218 sub set_columns {
 219   my ($self,$data) = @_;
 220   while (my ($col,$val) = each %$data) {
 221     $self->set_column($col,$val);
 222   }
 223 }
 224
 225 =item copy
 226
 227   my $copy = $orig->copy({ change => $to, ... });
 228
 229 Insert a new row with the specified changes.
 230
 231 =cut
 232
 233 =item store_column
 234
 235   $obj->store_column($col => $val);
 236
 237 Sets a column value without marking it as dirty
 238
 239 =cut
 240
 241 sub store_column {
 242   my ($self, $column, $value) = @_;
 243   $self->throw( "No such column '${column}'" )
 244     unless $self->_columns->{$column};
 245   $self->throw( "set_column called for ${column} without value" )
 246     if @_ < 3;
 247   return $self->{_column_data}{$column} = $value;
 248 }
 249
 250 sub _row_to_object {
 251   my ($class, $cols, $row) = @_;
 252   my %vals;
 253   $vals{$cols->[$_]} = $row->[$_] for 0 .. $#$cols;
 254   my $new = $class->new(\%vals);
 255   $new->in_storage(1);
 256   return $new;
 257 }
 258
 259 sub copy {
 260   my ($self, $changes) = @_;
 261   my $new = bless({ _column_data => { %{$self->{_column_data}}} }, ref $self);
 262   $new->set_column($_ => $changes->{$_}) for keys %$changes;
 263   return $new->insert;
 264 }
 265
 266 =item insert_or_update
 267
 268   $obj->insert_or_update
 269
 270 Updates the object if it's already in the db, else inserts it
 271
 272 =cut
 273
 274 sub insert_or_update {
 275   my $self = shift;
 276   return ($self->in_storage ? $self->update : $self->insert);
 277 }
 278
 279 =item is_changed
 280
 281   my @changed_col_names = $obj->is_changed
 282
 283 =cut
 284
 285 sub is_changed {
 286   return keys %{shift->{_dirty_columns} || {}};
 287 }
 288
 289 1;
 290
 291 =back
 292
 293 =head1 AUTHORS
 294
 295 Matt S. Trout <mst@shadowcatsystems.co.uk>
 296
 297 =head1 LICENSE
 298
 299 You may distribute this code under the same terms as Perl itself.
 300
 301 =cut
 302