lib/DBIx/Class/Storage/DBI.pm

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