Merge 'trunk' into 'DBIx-Class-C3'
[dbsrgits/DBIx-Class-Historic.git] / lib / DBIx / Class / PK.pm
CommitLineData
dbd7896f 1package DBIx::Class::PK;
2
3use strict;
4use warnings;
6eec7501 5use Tie::IxHash;
dbd7896f 6
1edd1722 7use base qw/DBIx::Class::Row/;
dbd7896f 8
9__PACKAGE__->mk_classdata('_primaries' => {});
10
34d52be2 11=head1 NAME
12
13DBIx::Class::PK - Primary Key class
14
15=head1 SYNOPSIS
16
17=head1 DESCRIPTION
18
19This class represents methods handling primary keys
20and depending on them.
21
22=head1 METHODS
23
24=over 4
25
26=cut
27
dbd7896f 28sub _ident_cond {
29 my ($class) = @_;
30 return join(" AND ", map { "$_ = ?" } keys %{$class->_primaries});
31}
32
33sub _ident_values {
34 my ($self) = @_;
35 return (map { $self->{_column_data}{$_} } keys %{$self->_primaries});
36}
37
076652e8 38=item set_primary_key <@cols>
39
40define one or more columns as primary key for this class
41
42=cut
43
510ca912 44sub set_primary_key {
dbd7896f 45 my ($class, @cols) = @_;
46 my %pri;
48700d09 47 tie %pri, 'Tie::IxHash', map { $_ => {} } @cols;
dbd7896f 48 $class->_primaries(\%pri);
49}
50
076652e8 51=item find
52
53Finds columns based on the primary key(s).
54
55=cut
56
656796f2 57sub find {
dbd7896f 58 my ($class, @vals) = @_;
c687b87e 59 my $attrs = (@vals > 1 && ref $vals[$#vals] eq 'HASH' ? pop(@vals) : {});
dbd7896f 60 my @pk = keys %{$class->_primaries};
656796f2 61 $class->throw( "Can't find unless primary columns are defined" )
78bab9ca 62 unless @pk;
dbd7896f 63 my $query;
64 if (ref $vals[0] eq 'HASH') {
65 $query = $vals[0];
a3018bd3 66 } elsif (@pk == @vals) {
1a14aa3f 67 $query = {};
68 @{$query}{@pk} = @vals;
69 #my $ret = ($class->search_literal($class->_ident_cond, @vals, $attrs))[0];
12bbb339 70 #warn "$class: ".join(', ', %{$ret->{_column_data}});
1a14aa3f 71 #return $ret;
dbd7896f 72 } else {
73 $query = {@vals};
74 }
656796f2 75 $class->throw( "Can't find unless all primary keys are specified" )
dbd7896f 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
1a14aa3f 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) : ());
dbd7896f 82}
83
076652e8 84=item discard_changes
85
86Roll back changes that hasn't been comitted to the database.
87
88=cut
89
510ca912 90sub discard_changes {
91 my ($self) = @_;
92 delete $self->{_dirty_columns};
8d5134b0 93 return unless $self->in_storage; # Don't reload if we aren't real!
656796f2 94 my ($reload) = $self->find($self->id);
c1d23573 95 unless ($reload) { # If we got deleted in the mean-time
8d5134b0 96 $self->in_storage(0);
c1d23573 97 return $self;
98 }
4a07648a 99 delete @{$self}{keys %$self};
100 @{$self}{keys %$reload} = values %$reload;
c1d23573 101 return $self;
510ca912 102}
103
076652e8 104=item id
105
106returns the primary key(s) for the current row. Can't be called as
107a class method.
108
109=cut
110
604d9f38 111sub id {
112 my ($self) = @_;
78bab9ca 113 $self->throw( "Can't call id() as a class method" ) unless ref $self;
604d9f38 114 my @pk = $self->_ident_values;
115 return (wantarray ? @pk : $pk[0]);
116}
117
076652e8 118=item primary_columns
119
120read-only accessor which returns a list of primary keys.
121
122=cut
123
8b445e33 124sub primary_columns {
125 return keys %{shift->_primaries};
126}
127
48700d09 128sub 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
135sub _create_ID {
136 my ($class,%vals) = @_;
90f3f5ff 137 return undef unless 0 == grep { !defined } values %vals;
48700d09 138 $class = ref $class || $class;
139 return join '|', $class, map { $_ . '=' . $vals{$_} } sort keys %vals;
140}
141
103647d5 142sub ident_condition {
143 my ($self) = @_;
144 my %cond;
145 $cond{$_} = $self->get_column($_) for $self->primary_columns;
146 return \%cond;
147}
148
dbd7896f 1491;
34d52be2 150
151=back
152
153=head1 AUTHORS
154
daec44b8 155Matt S. Trout <mst@shadowcatsystems.co.uk>
34d52be2 156
157=head1 LICENSE
158
159You may distribute this code under the same terms as Perl itself.
160
161=cut
162