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   $self->set_columns($upd) if $upd;
 100   my %to_update = $self->get_dirty_columns;
 101   return $self unless keys %to_update;
 102   my $ident_cond = $self->ident_condition;
 103   $self->throw_exception("Cannot safely update a row in a PK-less table")
 104     if ! keys %$ident_cond;
 105   my $rows = $self->result_source->storage->update(
 106                $self->result_source->from, \%to_update, $ident_cond);
 107   if ($rows == 0) {
 108     $self->throw_exception( "Can't update ${self}: row not found" );
 109   } elsif ($rows > 1) {
 110     $self->throw_exception("Can't update ${self}: updated more than one row");
 111   }
 112   $self->{_dirty_columns} = {};
 113   return $self;
 114 }
 115
 116 =head2 delete
 117
 118   $obj->delete
 119
 120 Deletes the object from the database. The object is still perfectly usable
 121 accessor-wise etc. but ->in_storage will now return 0 and the object must
 122 be re ->insert'ed before it can be ->update'ed
 123
 124 =cut
 125
 126 sub delete {
 127   my $self = shift;
 128   if (ref $self) {
 129     $self->throw_exception( "Not in database" ) unless $self->in_storage;
 130     my $ident_cond = $self->ident_condition;
 131     $self->throw_exception("Cannot safely delete a row in a PK-less table")
 132       if ! keys %$ident_cond;
 133     $self->result_source->storage->delete(
 134       $self->result_source->from, $ident_cond);
 135     $self->in_storage(undef);
 136   } else {
 137     $self->throw_exception("Can't do class delete without a ResultSource instance")
 138       unless $self->can('result_source_instance');
 139     my $attrs = { };
 140     if (@_ > 1 && ref $_[$#_] eq 'HASH') {
 141       $attrs = { %{ pop(@_) } };
 142     }
 143     my $query = (ref $_[0] eq 'HASH' ? $_[0] : {@_});
 144     $self->result_source_instance->resultset->search(@_)->delete;
 145   }
 146   return $self;
 147 }
 148
 149 =head2 get_column
 150
 151   my $val = $obj->get_column($col);
 152
 153 Gets a column value from a row object. Currently, does not do
 154 any queries; the column must have already been fetched from
 155 the database and stored in the object.
 156
 157 =cut
 158
 159 sub get_column {
 160   my ($self, $column) = @_;
 161   $self->throw_exception( "Can't fetch data as class method" ) unless ref $self;
 162   return $self->{_column_data}{$column}
 163     if exists $self->{_column_data}{$column};
 164   $self->throw_exception( "No such column '${column}'" ) unless $self->has_column($column);
 165   return undef;
 166 }
 167
 168 =head2 get_columns
 169
 170   my %data = $obj->get_columns;
 171
 172 Does C<get_column>, for all column values at once.
 173
 174 =cut
 175
 176 sub get_columns {
 177   my $self = shift;
 178   return %{$self->{_column_data}};
 179 }
 180
 181 =head2 get_dirty_columns
 182
 183   my %data = $obj->get_dirty_columns;
 184
 185 Identical to get_columns but only returns those that have been changed.
 186
 187 =cut
 188
 189 sub get_dirty_columns {
 190   my $self = shift;
 191   return map { $_ => $self->{_column_data}{$_} }
 192            keys %{$self->{_dirty_columns}};
 193 }
 194
 195 =head2 set_column
 196
 197   $obj->set_column($col => $val);
 198
 199 Sets a column value. If the new value is different from the old one,
 200 the column is marked as dirty for when you next call $obj->update.
 201
 202 =cut
 203
 204 sub set_column {
 205   my $self = shift;
 206   my ($column) = @_;
 207   my $old = $self->get_column($column);
 208   my $ret = $self->store_column(@_);
 209   $self->{_dirty_columns}{$column} = 1
 210     if (defined $old ^ defined $ret) || (defined $old && $old ne $ret);
 211   return $ret;
 212 }
 213
 214 =head2 set_columns
 215
 216   my $copy = $orig->set_columns({ $col => $val, ... });
 217
 218 Sets more than one column value at once.
 219
 220 =cut
 221
 222 sub set_columns {
 223   my ($self,$data) = @_;
 224   while (my ($col,$val) = each %$data) {
 225     $self->set_column($col,$val);
 226   }
 227   return $self;
 228 }
 229
 230 =head2 copy
 231
 232   my $copy = $orig->copy({ change => $to, ... });
 233
 234 Inserts a new row with the specified changes.
 235
 236 =cut
 237
 238 sub copy {
 239   my ($self, $changes) = @_;
 240   my $new = bless({ _column_data => { %{$self->{_column_data}}} }, ref $self);
 241   $new->set_column($_ => $changes->{$_}) for keys %$changes;
 242   return $new->insert;
 243 }
 244
 245 =head2 store_column
 246
 247   $obj->store_column($col => $val);
 248
 249 Sets a column value without marking it as dirty.
 250
 251 =cut
 252
 253 sub store_column {
 254   my ($self, $column, $value) = @_;
 255   $self->throw_exception( "No such column '${column}'" )
 256     unless exists $self->{_column_data}{$column} || $self->has_column($column);
 257   $self->throw_exception( "set_column called for ${column} without value" )
 258     if @_ < 3;
 259   return $self->{_column_data}{$column} = $value;
 260 }
 261
 262 =head2 inflate_result
 263
 264   Class->inflate_result($result_source, \%me, \%prefetch?)
 265
 266 Called by ResultSet to inflate a result from storage
 267
 268 =cut
 269
 270 sub inflate_result {
 271   my ($class, $source, $me, $prefetch) = @_;
 272   #use Data::Dumper; print Dumper(@_);
 273   my $new = bless({ result_source => $source,
 274                     _column_data => $me,
 275                     _in_storage => 1
 276                   },
 277                   ref $class || $class);
 278   my $schema;
 279   PRE: foreach my $pre (keys %{$prefetch||{}}) {
 280     my $pre_source = $source->related_source($pre);
 281     $class->throw_exception("Can't prefetch non-existant relationship ${pre}") unless $pre_source;
 282     my $fetched;
 283     unless ($pre_source->primary_columns == grep { exists $prefetch->{$pre}[0]{$_}
 284        and !defined $prefetch->{$pre}[0]{$_} } $pre_source->primary_columns)
 285     {
 286       $fetched = $pre_source->result_class->inflate_result(
 287                       $pre_source, @{$prefetch->{$pre}});
 288     }
 289     my $accessor = $source->relationship_info($pre)->{attrs}{accessor};
 290     $class->throw_exception("No accessor for prefetched $pre")
 291       unless defined $accessor;
 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