Fixed DBICTest Schema class names, added class_resolver system to make them work
[dbsrgits/DBIx-Class-Historic.git] / lib / DBIx / Class / PK.pm
CommitLineData
dbd7896f 1package DBIx::Class::PK;
2
3use strict;
4use warnings;
6eec7501 5use Tie::IxHash;
dbd7896f 6
95a70f01 7use base qw/Class::Data::Inheritable/;
dbd7896f 8
9__PACKAGE__->mk_classdata('_primaries' => {});
10
34d52be2 11=head1 NAME
12
13DBIx::Class::PK - Primary Key class
14
15=head1 SYNOPSIS
16
17=head1 DESCRIPTION
18
19This class represents methods handling primary keys
20and depending on them.
21
22=head1 METHODS
23
24=over 4
25
26=cut
27
28
dbd7896f 29sub _ident_cond {
30 my ($class) = @_;
31 return join(" AND ", map { "$_ = ?" } keys %{$class->_primaries});
32}
33
34sub _ident_values {
35 my ($self) = @_;
36 return (map { $self->{_column_data}{$_} } keys %{$self->_primaries});
37}
38
510ca912 39sub set_primary_key {
dbd7896f 40 my ($class, @cols) = @_;
41 my %pri;
6eec7501 42 tie %pri, 'Tie::IxHash';
43 %pri = map { $_ => {} } @cols;
dbd7896f 44 $class->_primaries(\%pri);
45}
46
656796f2 47sub find {
dbd7896f 48 my ($class, @vals) = @_;
c687b87e 49 my $attrs = (@vals > 1 && ref $vals[$#vals] eq 'HASH' ? pop(@vals) : {});
dbd7896f 50 my @pk = keys %{$class->_primaries};
656796f2 51 $class->throw( "Can't find unless primary columns are defined" )
78bab9ca 52 unless @pk;
dbd7896f 53 my $query;
54 if (ref $vals[0] eq 'HASH') {
55 $query = $vals[0];
a3018bd3 56 } elsif (@pk == @vals) {
656796f2 57 my $ret = ($class->search_literal($class->_ident_cond, @vals, $attrs))[0];
12bbb339 58 #warn "$class: ".join(', ', %{$ret->{_column_data}});
59 return $ret;
dbd7896f 60 } else {
61 $query = {@vals};
62 }
656796f2 63 $class->throw( "Can't find unless all primary keys are specified" )
dbd7896f 64 unless (keys %$query >= @pk); # If we check 'em we run afoul of uc/lc
65 # column names etc. Not sure what to do yet
12bbb339 66 my $ret = ($class->search($query))[0];
67 #warn "$class: ".join(', ', %{$ret->{_column_data}});
68 return $ret;
dbd7896f 69}
70
510ca912 71sub discard_changes {
72 my ($self) = @_;
73 delete $self->{_dirty_columns};
8d5134b0 74 return unless $self->in_storage; # Don't reload if we aren't real!
656796f2 75 my ($reload) = $self->find($self->id);
c1d23573 76 unless ($reload) { # If we got deleted in the mean-time
8d5134b0 77 $self->in_storage(0);
c1d23573 78 return $self;
79 }
4a07648a 80 delete @{$self}{keys %$self};
81 @{$self}{keys %$reload} = values %$reload;
82 #$self->store_column($_ => $reload->get_column($_))
83 # foreach keys %{$self->_columns};
c1d23573 84 return $self;
510ca912 85}
86
604d9f38 87sub id {
88 my ($self) = @_;
78bab9ca 89 $self->throw( "Can't call id() as a class method" ) unless ref $self;
604d9f38 90 my @pk = $self->_ident_values;
91 return (wantarray ? @pk : $pk[0]);
92}
93
8b445e33 94sub primary_columns {
95 return keys %{shift->_primaries};
96}
97
dbd7896f 981;
34d52be2 99
100=back
101
102=head1 AUTHORS
103
104Matt S. Trout <perl-stuff@trout.me.uk>
105
106=head1 LICENSE
107
108You may distribute this code under the same terms as Perl itself.
109
110=cut
111