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 Class::Accessor DBIx::Class::SQL/;
   7
   8 __PACKAGE__->mk_classdata('_columns' => {});
   9
  10 __PACKAGE__->mk_classdata('_table_name');
  11
  12 sub new {
  13   my ($class, $attrs) = @_;
  14   $class = ref $class if ref $class;
  15   my $new = bless({ _column_data => { } }, $class);
  16   if ($attrs) {
  17     die "attrs must be a hashref" unless ref($attrs) eq 'HASH';
  18     while (my ($k, $v) = each %{$attrs}) {
  19       $new->set($k => $v);
  20     }
  21   }
  22   $new->{_dirty_columns} = {};
  23   return $new;
  24 }
  25
  26 sub insert {
  27   my ($self) = @_;
  28   return if $self->{_in_database};
  29   my $sth = $self->_get_sth('insert', [ keys %{$self->{_column_data}} ],
  30                               $self->_table_name, undef);
  31   $sth->execute(values %{$self->{_column_data}});
  32   $self->{_in_database} = 1;
  33   $self->{_dirty_columns} = {};
  34   return $self;
  35 }
  36
  37 sub create {
  38   my ($class, $attrs) = @_;
  39   die "create needs a hashref" unless ref $attrs eq 'HASH';
  40   return $class->new($attrs)->insert;
  41 }
  42
  43 sub update {
  44   my ($self) = @_;
  45   die "Not in database" unless $self->{_in_database};
  46   my @to_update = keys %{$self->{_dirty_columns} || {}};
  47   return -1 unless @to_update;
  48   my $sth = $self->_get_sth('update', \@to_update,
  49                               $self->_table_name, $self->_ident_cond);
  50   my $rows = $sth->execute( (map { $self->{_column_data}{$_} } @to_update),
  51                   $self->_ident_values );
  52   if ($rows == 0) {
  53     die "Can't update $self: row not found";
  54   } elsif ($rows > 1) {
  55     die "Can't update $self: updated more than one row";
  56   }
  57   $self->{_dirty_columns} = {};
  58   return $self;
  59 }
  60
  61 sub delete {
  62   my $self = shift;
  63   if (ref $self) {
  64     my $sth = $self->_get_sth('delete', undef,
  65                                 $self->_table_name, $self->_ident_cond);
  66     $sth->execute($self->_ident_values);
  67     $sth->finish;
  68     delete $self->{_in_database};
  69   } else {
  70     my $query = (ref $_[0] eq 'HASH' ? $_[0] : {@_});
  71     my ($cond, $param) = $self->_where_from_hash($query);
  72     my $sth = $self->_get_sth('delete', undef, $self->_table_name, $cond);
  73     $sth->execute(@$param);
  74     $sth->finish;
  75   }
  76   return $self;
  77 }
  78
  79 sub discard_changes {
  80   my ($self) = @_;
  81   $_[0] = $self->retrieve($self->id);
  82 }
  83
  84 sub get {
  85   my ($self, $column) = @_;
  86   die "Can't fetch data as class method" unless ref $self;
  87   #die "No such column '${column}'" unless $self->_columns->{$column};
  88   return $self->{_column_data}{$column} if $self->_columns->{$column};
  89   return shift->SUPER::get(@_);
  90 }
  91
  92 sub set {
  93   my ($self, $column, $value) = @_;
  94   #die "No such column '${column}'" unless $self->_columns->{$column};
  95   #die "set_column called for ${column} without value" if @_ < 3;
  96   if ($self->_columns->{$column}) {
  97     $self->{_dirty_columns}{$column} = 1;
  98     return $self->{_column_data}{$column} = $value;
  99   }
 100   return shift->SUPER::set(@_);
 101 }
 102
 103 sub _register_columns {
 104   my ($class, @cols) = @_;
 105   my $names = { %{$class->_columns} };
 106   $names->{$_} ||= {} for @cols;
 107   $class->_columns($names);
 108 }
 109
 110 sub _mk_column_accessors {
 111   my ($class, @cols) = @_;
 112   $class->mk_accessors(@cols);
 113 }
 114
 115 sub set_columns {
 116   my ($class, @cols) = @_;
 117   $class->_register_columns(@cols);
 118   $class->_mk_column_accessors(@cols);
 119 }
 120
 121 sub retrieve_from_sql {
 122   my ($class, $cond, @vals) = @_;
 123   $cond =~ s/^\s*WHERE//i;
 124   my @cols = $class->_select_columns;
 125   my $sth = $class->_get_sth( 'select', \@cols, $class->_table_name, $cond);
 126   $sth->execute(@vals);
 127   my @found;
 128   while (my @row = $sth->fetchrow_array) {
 129     my $new = $class->new;
 130     $new->set($_, shift @row) for @cols;
 131     $new->{_in_database} = 1;
 132     $new->{_dirty_columns} = {};
 133     push(@found, $new);
 134   }
 135   return @found;
 136 }
 137
 138 sub search {
 139   my $class    = shift;
 140   my $where    = ref $_[0] eq "HASH" ? shift: {@_};
 141   my ($cond, $param)  = $class->_where_from_hash($where);
 142   return $class->retrieve_from_sql($cond, @{$param});
 143 }
 144
 145 sub search_like {
 146   my $class    = shift;
 147   my $where    = ref $_[0] eq "HASH" ? shift: {@_};
 148   my ($cond, $param)  = $class->_where_from_hash($where, { cmp => 'like' });
 149   return $class->retrieve_from_sql($cond, @{$param});
 150 }
 151
 152 sub _select_columns {
 153   return keys %{$_[0]->_columns};
 154 }
 155
 156 sub copy {
 157   my ($self, $changes) = @_;
 158   my $new = bless({ _column_data => { %{$self->{_column_data}}} }, ref $self);
 159   $new->set($_ => $changes->{$_}) for keys %$changes;
 160   return $new->insert;
 161 }
 162
 163 sub _where_from_hash {
 164   my ($self, $query, $opts) = @_;
 165   my $op = $opts->{'cmp'} || '=';
 166   my $cond = join(' AND ',
 167                map { (defined $query->{$_}
 168                        ? "$_ $op ?"
 169                        : (do { delete $query->{$_}; "$_ IS NULL"; }));
 170                    } keys %$query);
 171   return ($cond, [ values %$query ]);
 172 }
 173
 174 1;