lib/DBIx/Class/Table.pm

   1 package DBIx::Class::Table;
   2
   3 use strict;
   4 use warnings;
   5
   6 use base qw/Class::Data::Inheritable DBIx::Class::SQL/;
   7
   8 __PACKAGE__->mk_classdata('_columns' => {});
   9
  10 __PACKAGE__->mk_classdata('_table_name');
  11
  12 __PACKAGE__->mk_classdata('table_alias'); # FIXME XXX
  13
  14 sub new {
  15   my ($class, $attrs) = @_;
  16   $class = ref $class if ref $class;
  17   my $new = bless({ _column_data => { } }, $class);
  18   if ($attrs) {
  19     die "attrs must be a hashref" unless ref($attrs) eq 'HASH';
  20     while (my ($k, $v) = each %{$attrs}) {
  21       $new->store_column($k => $v);
  22     }
  23   }
  24   return $new;
  25 }
  26
  27 sub insert {
  28   my ($self) = @_;
  29   return if $self->{_in_database};
  30   my $sth = $self->_get_sth('insert', [ keys %{$self->{_column_data}} ],
  31                               $self->_table_name, undef);
  32   $sth->execute(values %{$self->{_column_data}});
  33   $sth->finish;
  34   $self->{_in_database} = 1;
  35   $self->{_dirty_columns} = {};
  36   return $self;
  37 }
  38
  39 sub in_database {
  40   return $_[0]->{_in_database};
  41 }
  42
  43 sub create {
  44   my ($class, $attrs) = @_;
  45   die "create needs a hashref" unless ref $attrs eq 'HASH';
  46   return $class->new($attrs)->insert;
  47 }
  48
  49 sub update {
  50   my ($self) = @_;
  51   die "Not in database" unless $self->{_in_database};
  52   my @to_update = keys %{$self->{_dirty_columns} || {}};
  53   return -1 unless @to_update;
  54   my $sth = $self->_get_sth('update', \@to_update,
  55                               $self->_table_name, $self->_ident_cond);
  56   my $rows = $sth->execute( (map { $self->{_column_data}{$_} } @to_update),
  57                   $self->_ident_values );
  58   $sth->finish;
  59   if ($rows == 0) {
  60     die "Can't update $self: row not found";
  61   } elsif ($rows > 1) {
  62     die "Can't update $self: updated more than one row";
  63   }
  64   $self->{_dirty_columns} = {};
  65   return $self;
  66 }
  67
  68 sub delete {
  69   my $self = shift;
  70   if (ref $self) {
  71     die "Not in database" unless $self->{_in_database};
  72     #warn $self->_ident_cond.' '.join(', ', $self->_ident_values);
  73     my $sth = $self->_get_sth('delete', undef,
  74                                 $self->_table_name, $self->_ident_cond);
  75     $sth->execute($self->_ident_values);
  76     $sth->finish;
  77     delete $self->{_in_database};
  78   } else {
  79     my $attrs = { };
  80     if (@_ > 1 && ref $_[$#_] eq 'HASH') {
  81       $attrs = { %{ pop(@_) } };
  82     }
  83     my $query = (ref $_[0] eq 'HASH' ? $_[0] : {@_});
  84     my ($cond, @param) = $self->_cond_resolve($query, $attrs);
  85     my $sth = $self->_get_sth('delete', undef, $self->_table_name, $cond);
  86     $sth->execute(@param);
  87     $sth->finish;
  88   }
  89   return $self;
  90 }
  91
  92 sub get_column {
  93   my ($self, $column) = @_;
  94   die "Can't fetch data as class method" unless ref $self;
  95   die "No such column '${column}'" unless $self->_columns->{$column};
  96   return $self->{_column_data}{$column} if $self->_columns->{$column};
  97 }
  98
  99 sub set_column {
 100   my $self = shift;
 101   my ($column) = @_;
 102   my $ret = $self->store_column(@_);
 103   $self->{_dirty_columns}{$column} = 1;
 104   return $ret;
 105 }
 106
 107 sub store_column {
 108   my ($self, $column, $value) = @_;
 109   die "No such column '${column}'" unless $self->_columns->{$column};
 110   die "set_column called for ${column} without value" if @_ < 3;
 111   return $self->{_column_data}{$column} = $value;
 112 }
 113
 114 sub _register_columns {
 115   my ($class, @cols) = @_;
 116   my $names = { %{$class->_columns} };
 117   $names->{$_} ||= {} for @cols;
 118   $class->_columns($names);
 119 }
 120
 121 sub _mk_column_accessors {
 122   my ($class, @cols) = @_;
 123   $class->mk_group_accessors('column' => @cols);
 124 }
 125
 126 sub add_columns {
 127   my ($class, @cols) = @_;
 128   $class->_register_columns(@cols);
 129   $class->_mk_column_accessors(@cols);
 130 }
 131
 132 sub retrieve_from_sql {
 133   my ($class, $cond, @vals) = @_;
 134   $cond =~ s/^\s*WHERE//i;
 135   my $attrs = (ref $vals[$#vals] eq 'HASH' ? pop(@vals) : {});
 136   my @cols = $class->_select_columns($attrs);
 137   my $sth = $class->_get_sth( 'select', \@cols, $class->_table_name, $cond);
 138   #warn "$cond @vals";
 139   return $class->sth_to_objects($sth, \@vals, \@cols);
 140 }
 141
 142 sub sth_to_objects {
 143   my ($class, $sth, $args, $cols) = @_;
 144   my @cols = ((ref $cols eq 'ARRAY') ? @$cols : @{$sth->{NAME_lc}} );
 145   $sth->execute(@$args);
 146   my @found;
 147   while (my @row = $sth->fetchrow_array) {
 148     my $new = $class->new;
 149     $new->store_column($_, shift @row) for @cols;
 150     $new->{_in_database} = 1;
 151     push(@found, $new);
 152   }
 153   $sth->finish;
 154   return @found;
 155 }
 156
 157 sub search {
 158   my $class = shift;
 159   my $attrs = { };
 160   if (@_ > 1 && ref $_[$#_] eq 'HASH') {
 161     $attrs = { %{ pop(@_) } };
 162   }
 163   my $query    = ref $_[0] eq "HASH" ? shift: {@_};
 164   my ($cond, @param)  = $class->_cond_resolve($query, $attrs);
 165   return $class->retrieve_from_sql($cond, @param);
 166 }
 167
 168 sub search_like {
 169   my $class    = shift;
 170   my $attrs = { };
 171   if (@_ > 1 && ref $_[$#_] eq 'HASH') {
 172     $attrs = pop(@_);
 173   }
 174   return $class->search(@_, { %$attrs, cmp => 'LIKE' });
 175 }
 176
 177 sub _select_columns {
 178   return keys %{$_[0]->_columns};
 179 }
 180
 181 sub copy {
 182   my ($self, $changes) = @_;
 183   my $new = bless({ _column_data => { %{$self->{_column_data}}} }, ref $self);
 184   $new->set_column($_ => $changes->{$_}) for keys %$changes;
 185   return $new->insert;
 186 }
 187
 188 sub _cond_resolve {
 189   my ($self, $query, $attrs) = @_;
 190   return '1 = 1' unless keys %$query;
 191   my $op = $attrs->{'cmp'} || '=';
 192   my $cond = join(' AND ',
 193                map { (defined $query->{$_}
 194                        ? "$_ $op ?"
 195                        : (do { delete $query->{$_}; "$_ IS NULL"; }));
 196                    } keys %$query);
 197   return ($cond, values %$query);
 198 }
 199
 200 sub table {
 201   shift->_table_name(@_);
 202 }
 203
 204 1;