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