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 $new = bless({ _column_data => { %{$self->{_column_data}}} }, ref $self);
 240   $new->set_column($_ => $changes->{$_}) for keys %$changes;
 241   return $new->insert;
 242 }
 243
 244 =head2 store_column
 245
 246   $obj->store_column($col => $val);
 247
 248 Sets a column value without marking it as dirty.
 249
 250 =cut
 251
 252 sub store_column {
 253   my ($self, $column, $value) = @_;
 254   $self->throw_exception( "No such column '${column}'" )
 255     unless exists $self->{_column_data}{$column} || $self->has_column($column);
 256   $self->throw_exception( "set_column called for ${column} without value" )
 257     if @_ < 3;
 258   return $self->{_column_data}{$column} = $value;
 259 }
 260
 261 =head2 inflate_result
 262
 263   Class->inflate_result($result_source, \%me, \%prefetch?)
 264
 265 Called by ResultSet to inflate a result from storage
 266
 267 =cut
 268
 269 sub inflate_result {
 270   my ($class, $source, $me, $prefetch) = @_;
 271   #use Data::Dumper; print Dumper(@_);
 272   my $new = bless({ result_source => $source,
 273                     _column_data => $me,
 274                     _in_storage => 1
 275                   },
 276                   ref $class || $class);
 277   my $schema;
 278   PRE: foreach my $pre (keys %{$prefetch||{}}) {
 279     my $pre_source = $source->related_source($pre);
 280     $class->throw_exception("Can't prefetch non-existant relationship ${pre}") unless $pre_source;
 281     my $fetched;
 282     unless ($pre_source->primary_columns == grep { exists $prefetch->{$pre}[0]{$_}
 283        and !defined $prefetch->{$pre}[0]{$_} } $pre_source->primary_columns)
 284     {
 285       $fetched = $pre_source->result_class->inflate_result(
 286                       $pre_source, @{$prefetch->{$pre}});
 287     }
 288     my $accessor = $source->relationship_info($pre)->{attrs}{accessor};
 289     $class->throw_exception("No accessor for prefetched $pre")
 290       unless defined $accessor;
 291     if ($accessor eq 'single') {
 292       $new->{_relationship_data}{$pre} = $fetched;
 293     } elsif ($accessor eq 'filter') {
 294       $new->{_inflated_column}{$pre} = $fetched;
 295     } else {
 296       $class->throw_exception("Don't know how to store prefetched $pre");
 297     }
 298   }
 299   return $new;
 300 }
 301
 302 =head2 insert_or_update
 303
 304   $obj->insert_or_update
 305
 306 Updates the object if it's already in the db, else inserts it.
 307
 308 =cut
 309
 310 sub insert_or_update {
 311   my $self = shift;
 312   return ($self->in_storage ? $self->update : $self->insert);
 313 }
 314
 315 =head2 is_changed
 316
 317   my @changed_col_names = $obj->is_changed
 318
 319 =cut
 320
 321 sub is_changed {
 322   return keys %{shift->{_dirty_columns} || {}};
 323 }
 324
 325 =head2 result_source
 326
 327   Accessor to the ResultSource this object was created from
 328
 329 =head2 register_column($column, $column_info)
 330
 331   Registers a column on the class. If the column_info has an 'accessor' key,
 332   creates an accessor named after the value if defined; if there is no such
 333   key, creates an accessor with the same name as the column
 334
 335 =cut
 336
 337 sub register_column {
 338   my ($class, $col, $info) = @_;
 339   my $acc = $col;
 340   if (exists $info->{accessor}) {
 341     return unless defined $info->{accessor};
 342     $acc = [ $info->{accessor}, $col ];
 343   }
 344   $class->mk_group_accessors('column' => $acc);
 345 }
 346
 347
 348 =head2 throw_exception
 349
 350 See Schema's throw_exception.
 351
 352 =cut
 353
 354 sub throw_exception {
 355   my $self=shift;
 356   if (ref $self && ref $self->result_source) {
 357     $self->result_source->schema->throw_exception(@_);
 358   } else {
 359     croak(@_);
 360   }
 361 }
 362
 363 1;
 364
 365 =head1 AUTHORS
 366
 367 Matt S. Trout <mst@shadowcatsystems.co.uk>
 368
 369 =head1 LICENSE
 370
 371 You may distribute this code under the same terms as Perl itself.
 372
 373 =cut
 374