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   $self->{related_resultsets} = {};
  70   return $self;
  71 }
  72
  73 =head2 in_storage
  74
  75   $obj->in_storage; # Get value
  76   $obj->in_storage(1); # Set value
  77
  78 Indicated whether the object exists as a row in the database or not
  79
  80 =cut
  81
  82 sub in_storage {
  83   my ($self, $val) = @_;
  84   $self->{_in_storage} = $val if @_ > 1;
  85   return $self->{_in_storage};
  86 }
  87
  88 =head2 update
  89
  90   $obj->update;
  91
  92 Must be run on an object that is already in the database; issues an SQL
  93 UPDATE query to commit any changes to the object to the db if required.
  94
  95 =cut
  96
  97 sub update {
  98   my ($self, $upd) = @_;
  99   $self->throw_exception( "Not in database" ) unless $self->in_storage;
 100   my %to_update = $self->get_dirty_columns;
 101   return $self unless keys %to_update;
 102   my $ident_cond = $self->ident_condition;
 103   $self->throw_exception("Cannot safely update a row in a PK-less table")
 104     if ! keys %$ident_cond;
 105   my $rows = $self->result_source->storage->update(
 106                $self->result_source->from, \%to_update, $ident_cond);
 107   if ($rows == 0) {
 108     $self->throw_exception( "Can't update ${self}: row not found" );
 109   } elsif ($rows > 1) {
 110     $self->throw_exception("Can't update ${self}: updated more than one row");
 111   }
 112   $self->{_dirty_columns} = {};
 113   $self->{related_resultsets} = {};
 114   return $self;
 115 }
 116
 117 =head2 delete
 118
 119   $obj->delete
 120
 121 Deletes the object from the database. The object is still perfectly usable
 122 accessor-wise etc. but ->in_storage will now return 0 and the object must
 123 be re ->insert'ed before it can be ->update'ed
 124
 125 =cut
 126
 127 sub delete {
 128   my $self = shift;
 129   if (ref $self) {
 130     $self->throw_exception( "Not in database" ) unless $self->in_storage;
 131     my $ident_cond = $self->ident_condition;
 132     $self->throw_exception("Cannot safely delete a row in a PK-less table")
 133       if ! keys %$ident_cond;
 134     $self->result_source->storage->delete(
 135       $self->result_source->from, $ident_cond);
 136     $self->in_storage(undef);
 137   } else {
 138     $self->throw_exception("Can't do class delete without a ResultSource instance")
 139       unless $self->can('result_source_instance');
 140     my $attrs = { };
 141     if (@_ > 1 && ref $_[$#_] eq 'HASH') {
 142       $attrs = { %{ pop(@_) } };
 143     }
 144     my $query = (ref $_[0] eq 'HASH' ? $_[0] : {@_});
 145     $self->result_source_instance->resultset->search(@_)->delete;
 146   }
 147   return $self;
 148 }
 149
 150 =head2 get_column
 151
 152   my $val = $obj->get_column($col);
 153
 154 Gets a column value from a row object. Currently, does not do
 155 any queries; the column must have already been fetched from
 156 the database and stored in the object.
 157
 158 =cut
 159
 160 sub get_column {
 161   my ($self, $column) = @_;
 162   $self->throw_exception( "Can't fetch data as class method" ) unless ref $self;
 163   return $self->{_column_data}{$column}
 164     if exists $self->{_column_data}{$column};
 165   $self->throw_exception( "No such column '${column}'" ) unless $self->has_column($column);
 166   return undef;
 167 }
 168
 169 =head2 get_columns
 170
 171   my %data = $obj->get_columns;
 172
 173 Does C<get_column>, for all column values at once.
 174
 175 =cut
 176
 177 sub get_columns {
 178   my $self = shift;
 179   return %{$self->{_column_data}};
 180 }
 181
 182 =head2 get_dirty_columns
 183
 184   my %data = $obj->get_dirty_columns;
 185
 186 Identical to get_columns but only returns those that have been changed.
 187
 188 =cut
 189
 190 sub get_dirty_columns {
 191   my $self = shift;
 192   return map { $_ => $self->{_column_data}{$_} }
 193            keys %{$self->{_dirty_columns}};
 194 }
 195
 196 =head2 set_column
 197
 198   $obj->set_column($col => $val);
 199
 200 Sets a column value. If the new value is different from the old one,
 201 the column is marked as dirty for when you next call $obj->update.
 202
 203 =cut
 204
 205 sub set_column {
 206   my $self = shift;
 207   my ($column) = @_;
 208   my $old = $self->get_column($column);
 209   my $ret = $self->store_column(@_);
 210   $self->{_dirty_columns}{$column} = 1
 211     if (defined $old ^ defined $ret) || (defined $old && $old ne $ret);
 212   return $ret;
 213 }
 214
 215 =head2 set_columns
 216
 217   my $copy = $orig->set_columns({ $col => $val, ... });
 218
 219 Sets more than one column value at once.
 220
 221 =cut
 222
 223 sub set_columns {
 224   my ($self,$data) = @_;
 225   while (my ($col,$val) = each %$data) {
 226     $self->set_column($col,$val);
 227   }
 228   return $self;
 229 }
 230
 231 =head2 copy
 232
 233   my $copy = $orig->copy({ change => $to, ... });
 234
 235 Inserts a new row with the specified changes.
 236
 237 =cut
 238
 239 sub copy {
 240   my ($self, $changes) = @_;
 241   $changes ||= {};
 242   my $col_data = { %{$self->{_column_data}} };
 243   foreach my $col (keys %$col_data) {
 244     delete $col_data->{$col}
 245       if $self->result_source->column_info($col)->{is_auto_increment};
 246   }
 247   my $new = bless({ _column_data => $col_data }, ref $self);
 248   $new->set_column($_ => $changes->{$_}) for keys %$changes;
 249   $new->insert;
 250   foreach my $rel ($self->result_source->relationships) {
 251     my $rel_info = $self->result_source->relationship_info($rel);
 252     if ($rel_info->{attrs}{cascade_copy}) {
 253       my $resolved = $self->result_source->resolve_condition(
 254        $rel_info->{cond}, $rel, $new);
 255       foreach my $related ($self->search_related($rel)) {
 256         $related->copy($resolved);
 257       }
 258     }
 259   }
 260   $new;
 261 }
 262
 263 =head2 store_column
 264
 265   $obj->store_column($col => $val);
 266
 267 Sets a column value without marking it as dirty.
 268
 269 =cut
 270
 271 sub store_column {
 272   my ($self, $column, $value) = @_;
 273   $self->throw_exception( "No such column '${column}'" )
 274     unless exists $self->{_column_data}{$column} || $self->has_column($column);
 275   $self->throw_exception( "set_column called for ${column} without value" )
 276     if @_ < 3;
 277   return $self->{_column_data}{$column} = $value;
 278 }
 279
 280 =head2 inflate_result
 281
 282   Class->inflate_result($result_source, \%me, \%prefetch?)
 283
 284 Called by ResultSet to inflate a result from storage
 285
 286 =cut
 287
 288 sub inflate_result {
 289   my ($class, $source, $me, $prefetch) = @_;
 290   #use Data::Dumper; print Dumper(@_);
 291   my $new = bless({ result_source => $source,
 292                     _column_data => $me,
 293                     _in_storage => 1
 294                   },
 295                   ref $class || $class);
 296   my $schema;
 297   foreach my $pre (keys %{$prefetch||{}}) {
 298     my $pre_val = $prefetch->{$pre};
 299     # if first prefetch item is arrayref, assume this is a has_many prefetch
 300     # and that objects are pre inflated (TODO: check arrayref contents using "ref" to make sure)
 301     if( ref $pre_val->[0] eq 'ARRAY' ) {
 302       $new->related_resultset($pre)->set_cache( $pre_val->[0] );
 303     }
 304     else {
 305       my $pre_source = $source->related_source($pre);
 306       $class->throw_exception("Can't prefetch non-existent relationship ${pre}") unless $pre_source;
 307       my $fetched;
 308       unless ($pre_source->primary_columns == grep { exists $prefetch->{$pre}[0]{$_}
 309          and !defined $prefetch->{$pre}[0]{$_} } $pre_source->primary_columns)
 310       {
 311         $fetched = $pre_source->result_class->inflate_result(
 312                       $pre_source, @{$prefetch->{$pre}});
 313       }
 314       my $accessor = $source->relationship_info($pre)->{attrs}{accessor};
 315       $class->throw_exception("No accessor for prefetched $pre")
 316        unless defined $accessor;
 317       if ($accessor eq 'single') {
 318         $new->{_relationship_data}{$pre} = $fetched;
 319       } elsif ($accessor eq 'filter') {
 320        $new->{_inflated_column}{$pre} = $fetched;
 321       } elsif ($accessor eq 'multi') {
 322        $class->throw_exception("Cache must be enabled for has_many prefetch '$pre'");
 323       } else {
 324        $class->throw_exception("Prefetch not supported with accessor '$accessor'");
 325       }
 326     }
 327   }
 328   return $new;
 329 }
 330
 331 =head2 insert_or_update
 332
 333   $obj->insert_or_update
 334
 335 Updates the object if it's already in the db, else inserts it.
 336
 337 =cut
 338
 339 sub insert_or_update {
 340   my $self = shift;
 341   return ($self->in_storage ? $self->update : $self->insert);
 342 }
 343
 344 =head2 is_changed
 345
 346   my @changed_col_names = $obj->is_changed
 347
 348 =cut
 349
 350 sub is_changed {
 351   return keys %{shift->{_dirty_columns} || {}};
 352 }
 353
 354 =head2 result_source
 355
 356   Accessor to the ResultSource this object was created from
 357
 358 =head2 register_column($column, $column_info)
 359
 360   Registers a column on the class. If the column_info has an 'accessor' key,
 361   creates an accessor named after the value if defined; if there is no such
 362   key, creates an accessor with the same name as the column
 363
 364 =cut
 365
 366 sub register_column {
 367   my ($class, $col, $info) = @_;
 368   my $acc = $col;
 369   if (exists $info->{accessor}) {
 370     return unless defined $info->{accessor};
 371     $acc = [ $info->{accessor}, $col ];
 372   }
 373   $class->mk_group_accessors('column' => $acc);
 374 }
 375
 376
 377 =head2 throw_exception
 378
 379 See Schema's throw_exception.
 380
 381 =cut
 382
 383 sub throw_exception {
 384   my $self=shift;
 385   if (ref $self && ref $self->result_source) {
 386     $self->result_source->schema->throw_exception(@_);
 387   } else {
 388     croak(@_);
 389   }
 390 }
 391
 392 1;
 393
 394 =head1 AUTHORS
 395
 396 Matt S. Trout <mst@shadowcatsystems.co.uk>
 397
 398 =head1 LICENSE
 399
 400 You may distribute this code under the same terms as Perl itself.
 401
 402 =cut
 403