4d46421eb1b93f5d4945696f8a9a9790c20a6512
[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/DBIx::Class::Row/;
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 contains methods for handling primary keys and methods 
20 depending on them.
21
22 =head1 METHODS
23
24 =cut
25
26 sub _ident_cond {
27   my ($class) = @_;
28   return join(" AND ", map { "$_ = ?" } keys %{$class->_primaries});
29 }
30
31 sub _ident_values {
32   my ($self) = @_;
33   return (map { $self->{_column_data}{$_} } keys %{$self->_primaries});
34 }
35
36 =head2 set_primary_key(@cols)
37
38 Defines one or more columns as primary key for this class. Should be
39 called after C<columns>.
40
41 =cut
42
43 sub set_primary_key {
44   my ($class, @cols) = @_;
45   # check if primary key columns are valid columns
46   for (@cols) {
47     $class->throw( "Column $_ can't be used as primary key because it isn't defined in $class" )
48       unless $class->has_column($_);
49   }
50   my %pri;
51   tie %pri, 'Tie::IxHash', map { $_ => {} } @cols;
52   $class->_primaries(\%pri);
53 }
54
55 =head2 find(@colvalues), find(\%cols)
56
57 Finds a row based on its primary key(s).
58
59 =cut
60
61 sub find {
62   my ($class, @vals) = @_;
63   my $attrs = (@vals > 1 && ref $vals[$#vals] eq 'HASH' ? pop(@vals) : {});
64   my @pk = keys %{$class->_primaries};
65   $class->throw( "Can't find unless primary columns are defined" ) 
66     unless @pk;
67   my $query;
68   if (ref $vals[0] eq 'HASH') {
69     $query = $vals[0];
70   } elsif (@pk == @vals) {
71     $query = {};
72     @{$query}{@pk} = @vals;
73     #my $ret = ($class->search_literal($class->_ident_cond, @vals, $attrs))[0];
74     #warn "$class: ".join(', ', %{$ret->{_column_data}});
75     #return $ret;
76   } else {
77     $query = {@vals};
78   }
79   $class->throw( "Can't find unless all primary keys are specified" )
80     unless (keys %$query >= @pk); # If we check 'em we run afoul of uc/lc
81                                   # column names etc. Not sure what to do yet
82   return $class->search($query)->next;
83   #my @cols = $class->_select_columns;
84   #my @row = $class->storage->select_single($class->_table_name, \@cols, $query);
85   #return (@row ? $class->_row_to_object(\@cols, \@row) : ());
86 }
87
88 =head2 discard_changes
89
90 Re-selects the row from the database, losing any changes that had
91 been made.
92
93 =cut
94
95 sub discard_changes {
96   my ($self) = @_;
97   delete $self->{_dirty_columns};
98   return unless $self->in_storage; # Don't reload if we aren't real!
99   my ($reload) = $self->find($self->id);
100   unless ($reload) { # If we got deleted in the mean-time
101     $self->in_storage(0);
102     return $self;
103   }
104   delete @{$self}{keys %$self};
105   @{$self}{keys %$reload} = values %$reload;
106   return $self;
107 }
108
109 =head2 id
110
111 Returns the primary key(s) for a row. Can't be called as
112 a class method.
113
114 =cut
115
116 sub id {
117   my ($self) = @_;
118   $self->throw( "Can't call id() as a class method" ) unless ref $self;
119   my @pk = $self->_ident_values;
120   return (wantarray ? @pk : $pk[0]);
121 }
122
123 =head2 primary_columns
124
125 Read-only accessor which returns the list of primary keys for a class
126 (in scalar context, only returns the first primary key).
127
128 =cut
129
130 sub primary_columns {
131   return keys %{shift->_primaries};
132 }
133
134 =head2 ID
135
136 Returns a unique id string identifying a row object by primary key.
137 Used by L<DBIx::Class::CDBICompat::LiveObjectIndex> and 
138 L<DBIx::Class::ObjectCache>.
139
140 =cut
141
142 sub ID {
143   my ($self) = @_;
144   $self->throw( "Can't call ID() as a class method" ) unless ref $self;
145   return undef unless $self->in_storage;
146   return $self->_create_ID(map { $_ => $self->{_column_data}{$_} } keys %{$self->_primaries});
147 }
148
149 sub _create_ID {
150   my ($class,%vals) = @_;
151   return undef unless 0 == grep { !defined } values %vals;
152   $class = ref $class || $class;
153   return join '|', $class, map { $_ . '=' . $vals{$_} } sort keys %vals;    
154 }
155
156 sub ident_condition {
157   my ($self) = @_;
158   my %cond;
159   $cond{$_} = $self->get_column($_) for $self->primary_columns;
160   return \%cond;
161 }
162
163 1;
164
165 =head1 AUTHORS
166
167 Matt S. Trout <mst@shadowcatsystems.co.uk>
168
169 =head1 LICENSE
170
171 You may distribute this code under the same terms as Perl itself.
172
173 =cut
174