lib/DBIx/Class/PK.pm

   1 package DBIx::Class::PK;
   2
   3 use strict;
   4 use warnings;
   5
   6 use base qw/DBIx::Class::Row/;
   7
   8 =head1 NAME
   9
  10 DBIx::Class::PK - Primary Key class
  11
  12 =head1 SYNOPSIS
  13
  14 =head1 DESCRIPTION
  15
  16 This class contains methods for handling primary keys and methods
  17 depending on them.
  18
  19 =head1 METHODS
  20
  21 =cut
  22
  23 =head2 id
  24
  25 Returns the primary key(s) for a row. Can't be called as
  26 a class method.
  27
  28 =cut
  29
  30 sub id {
  31   my ($self) = @_;
  32   $self->throw_exception( "Can't call id() as a class method" )
  33     unless ref $self;
  34   my @id_vals = $self->_ident_values;
  35   return (wantarray ? @id_vals : $id_vals[0]);
  36 }
  37
  38 sub _ident_values {
  39   my ($self) = @_;
  40   my (@ids, @missing);
  41
  42   for ($self->_pri_cols) {
  43     push @ids, $self->get_column($_);
  44     push @missing, $_ if (! defined $ids[-1] and ! $self->has_column_loaded ($_) );
  45   }
  46
  47   if (@missing && $self->in_storage) {
  48     $self->throw_exception (
  49       'Unable to uniquely identify row object with missing PK columns: '
  50       . join (', ', @missing )
  51     );
  52   }
  53
  54   return @ids;
  55 }
  56
  57 =head2 ID
  58
  59 Returns a unique id string identifying a row object by primary key.
  60 Used by L<DBIx::Class::CDBICompat::LiveObjectIndex> and
  61 L<DBIx::Class::ObjectCache>.
  62
  63 =over
  64
  65 =item WARNING
  66
  67 The default C<_create_ID> method used by this function orders the returned
  68 values by the alphabetical order of the primary column names, B<unlike>
  69 the L</id> method, which follows the same order in which columns were fed
  70 to L<DBIx::Class::ResultSource/set_primary_key>.
  71
  72 =back
  73
  74 =cut
  75
  76 sub ID {
  77   my ($self) = @_;
  78   $self->throw_exception( "Can't call ID() as a class method" )
  79     unless ref $self;
  80   return undef unless $self->in_storage;
  81   return $self->_create_ID(%{$self->ident_condition});
  82 }
  83
  84 sub _create_ID {
  85   my ($self, %vals) = @_;
  86   return undef unless 0 == grep { !defined } values %vals;
  87   return join '|', ref $self || $self, $self->result_source->name,
  88     map { $_ . '=' . $vals{$_} } sort keys %vals;
  89 }
  90
  91 =head2 ident_condition
  92
  93   my $cond = $result_source->ident_condition();
  94
  95   my $cond = $result_source->ident_condition('alias');
  96
  97 Produces a condition hash to locate a row based on the primary key(s).
  98
  99 =cut
 100
 101 sub ident_condition {
 102   my ($self, $alias) = @_;
 103
 104   my @pks = $self->_pri_cols;
 105   my @vals = $self->_ident_values;
 106
 107   my (%cond, @undef);
 108   my $prefix = defined $alias ? $alias.'.' : '';
 109   for my $col (@pks) {
 110     if (! defined ($cond{$prefix.$col} = shift @vals) ) {
 111       push @undef, $col;
 112     }
 113   }
 114
 115   if (@undef && $self->in_storage) {
 116     $self->throw_exception (
 117       'Unable to construct row object identity condition due to NULL PK columns: '
 118       . join (', ', @undef)
 119     );
 120   }
 121
 122   return \%cond;
 123 }
 124
 125 1;
 126
 127 =head1 AUTHORS
 128
 129 Matt S. Trout <mst@shadowcatsystems.co.uk>
 130
 131 =head1 LICENSE
 132
 133 You may distribute this code under the same terms as Perl itself.
 134
 135 =cut
 136