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