Commit | Line | Data |
dbd7896f |
1 | package DBIx::Class::PK; |
2 | |
3 | use strict; |
4 | use warnings; |
6eec7501 |
5 | use Tie::IxHash; |
dbd7896f |
6 | |
95a70f01 |
7 | use base qw/Class::Data::Inheritable/; |
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 | |
28 | |
dbd7896f |
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 | |
510ca912 |
39 | sub 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 |
47 | sub 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) { |
1a14aa3f |
57 | $query = {}; |
58 | @{$query}{@pk} = @vals; |
59 | #my $ret = ($class->search_literal($class->_ident_cond, @vals, $attrs))[0]; |
12bbb339 |
60 | #warn "$class: ".join(', ', %{$ret->{_column_data}}); |
1a14aa3f |
61 | #return $ret; |
dbd7896f |
62 | } else { |
63 | $query = {@vals}; |
64 | } |
656796f2 |
65 | $class->throw( "Can't find unless all primary keys are specified" ) |
dbd7896f |
66 | unless (keys %$query >= @pk); # If we check 'em we run afoul of uc/lc |
67 | # column names etc. Not sure what to do yet |
1a14aa3f |
68 | #return $class->search($query)->next; |
69 | my @cols = $class->_select_columns; |
70 | my @row = $class->storage->select_single($class->_table_name, \@cols, $query); |
71 | return (@row ? $class->_row_to_object(\@cols, \@row) : ()); |
dbd7896f |
72 | } |
73 | |
510ca912 |
74 | sub discard_changes { |
75 | my ($self) = @_; |
76 | delete $self->{_dirty_columns}; |
8d5134b0 |
77 | return unless $self->in_storage; # Don't reload if we aren't real! |
656796f2 |
78 | my ($reload) = $self->find($self->id); |
c1d23573 |
79 | unless ($reload) { # If we got deleted in the mean-time |
8d5134b0 |
80 | $self->in_storage(0); |
c1d23573 |
81 | return $self; |
82 | } |
4a07648a |
83 | delete @{$self}{keys %$self}; |
84 | @{$self}{keys %$reload} = values %$reload; |
85 | #$self->store_column($_ => $reload->get_column($_)) |
86 | # foreach keys %{$self->_columns}; |
c1d23573 |
87 | return $self; |
510ca912 |
88 | } |
89 | |
604d9f38 |
90 | sub id { |
91 | my ($self) = @_; |
78bab9ca |
92 | $self->throw( "Can't call id() as a class method" ) unless ref $self; |
604d9f38 |
93 | my @pk = $self->_ident_values; |
94 | return (wantarray ? @pk : $pk[0]); |
95 | } |
96 | |
8b445e33 |
97 | sub primary_columns { |
98 | return keys %{shift->_primaries}; |
99 | } |
100 | |
dbd7896f |
101 | 1; |
34d52be2 |
102 | |
103 | =back |
104 | |
105 | =head1 AUTHORS |
106 | |
daec44b8 |
107 | Matt S. Trout <mst@shadowcatsystems.co.uk> |
34d52be2 |
108 | |
109 | =head1 LICENSE |
110 | |
111 | You may distribute this code under the same terms as Perl itself. |
112 | |
113 | =cut |
114 | |