Commit | Line | Data |
dbd7896f |
1 | package DBIx::Class::PK; |
2 | |
3 | use strict; |
4 | use warnings; |
6eec7501 |
5 | use Tie::IxHash; |
dbd7896f |
6 | |
1edd1722 |
7 | use base qw/DBIx::Class::Row/; |
dbd7896f |
8 | |
9 | __PACKAGE__->mk_classdata('_primaries' => {}); |
10 | |
34d52be2 |
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 | |
dbd7896f |
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 | |
076652e8 |
38 | =item set_primary_key <@cols> |
39 | |
40 | define one or more columns as primary key for this class |
41 | |
42 | =cut |
43 | |
510ca912 |
44 | sub set_primary_key { |
dbd7896f |
45 | my ($class, @cols) = @_; |
6a94f7f4 |
46 | # check if primary key columns are valid columns |
47 | for (@cols) { |
48 | $class->throw( "Column $_ can't be used as primary key because it isn't defined in $class" ) |
49 | unless $class->has_column($_); |
50 | } |
dbd7896f |
51 | my %pri; |
48700d09 |
52 | tie %pri, 'Tie::IxHash', map { $_ => {} } @cols; |
dbd7896f |
53 | $class->_primaries(\%pri); |
54 | } |
55 | |
076652e8 |
56 | =item find |
57 | |
58 | Finds columns based on the primary key(s). |
59 | |
60 | =cut |
61 | |
656796f2 |
62 | sub find { |
dbd7896f |
63 | my ($class, @vals) = @_; |
c687b87e |
64 | my $attrs = (@vals > 1 && ref $vals[$#vals] eq 'HASH' ? pop(@vals) : {}); |
dbd7896f |
65 | my @pk = keys %{$class->_primaries}; |
656796f2 |
66 | $class->throw( "Can't find unless primary columns are defined" ) |
78bab9ca |
67 | unless @pk; |
dbd7896f |
68 | my $query; |
69 | if (ref $vals[0] eq 'HASH') { |
70 | $query = $vals[0]; |
a3018bd3 |
71 | } elsif (@pk == @vals) { |
1a14aa3f |
72 | $query = {}; |
73 | @{$query}{@pk} = @vals; |
74 | #my $ret = ($class->search_literal($class->_ident_cond, @vals, $attrs))[0]; |
12bbb339 |
75 | #warn "$class: ".join(', ', %{$ret->{_column_data}}); |
1a14aa3f |
76 | #return $ret; |
dbd7896f |
77 | } else { |
78 | $query = {@vals}; |
79 | } |
656796f2 |
80 | $class->throw( "Can't find unless all primary keys are specified" ) |
dbd7896f |
81 | unless (keys %$query >= @pk); # If we check 'em we run afoul of uc/lc |
82 | # column names etc. Not sure what to do yet |
1a14aa3f |
83 | #return $class->search($query)->next; |
84 | my @cols = $class->_select_columns; |
85 | my @row = $class->storage->select_single($class->_table_name, \@cols, $query); |
86 | return (@row ? $class->_row_to_object(\@cols, \@row) : ()); |
dbd7896f |
87 | } |
88 | |
076652e8 |
89 | =item discard_changes |
90 | |
91 | Roll back changes that hasn't been comitted to the database. |
92 | |
93 | =cut |
94 | |
510ca912 |
95 | sub discard_changes { |
96 | my ($self) = @_; |
97 | delete $self->{_dirty_columns}; |
8d5134b0 |
98 | return unless $self->in_storage; # Don't reload if we aren't real! |
656796f2 |
99 | my ($reload) = $self->find($self->id); |
c1d23573 |
100 | unless ($reload) { # If we got deleted in the mean-time |
8d5134b0 |
101 | $self->in_storage(0); |
c1d23573 |
102 | return $self; |
103 | } |
4a07648a |
104 | delete @{$self}{keys %$self}; |
105 | @{$self}{keys %$reload} = values %$reload; |
c1d23573 |
106 | return $self; |
510ca912 |
107 | } |
108 | |
076652e8 |
109 | =item id |
110 | |
111 | returns the primary key(s) for the current row. Can't be called as |
112 | a class method. |
113 | |
114 | =cut |
115 | |
604d9f38 |
116 | sub id { |
117 | my ($self) = @_; |
78bab9ca |
118 | $self->throw( "Can't call id() as a class method" ) unless ref $self; |
604d9f38 |
119 | my @pk = $self->_ident_values; |
120 | return (wantarray ? @pk : $pk[0]); |
121 | } |
122 | |
076652e8 |
123 | =item primary_columns |
124 | |
125 | read-only accessor which returns a list of primary keys. |
126 | |
127 | =cut |
128 | |
8b445e33 |
129 | sub primary_columns { |
130 | return keys %{shift->_primaries}; |
131 | } |
132 | |
48700d09 |
133 | sub ID { |
134 | my ($self) = @_; |
135 | $self->throw( "Can't call ID() as a class method" ) unless ref $self; |
136 | return undef unless $self->in_storage; |
137 | return $self->_create_ID(map { $_ => $self->{_column_data}{$_} } keys %{$self->_primaries}); |
138 | } |
139 | |
140 | sub _create_ID { |
141 | my ($class,%vals) = @_; |
90f3f5ff |
142 | return undef unless 0 == grep { !defined } values %vals; |
48700d09 |
143 | $class = ref $class || $class; |
144 | return join '|', $class, map { $_ . '=' . $vals{$_} } sort keys %vals; |
145 | } |
146 | |
103647d5 |
147 | sub ident_condition { |
148 | my ($self) = @_; |
149 | my %cond; |
150 | $cond{$_} = $self->get_column($_) for $self->primary_columns; |
151 | return \%cond; |
152 | } |
153 | |
dbd7896f |
154 | 1; |
34d52be2 |
155 | |
156 | =back |
157 | |
158 | =head1 AUTHORS |
159 | |
daec44b8 |
160 | Matt S. Trout <mst@shadowcatsystems.co.uk> |
34d52be2 |
161 | |
162 | =head1 LICENSE |
163 | |
164 | You may distribute this code under the same terms as Perl itself. |
165 | |
166 | =cut |
167 | |