lib/DBIx/Class/PK.pm

   1 package DBIx::Class::PK;
   2
   3 use strict;
   4 use warnings;
   5
   6 use base qw/Class::Data::Inheritable DBIx::Class::SQL/;
   7
   8 __PACKAGE__->mk_classdata('_primaries' => {});
   9
  10 sub _ident_cond {
  11   my ($class) = @_;
  12   return join(" AND ", map { "$_ = ?" } keys %{$class->_primaries});
  13 }
  14
  15 sub _ident_values {
  16   my ($self) = @_;
  17   return (map { $self->{_column_data}{$_} } keys %{$self->_primaries});
  18 }
  19
  20 sub set_primary_key {
  21   my ($class, @cols) = @_;
  22   my %pri;
  23   $pri{$_} = {} for @cols;
  24   $class->_primaries(\%pri);
  25 }
  26
  27 sub retrieve {
  28   my ($class, @vals) = @_;
  29   my @pk = keys %{$class->_primaries};
  30   die "Can't retrieve unless primary columns are defined" unless @pk;
  31   my $query;
  32   if (ref $vals[0] eq 'HASH') {
  33     $query = $vals[0];
  34   } elsif (@pk == @vals) {
  35     my $ret = ($class->retrieve_from_sql($class->_ident_cond, @vals))[0];
  36     #warn "$class: ".join(', ', %{$ret->{_column_data}});
  37     return $ret;
  38   } else {
  39     $query = {@vals};
  40   }
  41   die "Can't retrieve unless all primary keys are specified"
  42     unless (keys %$query >= @pk); # If we check 'em we run afoul of uc/lc
  43                                   # column names etc. Not sure what to do yet
  44   my $ret = ($class->search($query))[0];
  45   #warn "$class: ".join(', ', %{$ret->{_column_data}});
  46   return $ret;
  47 }
  48
  49 sub discard_changes {
  50   my ($self) = @_;
  51   delete $self->{_dirty_columns};
  52   $_[0] = $self->retrieve($self->id);
  53 }
  54
  55 1;