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