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