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