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::Table> 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 $rows = $self->result_source->storage->update(
 102                $self->result_source->from, \%to_update, $self->ident_condition);
 103   if ($rows == 0) {
 104     $self->throw_exception( "Can't update ${self}: row not found" );
 105   } elsif ($rows > 1) {
 106     $self->throw_exception("Can't update ${self}: updated more than one row");
 107   }
 108   $self->{_dirty_columns} = {};
 109   return $self;
 110 }
 111
 112 =head2 delete
 113
 114   $obj->delete
 115
 116 Deletes the object from the database. The object is still perfectly usable
 117 accessor-wise etc. but ->in_storage will now return 0 and the object must
 118 be re ->insert'ed before it can be ->update'ed
 119
 120 =cut
 121
 122 sub delete {
 123   my $self = shift;
 124   if (ref $self) {
 125     $self->throw_exception( "Not in database" ) unless $self->in_storage;
 126     $self->result_source->storage->delete(
 127       $self->result_source->from, $self->ident_condition);
 128     $self->in_storage(undef);
 129   } else {
 130     $self->throw_exception("Can't do class delete without a ResultSource instance")
 131       unless $self->can('result_source_instance');
 132     my $attrs = { };
 133     if (@_ > 1 && ref $_[$#_] eq 'HASH') {
 134       $attrs = { %{ pop(@_) } };
 135     }
 136     my $query = (ref $_[0] eq 'HASH' ? $_[0] : {@_});
 137     $self->result_source_instance->resultset->search(@_)->delete;
 138   }
 139   return $self;
 140 }
 141
 142 =head2 get_column
 143
 144   my $val = $obj->get_column($col);
 145
 146 Gets a column value from a row object. Currently, does not do
 147 any queries; the column must have already been fetched from
 148 the database and stored in the object.
 149
 150 =cut
 151
 152 sub get_column {
 153   my ($self, $column) = @_;
 154   $self->throw_exception( "Can't fetch data as class method" ) unless ref $self;
 155   return $self->{_column_data}{$column}
 156     if exists $self->{_column_data}{$column};
 157   $self->throw_exception( "No such column '${column}'" ) unless $self->has_column($column);
 158   return undef;
 159 }
 160
 161 =head2 get_columns
 162
 163   my %data = $obj->get_columns;
 164
 165 Does C<get_column>, for all column values at once.
 166
 167 =cut
 168
 169 sub get_columns {
 170   my $self = shift;
 171   return %{$self->{_column_data}};
 172 }
 173
 174 =head2 get_dirty_columns
 175
 176   my %data = $obj->get_dirty_columns;
 177
 178 Identical to get_columns but only returns those that have been changed.
 179
 180 =cut
 181
 182 sub get_dirty_columns {
 183   my $self = shift;
 184   return map { $_ => $self->{_column_data}{$_} }
 185            keys %{$self->{_dirty_columns}};
 186 }
 187
 188 =head2 set_column
 189
 190   $obj->set_column($col => $val);
 191
 192 Sets a column value. If the new value is different from the old one,
 193 the column is marked as dirty for when you next call $obj->update.
 194
 195 =cut
 196
 197 sub set_column {
 198   my $self = shift;
 199   my ($column) = @_;
 200   my $old = $self->get_column($column);
 201   my $ret = $self->store_column(@_);
 202   $self->{_dirty_columns}{$column} = 1
 203     if (defined $old ^ defined $ret) || (defined $old && $old ne $ret);
 204   return $ret;
 205 }
 206
 207 =head2 set_columns
 208
 209   my $copy = $orig->set_columns({ $col => $val, ... });
 210
 211 Sets more than one column value at once.
 212
 213 =cut
 214
 215 sub set_columns {
 216   my ($self,$data) = @_;
 217   while (my ($col,$val) = each %$data) {
 218     $self->set_column($col,$val);
 219   }
 220   return $self;
 221 }
 222
 223 =head2 copy
 224
 225   my $copy = $orig->copy({ change => $to, ... });
 226
 227 Inserts a new row with the specified changes.
 228
 229 =cut
 230
 231 sub copy {
 232   my ($self, $changes) = @_;
 233   my $new = bless({ _column_data => { %{$self->{_column_data}}} }, ref $self);
 234   $new->set_column($_ => $changes->{$_}) for keys %$changes;
 235   return $new->insert;
 236 }
 237
 238 =head2 store_column
 239
 240   $obj->store_column($col => $val);
 241
 242 Sets a column value without marking it as dirty.
 243
 244 =cut
 245
 246 sub store_column {
 247   my ($self, $column, $value) = @_;
 248   $self->throw_exception( "No such column '${column}'" )
 249     unless exists $self->{_column_data}{$column} || $self->has_column($column);
 250   $self->throw_exception( "set_column called for ${column} without value" )
 251     if @_ < 3;
 252   return $self->{_column_data}{$column} = $value;
 253 }
 254
 255 =head2 inflate_result
 256
 257   Class->inflate_result($result_source, \%me, \%prefetch?)
 258
 259 Called by ResultSet to inflate a result from storage
 260
 261 =cut
 262
 263 sub inflate_result {
 264   my ($class, $source, $me, $prefetch) = @_;
 265   #use Data::Dumper; print Dumper(@_);
 266   my $new = bless({ result_source => $source,
 267                     _column_data => $me,
 268                     _in_storage => 1
 269                   },
 270                   ref $class || $class);
 271   my $schema;
 272   PRE: foreach my $pre (keys %{$prefetch||{}}) {
 273     my $pre_source = $source->related_source($pre);
 274     $class->throw_exception("Can't prefetch non-existant relationship ${pre}") unless $pre_source;
 275     my $fetched = $pre_source->result_class->inflate_result(
 276                     $pre_source, @{$prefetch->{$pre}});
 277     my $accessor = $source->relationship_info($pre)->{attrs}{accessor};
 278     $class->throw_exception("No accessor for prefetched $pre")
 279       unless defined $accessor;
 280     PRIMARY: foreach my $pri ($pre_source->primary_columns) {
 281       unless (defined $fetched->get_column($pri)) {
 282         undef $fetched;
 283         last PRIMARY;
 284       }
 285     }
 286     if ($accessor eq 'single') {
 287       $new->{_relationship_data}{$pre} = $fetched;
 288     } elsif ($accessor eq 'filter') {
 289       $new->{_inflated_column}{$pre} = $fetched;
 290     } else {
 291       $class->throw_exception("Don't know how to store prefetched $pre");
 292     }
 293   }
 294   return $new;
 295 }
 296
 297 =head2 insert_or_update
 298
 299   $obj->insert_or_update
 300
 301 Updates the object if it's already in the db, else inserts it.
 302
 303 =cut
 304
 305 sub insert_or_update {
 306   my $self = shift;
 307   return ($self->in_storage ? $self->update : $self->insert);
 308 }
 309
 310 =head2 is_changed
 311
 312   my @changed_col_names = $obj->is_changed
 313
 314 =cut
 315
 316 sub is_changed {
 317   return keys %{shift->{_dirty_columns} || {}};
 318 }
 319
 320 =head2 result_source
 321
 322   Accessor to the ResultSource this object was created from
 323
 324 =head2 register_column($column, $column_info)
 325
 326   Registers a column on the class and creates an accessor for it
 327
 328 =cut
 329
 330 sub register_column {
 331   my ($class, $col, $info) = @_;
 332   $class->mk_group_accessors('column' => $col);
 333 }
 334
 335
 336 =item throw_exception
 337
 338 See Schema's throw_exception.
 339
 340 =cut
 341
 342 sub throw_exception {
 343   my $self=shift;
 344   if (ref $self && ref $self->result_source) {
 345     $self->result_source->schema->throw_exception(@_);
 346   } else {
 347     croak(@_);
 348   }
 349 }
 350
 351 1;
 352
 353 =head1 AUTHORS
 354
 355 Matt S. Trout <mst@shadowcatsystems.co.uk>
 356
 357 =head1 LICENSE
 358
 359 You may distribute this code under the same terms as Perl itself.
 360
 361 =cut
 362