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     # if first prefetch item is arrayref, assume this is a has_many prefetch
 301     # and that objects are pre inflated (TODO: check arrayref contents using "ref" to make sure)
 302     if( ref $pre_val->[0] eq 'ARRAY' ) {
 303       $new->related_resultset($pre)->set_cache( $pre_val->[0] );
 304     }
 305     else {
 306       my $pre_source = $source->related_source($pre);
 307       $class->throw_exception("Can't prefetch non-existent relationship ${pre}") unless $pre_source;
 308       my $fetched;
 309       unless ($pre_source->primary_columns == grep { exists $prefetch->{$pre}[0]{$_}
 310          and !defined $prefetch->{$pre}[0]{$_} } $pre_source->primary_columns)
 311       {
 312         $fetched = $pre_source->result_class->inflate_result(
 313                       $pre_source, @{$prefetch->{$pre}});
 314       }
 315       my $accessor = $source->relationship_info($pre)->{attrs}{accessor};
 316       $class->throw_exception("No accessor for prefetched $pre")
 317        unless defined $accessor;
 318       if ($accessor eq 'single') {
 319         $new->{_relationship_data}{$pre} = $fetched;
 320       } elsif ($accessor eq 'filter') {
 321        $new->{_inflated_column}{$pre} = $fetched;
 322       } elsif ($accessor eq 'multi') {
 323        $class->throw_exception("Cache must be enabled for has_many prefetch '$pre'");
 324       } else {
 325        $class->throw_exception("Prefetch not supported with accessor '$accessor'");
 326       }
 327     }
 328   }
 329   return $new;
 330 }
 331
 332 =head2 insert_or_update
 333
 334   $obj->insert_or_update
 335
 336 Updates the object if it's already in the db, else inserts it.
 337
 338 =cut
 339
 340 sub insert_or_update {
 341   my $self = shift;
 342   return ($self->in_storage ? $self->update : $self->insert);
 343 }
 344
 345 =head2 is_changed
 346
 347   my @changed_col_names = $obj->is_changed
 348
 349 =cut
 350
 351 sub is_changed {
 352   return keys %{shift->{_dirty_columns} || {}};
 353 }
 354
 355 =head2 result_source
 356
 357   Accessor to the ResultSource this object was created from
 358
 359 =head2 register_column
 360
 361 =head3 Arguments: ($column, $column_info)
 362
 363   Registers a column on the class. If the column_info has an 'accessor' key,
 364   creates an accessor named after the value if defined; if there is no such
 365   key, creates an accessor with the same name as the column
 366
 367 =cut
 368
 369 sub register_column {
 370   my ($class, $col, $info) = @_;
 371   my $acc = $col;
 372   if (exists $info->{accessor}) {
 373     return unless defined $info->{accessor};
 374     $acc = [ $info->{accessor}, $col ];
 375   }
 376   $class->mk_group_accessors('column' => $acc);
 377 }
 378
 379
 380 =head2 throw_exception
 381
 382 See Schema's throw_exception.
 383
 384 =cut
 385
 386 sub throw_exception {
 387   my $self=shift;
 388   if (ref $self && ref $self->result_source) {
 389     $self->result_source->schema->throw_exception(@_);
 390   } else {
 391     croak(@_);
 392   }
 393 }
 394
 395 1;
 396
 397 =head1 AUTHORS
 398
 399 Matt S. Trout <mst@shadowcatsystems.co.uk>
 400
 401 =head1 LICENSE
 402
 403 You may distribute this code under the same terms as Perl itself.
 404
 405 =cut
 406