lib/DBIx/Class/Row.pm

   1 package DBIx::Class::Row;
   2
   3 use strict;
   4 use warnings;
   5
   6 use Carp qw/croak/;
   7
   8 use base qw/DBIx::Class/;
   9
  10 __PACKAGE__->load_components(qw/AccessorGroup/);
  11
  12 __PACKAGE__->mk_group_accessors('simple' => 'result_source');
  13
  14 =head1 NAME
  15
  16 DBIx::Class::Row - Basic row methods
  17
  18 =head1 SYNOPSIS
  19
  20 =head1 DESCRIPTION
  21
  22 This class is responsible for defining and doing basic operations on rows
  23 derived from L<DBIx::Class::Table> objects.
  24
  25 =head1 METHODS
  26
  27 =head2 new
  28
  29   my $obj = My::Class->new($attrs);
  30
  31 Creates a new row object from column => value mappings passed as a hash ref
  32
  33 =cut
  34
  35 sub new {
  36   my ($class, $attrs) = @_;
  37   $class = ref $class if ref $class;
  38   my $new = bless({ _column_data => { } }, $class);
  39   if ($attrs) {
  40     $new->throw("attrs must be a hashref" ) unless ref($attrs) eq 'HASH';
  41     while (my ($k, $v) = each %{$attrs}) {
  42       croak "No such column $k on $class" unless $class->has_column($k);
  43       $new->store_column($k => $v);
  44     }
  45   }
  46   return $new;
  47 }
  48
  49 =head2 insert
  50
  51   $obj->insert;
  52
  53 Inserts an object into the database if it isn't already in there. Returns
  54 the object itself. Requires the object's result source to be set, or the
  55 class to have a result_source_instance method.
  56
  57 =cut
  58
  59 sub insert {
  60   my ($self) = @_;
  61   return $self if $self->in_storage;
  62   $self->{result_source} ||= $self->result_source_instance
  63     if $self->can('result_source_instance');
  64   my $source = $self->{result_source};
  65   croak "No result_source set on this object; can't insert" unless $source;
  66   #use Data::Dumper; warn Dumper($self);
  67   $source->storage->insert($source->from, { $self->get_columns });
  68   $self->in_storage(1);
  69   $self->{_dirty_columns} = {};
  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( "Not in database" ) unless $self->in_storage;
 100   my %to_update = $self->get_dirty_columns;
 101   return $self unless keys %to_update;
 102   my $rows = $self->result_source->storage->update(
 103                $self->result_source->from, \%to_update, $self->ident_condition);
 104   if ($rows == 0) {
 105     $self->throw( "Can't update ${self}: row not found" );
 106   } elsif ($rows > 1) {
 107     $self->throw("Can't update ${self}: updated more than one row");
 108   }
 109   $self->{_dirty_columns} = {};
 110   return $self;
 111 }
 112
 113 =head2 delete
 114
 115   $obj->delete
 116
 117 Deletes the object from the database. The object is still perfectly usable
 118 accessor-wise etc. but ->in_storage will now return 0 and the object must
 119 be re ->insert'ed before it can be ->update'ed
 120
 121 =cut
 122
 123 sub delete {
 124   my $self = shift;
 125   if (ref $self) {
 126     $self->throw( "Not in database" ) unless $self->in_storage;
 127     $self->result_source->storage->delete(
 128       $self->result_source->from, $self->ident_condition);
 129     $self->in_storage(undef);
 130   } else {
 131     croak "Can't do class delete without a ResultSource instance"
 132       unless $self->can('result_source_instance');
 133     my $attrs = { };
 134     if (@_ > 1 && ref $_[$#_] eq 'HASH') {
 135       $attrs = { %{ pop(@_) } };
 136     }
 137     my $query = (ref $_[0] eq 'HASH' ? $_[0] : {@_});
 138     $self->result_source_instance->resultset->search(@_)->delete;
 139   }
 140   return $self;
 141 }
 142
 143 =head2 get_column
 144
 145   my $val = $obj->get_column($col);
 146
 147 Gets a column value from a row object. Currently, does not do
 148 any queries; the column must have already been fetched from
 149 the database and stored in the object.
 150
 151 =cut
 152
 153 sub get_column {
 154   my ($self, $column) = @_;
 155   $self->throw( "Can't fetch data as class method" ) unless ref $self;
 156   return $self->{_column_data}{$column}
 157     if exists $self->{_column_data}{$column};
 158   $self->throw( "No such column '${column}'" ) unless $self->has_column($column);
 159   return undef;
 160 }
 161
 162 =head2 get_columns
 163
 164   my %data = $obj->get_columns;
 165
 166 Does C<get_column>, for all column values at once.
 167
 168 =cut
 169
 170 sub get_columns {
 171   my $self = shift;
 172   return %{$self->{_column_data}};
 173 }
 174
 175 =head2 get_dirty_columns
 176
 177   my %data = $obj->get_dirty_columns;
 178
 179 Identical to get_columns but only returns those that have been changed.
 180
 181 =cut
 182
 183 sub get_dirty_columns {
 184   my $self = shift;
 185   return map { $_ => $self->{_column_data}{$_} }
 186            keys %{$self->{_dirty_columns}};
 187 }
 188
 189 =head2 set_column
 190
 191   $obj->set_column($col => $val);
 192
 193 Sets a column value. If the new value is different from the old one,
 194 the column is marked as dirty for when you next call $obj->update.
 195
 196 =cut
 197
 198 sub set_column {
 199   my $self = shift;
 200   my ($column) = @_;
 201   my $old = $self->get_column($column);
 202   my $ret = $self->store_column(@_);
 203   $self->{_dirty_columns}{$column} = 1
 204     if (defined $old ^ defined $ret) || (defined $old && $old ne $ret);
 205   return $ret;
 206 }
 207
 208 =head2 set_columns
 209
 210   my $copy = $orig->set_columns({ $col => $val, ... });
 211
 212 Sets more than one column value at once.
 213
 214 =cut
 215
 216 sub set_columns {
 217   my ($self,$data) = @_;
 218   while (my ($col,$val) = each %$data) {
 219     $self->set_column($col,$val);
 220   }
 221   return $self;
 222 }
 223
 224 =head2 copy
 225
 226   my $copy = $orig->copy({ change => $to, ... });
 227
 228 Inserts a new row with the specified changes.
 229
 230 =cut
 231
 232 sub copy {
 233   my ($self, $changes) = @_;
 234   my $new = bless({ _column_data => { %{$self->{_column_data}}} }, ref $self);
 235   $new->set_column($_ => $changes->{$_}) for keys %$changes;
 236   return $new->insert;
 237 }
 238
 239 =head2 store_column
 240
 241   $obj->store_column($col => $val);
 242
 243 Sets a column value without marking it as dirty.
 244
 245 =cut
 246
 247 sub store_column {
 248   my ($self, $column, $value) = @_;
 249   $self->throw( "No such column '${column}'" )
 250     unless exists $self->{_column_data}{$column} || $self->has_column($column);
 251   $self->throw( "set_column called for ${column} without value" )
 252     if @_ < 3;
 253   return $self->{_column_data}{$column} = $value;
 254 }
 255
 256 =head2 inflate_result
 257
 258   Class->inflate_result($result_source, \%me, \%prefetch?)
 259
 260 Called by ResultSet to inflate a result from storage
 261
 262 =cut
 263
 264 sub inflate_result {
 265   my ($class, $source, $me, $prefetch) = @_;
 266   #use Data::Dumper; print Dumper(@_);
 267   my $new = bless({ result_source => $source,
 268                     _column_data => $me,
 269                     _in_storage => 1
 270                   },
 271                   ref $class || $class);
 272   my $schema;
 273   PRE: foreach my $pre (keys %{$prefetch||{}}) {
 274     my $pre_source = $source->related_source($pre);
 275     croak "Can't prefetch non-existant relationship ${pre}" unless $pre_source;
 276     my $fetched = $pre_source->result_class->inflate_result(
 277                     $pre_source, @{$prefetch->{$pre}});
 278     my $accessor = $source->relationship_info($pre)->{attrs}{accessor};
 279     $class->throw("No accessor for prefetched $pre")
 280       unless defined $accessor;
 281     PRIMARY: foreach my $pri ($pre_source->primary_columns) {
 282       unless (defined $fetched->get_column($pri)) {
 283         undef $fetched;
 284         last PRIMARY;
 285       }
 286     }
 287     if ($accessor eq 'single') {
 288       $new->{_relationship_data}{$pre} = $fetched;
 289     } elsif ($accessor eq 'filter') {
 290       $new->{_inflated_column}{$pre} = $fetched;
 291     } else {
 292       $class->throw("Don't know how to store prefetched $pre");
 293     }
 294   }
 295   return $new;
 296 }
 297
 298 =head2 insert_or_update
 299
 300   $obj->insert_or_update
 301
 302 Updates the object if it's already in the db, else inserts it.
 303
 304 =cut
 305
 306 sub insert_or_update {
 307   my $self = shift;
 308   return ($self->in_storage ? $self->update : $self->insert);
 309 }
 310
 311 =head2 is_changed
 312
 313   my @changed_col_names = $obj->is_changed
 314
 315 =cut
 316
 317 sub is_changed {
 318   return keys %{shift->{_dirty_columns} || {}};
 319 }
 320
 321 =head2 result_source
 322
 323   Accessor to the ResultSource this object was created from
 324
 325 =head2 register_column($column, $column_info)
 326
 327   Registers a column on the class and creates an accessor for it
 328
 329 =cut
 330
 331 sub register_column {
 332   my ($class, $col, $info) = @_;
 333   $class->mk_group_accessors('column' => $col);
 334 }
 335
 336 1;
 337
 338 =head1 AUTHORS
 339
 340 Matt S. Trout <mst@shadowcatsystems.co.uk>
 341
 342 =head1 LICENSE
 343
 344 You may distribute this code under the same terms as Perl itself.
 345
 346 =cut
 347