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