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 = $pre_source->result_class->inflate_result(
 282                     $pre_source, @{$prefetch->{$pre}});
 283     my $accessor = $source->relationship_info($pre)->{attrs}{accessor};
 284     $class->throw_exception("No accessor for prefetched $pre")
 285       unless defined $accessor;
 286     PRIMARY: foreach my $pri ($pre_source->primary_columns) {
 287       unless (defined $fetched->get_column($pri)) {
 288         undef $fetched;
 289         last PRIMARY;
 290       }
 291     }
 292     if ($accessor eq 'single') {
 293       $new->{_relationship_data}{$pre} = $fetched;
 294     } elsif ($accessor eq 'filter') {
 295       $new->{_inflated_column}{$pre} = $fetched;
 296     } else {
 297       $class->throw_exception("Don't know how to store prefetched $pre");
 298     }
 299   }
 300   return $new;
 301 }
 302
 303 =head2 insert_or_update
 304
 305   $obj->insert_or_update
 306
 307 Updates the object if it's already in the db, else inserts it.
 308
 309 =cut
 310
 311 sub insert_or_update {
 312   my $self = shift;
 313   return ($self->in_storage ? $self->update : $self->insert);
 314 }
 315
 316 =head2 is_changed
 317
 318   my @changed_col_names = $obj->is_changed
 319
 320 =cut
 321
 322 sub is_changed {
 323   return keys %{shift->{_dirty_columns} || {}};
 324 }
 325
 326 =head2 result_source
 327
 328   Accessor to the ResultSource this object was created from
 329
 330 =head2 register_column($column, $column_info)
 331
 332   Registers a column on the class. If the column_info has an 'accessor' key,
 333   creates an accessor named after the value if defined; if there is no such
 334   key, creates an accessor with the same name as the column
 335
 336 =cut
 337
 338 sub register_column {
 339   my ($class, $col, $info) = @_;
 340   my $acc = $col;
 341   if (exists $info->{accessor}) {
 342     return unless defined $info->{accessor};
 343     $acc = [ $info->{accessor}, $col ];
 344   }
 345   $class->mk_group_accessors('column' => $acc);
 346 }
 347
 348
 349 =head2 throw_exception
 350
 351 See Schema's throw_exception.
 352
 353 =cut
 354
 355 sub throw_exception {
 356   my $self=shift;
 357   if (ref $self && ref $self->result_source) {
 358     $self->result_source->schema->throw_exception(@_);
 359   } else {
 360     croak(@_);
 361   }
 362 }
 363
 364 1;
 365
 366 =head1 AUTHORS
 367
 368 Matt S. Trout <mst@shadowcatsystems.co.uk>
 369
 370 =head1 LICENSE
 371
 372 You may distribute this code under the same terms as Perl itself.
 373
 374 =cut
 375