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