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 use Carp::Clan qw/^DBIx::Class/;
   8
   9 __PACKAGE__->load_components(qw/AccessorGroup/);
  10
  11 __PACKAGE__->mk_group_accessors('simple' => 'result_source');
  12
  13 =head1 NAME
  14
  15 DBIx::Class::Row - Basic row methods
  16
  17 =head1 SYNOPSIS
  18
  19 =head1 DESCRIPTION
  20
  21 This class is responsible for defining and doing basic operations on rows
  22 derived from L<DBIx::Class::ResultSource> objects.
  23
  24 =head1 METHODS
  25
  26 =head2 new
  27
  28   my $obj = My::Class->new($attrs);
  29
  30 Creates a new row object from column => value mappings passed as a hash ref
  31
  32 =cut
  33
  34 sub new {
  35   my ($class, $attrs) = @_;
  36   $class = ref $class if ref $class;
  37   my $new = bless({ _column_data => { } }, $class);
  38   if ($attrs) {
  39     $new->throw_exception("attrs must be a hashref" ) unless ref($attrs) eq 'HASH';
  40     while (my ($k, $v) = each %{$attrs}) {
  41       $new->throw_exception("No such column $k on $class") unless $class->has_column($k);
  42       $new->store_column($k => $v);
  43     }
  44   }
  45   return $new;
  46 }
  47
  48 =head2 insert
  49
  50   $obj->insert;
  51
  52 Inserts an object into the database if it isn't already in there. Returns
  53 the object itself. Requires the object's result source to be set, or the
  54 class to have a result_source_instance method.
  55
  56 =cut
  57
  58 sub insert {
  59   my ($self) = @_;
  60   return $self if $self->in_storage;
  61   $self->{result_source} ||= $self->result_source_instance
  62     if $self->can('result_source_instance');
  63   my $source = $self->{result_source};
  64   $self->throw_exception("No result_source set on this object; can't insert") unless $source;
  65   #use Data::Dumper; warn Dumper($self);
  66   $source->storage->insert($source->from, { $self->get_columns });
  67   $self->in_storage(1);
  68   $self->{_dirty_columns} = {};
  69   return $self;
  70 }
  71
  72 =head2 in_storage
  73
  74   $obj->in_storage; # Get value
  75   $obj->in_storage(1); # Set value
  76
  77 Indicated whether the object exists as a row in the database or not
  78
  79 =cut
  80
  81 sub in_storage {
  82   my ($self, $val) = @_;
  83   $self->{_in_storage} = $val if @_ > 1;
  84   return $self->{_in_storage};
  85 }
  86
  87 =head2 update
  88
  89   $obj->update;
  90
  91 Must be run on an object that is already in the database; issues an SQL
  92 UPDATE query to commit any changes to the object to the db if required.
  93
  94 =cut
  95
  96 sub update {
  97   my ($self, $upd) = @_;
  98   $self->throw_exception( "Not in database" ) unless $self->in_storage;
  99   my %to_update = $self->get_dirty_columns;
 100   return $self unless keys %to_update;
 101   my $ident_cond = $self->ident_condition;
 102   $self->throw_exception("Cannot safely update a row in a PK-less table")
 103     if ! keys %$ident_cond;
 104   my $rows = $self->result_source->storage->update(
 105                $self->result_source->from, \%to_update, $ident_cond);
 106   if ($rows == 0) {
 107     $self->throw_exception( "Can't update ${self}: row not found" );
 108   } elsif ($rows > 1) {
 109     $self->throw_exception("Can't update ${self}: updated more than one row");
 110   }
 111   $self->{_dirty_columns} = {};
 112   return $self;
 113 }
 114
 115 =head2 delete
 116
 117   $obj->delete
 118
 119 Deletes the object from the database. The object is still perfectly usable
 120 accessor-wise etc. but ->in_storage will now return 0 and the object must
 121 be re ->insert'ed before it can be ->update'ed
 122
 123 =cut
 124
 125 sub delete {
 126   my $self = shift;
 127   if (ref $self) {
 128     $self->throw_exception( "Not in database" ) unless $self->in_storage;
 129     my $ident_cond = $self->ident_condition;
 130     $self->throw_exception("Cannot safely delete a row in a PK-less table")
 131       if ! keys %$ident_cond;
 132     $self->result_source->storage->delete(
 133       $self->result_source->from, $ident_cond);
 134     $self->in_storage(undef);
 135   } else {
 136     $self->throw_exception("Can't do class delete without a ResultSource instance")
 137       unless $self->can('result_source_instance');
 138     my $attrs = { };
 139     if (@_ > 1 && ref $_[$#_] eq 'HASH') {
 140       $attrs = { %{ pop(@_) } };
 141     }
 142     my $query = (ref $_[0] eq 'HASH' ? $_[0] : {@_});
 143     $self->result_source_instance->resultset->search(@_)->delete;
 144   }
 145   return $self;
 146 }
 147
 148 =head2 get_column
 149
 150   my $val = $obj->get_column($col);
 151
 152 Gets a column value from a row object. Currently, does not do
 153 any queries; the column must have already been fetched from
 154 the database and stored in the object.
 155
 156 =cut
 157
 158 sub get_column {
 159   my ($self, $column) = @_;
 160   $self->throw_exception( "Can't fetch data as class method" ) unless ref $self;
 161   return $self->{_column_data}{$column}
 162     if exists $self->{_column_data}{$column};
 163   $self->throw_exception( "No such column '${column}'" ) unless $self->has_column($column);
 164   return undef;
 165 }
 166
 167 =head2 get_columns
 168
 169   my %data = $obj->get_columns;
 170
 171 Does C<get_column>, for all column values at once.
 172
 173 =cut
 174
 175 sub get_columns {
 176   my $self = shift;
 177   return %{$self->{_column_data}};
 178 }
 179
 180 =head2 get_dirty_columns
 181
 182   my %data = $obj->get_dirty_columns;
 183
 184 Identical to get_columns but only returns those that have been changed.
 185
 186 =cut
 187
 188 sub get_dirty_columns {
 189   my $self = shift;
 190   return map { $_ => $self->{_column_data}{$_} }
 191            keys %{$self->{_dirty_columns}};
 192 }
 193
 194 =head2 set_column
 195
 196   $obj->set_column($col => $val);
 197
 198 Sets a column value. If the new value is different from the old one,
 199 the column is marked as dirty for when you next call $obj->update.
 200
 201 =cut
 202
 203 sub set_column {
 204   my $self = shift;
 205   my ($column) = @_;
 206   my $old = $self->get_column($column);
 207   my $ret = $self->store_column(@_);
 208   $self->{_dirty_columns}{$column} = 1
 209     if (defined $old ^ defined $ret) || (defined $old && $old ne $ret);
 210   return $ret;
 211 }
 212
 213 =head2 set_columns
 214
 215   my $copy = $orig->set_columns({ $col => $val, ... });
 216
 217 Sets more than one column value at once.
 218
 219 =cut
 220
 221 sub set_columns {
 222   my ($self,$data) = @_;
 223   while (my ($col,$val) = each %$data) {
 224     $self->set_column($col,$val);
 225   }
 226   return $self;
 227 }
 228
 229 =head2 copy
 230
 231   my $copy = $orig->copy({ change => $to, ... });
 232
 233 Inserts a new row with the specified changes.
 234
 235 =cut
 236
 237 sub copy {
 238   my ($self, $changes) = @_;
 239   my $col_data = { %{$self->{_column_data}} };
 240   foreach my $col (keys %$col_data) {
 241     delete $col_data->{$col}
 242       if $self->result_source->column_info($col)->{is_auto_increment};
 243   }
 244   my $new = bless({ _column_data => $col_data }, ref $self);
 245   $new->set_column($_ => $changes->{$_}) for keys %$changes;
 246   return $new->insert;
 247 }
 248
 249 =head2 store_column
 250
 251   $obj->store_column($col => $val);
 252
 253 Sets a column value without marking it as dirty.
 254
 255 =cut
 256
 257 sub store_column {
 258   my ($self, $column, $value) = @_;
 259   $self->throw_exception( "No such column '${column}'" )
 260     unless exists $self->{_column_data}{$column} || $self->has_column($column);
 261   $self->throw_exception( "set_column called for ${column} without value" )
 262     if @_ < 3;
 263   return $self->{_column_data}{$column} = $value;
 264 }
 265
 266 =head2 inflate_result
 267
 268   Class->inflate_result($result_source, \%me, \%prefetch?)
 269
 270 Called by ResultSet to inflate a result from storage
 271
 272 =cut
 273
 274 sub inflate_result {
 275   my ($class, $source, $me, $prefetch) = @_;
 276   #use Data::Dumper; print Dumper(@_);
 277   my $new = bless({ result_source => $source,
 278                     _column_data => $me,
 279                     _in_storage => 1
 280                   },
 281                   ref $class || $class);
 282   my $schema;
 283   PRE: foreach my $pre (keys %{$prefetch||{}}) {
 284     my $pre_source = $source->related_source($pre);
 285     $class->throw_exception("Can't prefetch non-existant relationship ${pre}") unless $pre_source;
 286     my $fetched;
 287     unless ($pre_source->primary_columns == grep { exists $prefetch->{$pre}[0]{$_}
 288        and !defined $prefetch->{$pre}[0]{$_} } $pre_source->primary_columns)
 289     {
 290       $fetched = $pre_source->result_class->inflate_result(
 291                       $pre_source, @{$prefetch->{$pre}});
 292     }
 293     my $accessor = $source->relationship_info($pre)->{attrs}{accessor};
 294     $class->throw_exception("No accessor for prefetched $pre")
 295       unless defined $accessor;
 296     if ($accessor eq 'single') {
 297       $new->{_relationship_data}{$pre} = $fetched;
 298     } elsif ($accessor eq 'filter') {
 299       $new->{_inflated_column}{$pre} = $fetched;
 300     } else {
 301       $class->throw_exception("Don't know how to store prefetched $pre");
 302     }
 303   }
 304   return $new;
 305 }
 306
 307 =head2 insert_or_update
 308
 309   $obj->insert_or_update
 310
 311 Updates the object if it's already in the db, else inserts it.
 312
 313 =cut
 314
 315 sub insert_or_update {
 316   my $self = shift;
 317   return ($self->in_storage ? $self->update : $self->insert);
 318 }
 319
 320 =head2 is_changed
 321
 322   my @changed_col_names = $obj->is_changed
 323
 324 =cut
 325
 326 sub is_changed {
 327   return keys %{shift->{_dirty_columns} || {}};
 328 }
 329
 330 =head2 result_source
 331
 332   Accessor to the ResultSource this object was created from
 333
 334 =head2 register_column($column, $column_info)
 335
 336   Registers a column on the class. If the column_info has an 'accessor' key,
 337   creates an accessor named after the value if defined; if there is no such
 338   key, creates an accessor with the same name as the column
 339
 340 =cut
 341
 342 sub register_column {
 343   my ($class, $col, $info) = @_;
 344   my $acc = $col;
 345   if (exists $info->{accessor}) {
 346     return unless defined $info->{accessor};
 347     $acc = [ $info->{accessor}, $col ];
 348   }
 349   $class->mk_group_accessors('column' => $acc);
 350 }
 351
 352
 353 =head2 throw_exception
 354
 355 See Schema's throw_exception.
 356
 357 =cut
 358
 359 sub throw_exception {
 360   my $self=shift;
 361   if (ref $self && ref $self->result_source) {
 362     $self->result_source->schema->throw_exception(@_);
 363   } else {
 364     croak(@_);
 365   }
 366 }
 367
 368 1;
 369
 370 =head1 AUTHORS
 371
 372 Matt S. Trout <mst@shadowcatsystems.co.uk>
 373
 374 =head1 LICENSE
 375
 376 You may distribute this code under the same terms as Perl itself.
 377
 378 =cut
 379