X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2FPK.pm;h=0ef470b336af96abd656b776cb5c391733e4e4b8;hb=367eaf50970dd3fd223ce5e1f0337703f2a6c70e;hp=a25c4319c7fa07708bd7501c0174a4133c149c3d;hpb=b946a283391c836663b4238c681c1a6f62f75394;p=dbsrgits%2FDBIx-Class.git diff --git a/lib/DBIx/Class/PK.pm b/lib/DBIx/Class/PK.pm index a25c431..0ef470b 100644 --- a/lib/DBIx/Class/PK.pm +++ b/lib/DBIx/Class/PK.pm @@ -5,6 +5,9 @@ use warnings; use base qw/DBIx::Class::Row/; +use DBIx::Class::_Util 'fail_on_internal_call'; +use namespace::clean; + =head1 NAME DBIx::Class::PK - Primary Key class @@ -27,26 +30,34 @@ a class method. =cut -sub id { - my ($self) = @_; - $self->throw_exception( "Can't call id() as a class method" ) - unless ref $self; - my @id_vals = $self->_ident_values; - return (wantarray ? @id_vals : $id_vals[0]); +sub id :DBIC_method_is_indirect_sugar { + DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call; + + $_[0]->throw_exception( "Can't call id() as a class method" ) + unless ref $_[0]; + + wantarray + ? $_[0]->_ident_values + : ($_[0]->_ident_values)[0] # FIXME - horrible horrible legacy crap + ; } sub _ident_values { - my ($self) = @_; + my ($self, $use_storage_state) = @_; + my (@ids, @missing); - for ($self->_pri_cols) { - push @ids, $self->get_column($_); + for ($self->result_source->_pri_cols_or_die) { + push @ids, ($use_storage_state and exists $self->{_column_data_in_storage}{$_}) + ? $self->{_column_data_in_storage}{$_} + : $self->get_column($_) + ; push @missing, $_ if (! defined $ids[-1] and ! $self->has_column_loaded ($_) ); } if (@missing && $self->in_storage) { $self->throw_exception ( - 'Unable to uniquely identify row object with missing PK columns: ' + 'Unable to uniquely identify result object with missing PK columns: ' . join (', ', @missing ) ); } @@ -56,7 +67,7 @@ sub _ident_values { =head2 ID -Returns a unique id string identifying a row object by primary key. +Returns a unique id string identifying a result object by primary key. Used by L and L. @@ -83,7 +94,7 @@ sub ID { sub _create_ID { my ($self, %vals) = @_; - return undef unless 0 == grep { !defined } values %vals; + return undef if grep { !defined } values %vals; return join '|', ref $self || $self, $self->result_source->name, map { $_ . '=' . $vals{$_} } sort keys %vals; } @@ -99,10 +110,18 @@ Produces a condition hash to locate a row based on the primary key(s). =cut sub ident_condition { - my ($self, $alias) = @_; + shift->_mk_ident_cond(@_); +} + +sub _storage_ident_condition { + shift->_mk_ident_cond(shift, 1); +} + +sub _mk_ident_cond { + my ($self, $alias, $use_storage_state) = @_; - my @pks = $self->_pri_cols; - my @vals = $self->_ident_values; + my @pks = $self->result_source->_pri_cols_or_die; + my @vals = $self->_ident_values($use_storage_state); my (%cond, @undef); my $prefix = defined $alias ? $alias.'.' : ''; @@ -114,7 +133,7 @@ sub ident_condition { if (@undef && $self->in_storage) { $self->throw_exception ( - 'Unable to construct row object identity condition due to NULL PK columns: ' + 'Unable to construct result object identity condition due to NULL PK columns: ' . join (', ', @undef) ); } @@ -122,15 +141,17 @@ sub ident_condition { return \%cond; } -1; - -=head1 AUTHORS +=head1 FURTHER QUESTIONS? -Matt S. Trout +Check the list of L. -=head1 LICENSE +=head1 COPYRIGHT AND LICENSE -You may distribute this code under the same terms as Perl itself. +This module is free software L +by the L. You can +redistribute it and/or modify it under the same terms as the +L. =cut +1;