lib/DBIx/Class/Storage/DBI.pm

   1 package DBIx::Class::Storage::DBI;
   2
   3 use DBI;
   4
   5 use base qw/DBIx::Class/;
   6
   7 __PACKAGE__->load_components(qw/SQL::Abstract SQL Exception AccessorGroup/);
   8
   9 __PACKAGE__->mk_group_accessors('simple' => qw/connect_info _dbh/);
  10
  11 sub new {
  12   bless({}, ref $_[0] || $_[0]);
  13 }
  14
  15 sub get_simple {
  16   my ($self, $get) = @_;
  17   return $self->{$get};
  18 }
  19
  20 sub set_simple {
  21   my ($self, $set, $val) = @_;
  22   return $self->{$set} = $val;
  23 }
  24
  25 =head1 NAME
  26
  27 DBIx::Class::Storage::DBI - DBI storage handler
  28
  29 =head1 SYNOPSIS
  30
  31 =head1 DESCRIPTION
  32
  33 This class represents the connection to the database
  34
  35 =head1 METHODS
  36
  37 =over 4
  38
  39 =cut
  40
  41 sub dbh {
  42   my ($self) = @_;
  43   my $dbh;
  44   unless (($dbh = $self->_dbh) && $dbh->FETCH('Active') && $dbh->ping) {
  45     $self->_populate_dbh;
  46   }
  47   return $self->_dbh;
  48 }
  49
  50 sub _populate_dbh {
  51   my ($self) = @_;
  52   my @info = @{$self->connect_info || []};
  53   $self->_dbh($self->_connect(@info));
  54 }
  55
  56 sub _connect {
  57   my ($self, @info) = @_;
  58   return DBI->connect(@info);
  59 }
  60
  61 =item commit
  62
  63   $class->commit;
  64
  65 Issues a commit again the current dbh
  66
  67 =cut
  68
  69 sub commit { $_[0]->dbh->commit; }
  70
  71 =item rollback
  72
  73   $class->rollback;
  74
  75 Issues a rollback again the current dbh
  76
  77 =cut
  78
  79 sub rollback { $_[0]->dbh->rollback; }
  80
  81 sub insert {
  82   my ($self, $ident, $to_insert) = @_;
  83   my $sql = $self->create_sql('insert', [ keys %{$to_insert} ], $ident, undef);
  84   my $sth = $self->sth($sql);
  85   $sth->execute(values %{$to_insert});
  86   $self->throw( "Couldn't insert ".join(%to_insert)." into ${ident}" )
  87     unless $sth->rows;
  88   return $to_insert;
  89 }
  90
  91 sub update {
  92   my ($self, $ident, $to_update, $condition) = @_;
  93   my $attrs = { };
  94   my $set_sql = $self->_cond_resolve($to_update, $attrs, ',');
  95   $set_sql =~ s/^\(//;
  96   $set_sql =~ s/\)$//;
  97   my $cond_sql = $self->_cond_resolve($condition, $attrs);
  98   my $sql = $self->create_sql('update', $set_sql, $ident, $cond_sql);
  99   my $sth = $self->sth($sql);
 100   my $rows = $sth->execute( @{$attrs->{bind}||[]} );
 101   return $rows;
 102 }
 103
 104 sub delete {
 105   my ($self, $ident, $condition) = @_;
 106   my $attrs = { };
 107   my $cond_sql = $self->_cond_resolve($condition, $attrs);
 108   my $sql = $self->create_sql('delete', undef, $ident, $cond_sql);
 109   #warn "$sql ".join(', ',@{$attrs->{bind}||[]});
 110   my $sth = $self->sth($sql);
 111   return $sth->execute( @{$attrs->{bind}||[]} );
 112 }
 113
 114 sub select {
 115   my ($self, $ident, $select, $condition, $attrs) = @_;
 116   $attrs ||= { };
 117   #my $select_sql = $self->_cond_resolve($select, $attrs, ',');
 118   my $cond_sql = $self->_cond_resolve($condition, $attrs);
 119   1 while $cond_sql =~ s/^\s*\(\s*(.*ORDER.*)\s*\)\s*$/$1/;
 120   my $sql = $self->create_sql('select', $select, $ident, $cond_sql);
 121   #warn $sql.' '.join(', ', @{$attrs->{bind}||[]});
 122   my $sth = $self->sth($sql);
 123   if (@{$attrs->{bind}||[]}) {
 124     $sth->execute( @{$attrs->{bind}||[]} );
 125   } else {
 126     # disable unexplained 'Use of uninitialized value in subroutine entry'
 127     # warnings
 128     no warnings 'uninitialized';
 129     $sth->execute;
 130   }
 131   return $sth;
 132 }
 133
 134 sub sth {
 135   shift->dbh->prepare(@_);
 136 }
 137
 138 1;
 139
 140 =back
 141
 142 =head1 AUTHORS
 143
 144 Matt S. Trout <perl-stuff@trout.me.uk>
 145
 146 =head1 LICENSE
 147
 148 You may distribute this code under the same terms as Perl itself.
 149
 150 =cut
 151