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 | |
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 | |
510ca912 |
38 | sub set_primary_key { |
dbd7896f |
39 | my ($class, @cols) = @_; |
40 | my %pri; |
48700d09 |
41 | tie %pri, 'Tie::IxHash', map { $_ => {} } @cols; |
dbd7896f |
42 | $class->_primaries(\%pri); |
43 | } |
44 | |
656796f2 |
45 | sub find { |
dbd7896f |
46 | my ($class, @vals) = @_; |
c687b87e |
47 | my $attrs = (@vals > 1 && ref $vals[$#vals] eq 'HASH' ? pop(@vals) : {}); |
dbd7896f |
48 | my @pk = keys %{$class->_primaries}; |
656796f2 |
49 | $class->throw( "Can't find unless primary columns are defined" ) |
78bab9ca |
50 | unless @pk; |
dbd7896f |
51 | my $query; |
52 | if (ref $vals[0] eq 'HASH') { |
53 | $query = $vals[0]; |
a3018bd3 |
54 | } elsif (@pk == @vals) { |
1a14aa3f |
55 | $query = {}; |
56 | @{$query}{@pk} = @vals; |
57 | #my $ret = ($class->search_literal($class->_ident_cond, @vals, $attrs))[0]; |
12bbb339 |
58 | #warn "$class: ".join(', ', %{$ret->{_column_data}}); |
1a14aa3f |
59 | #return $ret; |
dbd7896f |
60 | } else { |
61 | $query = {@vals}; |
62 | } |
656796f2 |
63 | $class->throw( "Can't find unless all primary keys are specified" ) |
dbd7896f |
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 |
1a14aa3f |
66 | #return $class->search($query)->next; |
67 | my @cols = $class->_select_columns; |
68 | my @row = $class->storage->select_single($class->_table_name, \@cols, $query); |
69 | return (@row ? $class->_row_to_object(\@cols, \@row) : ()); |
dbd7896f |
70 | } |
71 | |
510ca912 |
72 | sub discard_changes { |
73 | my ($self) = @_; |
74 | delete $self->{_dirty_columns}; |
8d5134b0 |
75 | return unless $self->in_storage; # Don't reload if we aren't real! |
656796f2 |
76 | my ($reload) = $self->find($self->id); |
c1d23573 |
77 | unless ($reload) { # If we got deleted in the mean-time |
8d5134b0 |
78 | $self->in_storage(0); |
c1d23573 |
79 | return $self; |
80 | } |
4a07648a |
81 | delete @{$self}{keys %$self}; |
82 | @{$self}{keys %$reload} = values %$reload; |
83 | #$self->store_column($_ => $reload->get_column($_)) |
84 | # foreach keys %{$self->_columns}; |
c1d23573 |
85 | return $self; |
510ca912 |
86 | } |
87 | |
604d9f38 |
88 | sub id { |
89 | my ($self) = @_; |
78bab9ca |
90 | $self->throw( "Can't call id() as a class method" ) unless ref $self; |
604d9f38 |
91 | my @pk = $self->_ident_values; |
92 | return (wantarray ? @pk : $pk[0]); |
93 | } |
94 | |
8b445e33 |
95 | sub primary_columns { |
96 | return keys %{shift->_primaries}; |
97 | } |
98 | |
48700d09 |
99 | sub ID { |
100 | my ($self) = @_; |
101 | $self->throw( "Can't call ID() as a class method" ) unless ref $self; |
102 | return undef unless $self->in_storage; |
103 | return $self->_create_ID(map { $_ => $self->{_column_data}{$_} } keys %{$self->_primaries}); |
104 | } |
105 | |
106 | sub _create_ID { |
107 | my ($class,%vals) = @_; |
108 | $class = ref $class || $class; |
109 | return join '|', $class, map { $_ . '=' . $vals{$_} } sort keys %vals; |
110 | } |
111 | |
dbd7896f |
112 | 1; |
34d52be2 |
113 | |
114 | =back |
115 | |
116 | =head1 AUTHORS |
117 | |
daec44b8 |
118 | Matt S. Trout <mst@shadowcatsystems.co.uk> |
34d52be2 |
119 | |
120 | =head1 LICENSE |
121 | |
122 | You may distribute this code under the same terms as Perl itself. |
123 | |
124 | =cut |
125 | |