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