Preparing for 0.02 release
[dbsrgits/DBIx-Class.git] / lib / DBIx / Class / Storage / DBI.pm
1 package DBIx::Class::Storage::DBI;
2
3 use strict;
4 use warnings;
5 use DBI;
6 use SQL::Abstract::Limit;
7 use DBIx::Class::Storage::DBI::Cursor;
8
9 use base qw/DBIx::Class/;
10
11 __PACKAGE__->load_components(qw/Exception AccessorGroup/);
12
13 __PACKAGE__->mk_group_accessors('simple' =>
14   qw/connect_info _dbh _sql_maker debug cursor/);
15
16 sub new {
17   my $new = bless({}, ref $_[0] || $_[0]);
18   $new->cursor("DBIx::Class::Storage::DBI::Cursor");
19   $new->debug(1) if $ENV{DBIX_CLASS_STORAGE_DBI_DEBUG};
20   return $new;
21 }
22
23 sub get_simple {
24   my ($self, $get) = @_;
25   return $self->{$get};
26 }
27
28 sub set_simple {
29   my ($self, $set, $val) = @_;
30   return $self->{$set} = $val;
31 }
32
33 =head1 NAME 
34
35 DBIx::Class::Storage::DBI - DBI storage handler
36
37 =head1 SYNOPSIS
38
39 =head1 DESCRIPTION
40
41 This class represents the connection to the database
42
43 =head1 METHODS
44
45 =over 4
46
47 =cut
48
49 sub dbh {
50   my ($self) = @_;
51   my $dbh;
52   unless (($dbh = $self->_dbh) && $dbh->FETCH('Active') && $dbh->ping) {
53     $self->_populate_dbh;
54   }
55   return $self->_dbh;
56 }
57
58 sub sql_maker {
59   my ($self) = @_;
60   unless ($self->_sql_maker) {
61     $self->_sql_maker(new SQL::Abstract::Limit( limit_dialect => $self->dbh ));
62   }
63   return $self->_sql_maker;
64 }
65
66 sub _populate_dbh {
67   my ($self) = @_;
68   my @info = @{$self->connect_info || []};
69   $self->_dbh($self->_connect(@info));
70 }
71
72 sub _connect {
73   my ($self, @info) = @_;
74   return DBI->connect(@info);
75 }
76
77 =item commit
78
79   $class->commit;
80
81 Issues a commit again the current dbh
82
83 =cut
84
85 sub commit { $_[0]->dbh->commit; }
86
87 =item rollback
88
89   $class->rollback;
90
91 Issues a rollback again the current dbh
92
93 =cut
94
95 sub rollback { $_[0]->dbh->rollback; }
96
97 sub _execute {
98   my ($self, $op, $extra_bind, $ident, @args) = @_;
99   my ($sql, @bind) = $self->sql_maker->$op($ident, @args);
100   unshift(@bind, @$extra_bind) if $extra_bind;
101   warn "$sql: @bind" if $self->debug;
102   my $sth = $self->sth($sql);
103   @bind = map { ref $_ ? ''.$_ : $_ } @bind; # stringify args
104   my $rv = $sth->execute(@bind);
105   return (wantarray ? ($rv, $sth, @bind) : $rv);
106 }
107
108 sub insert {
109   my ($self, $ident, $to_insert) = @_;
110   $self->throw( "Couldn't insert ".join(', ', map "$_ => $to_insert->{$_}", keys %$to_insert)." into ${ident}" )
111     unless ($self->_execute('insert' => [], $ident, $to_insert) > 0);
112   return $to_insert;
113 }
114
115 sub update {
116   return shift->_execute('update' => [], @_);
117 }
118
119 sub delete {
120   return shift->_execute('delete' => [], @_);
121 }
122
123 sub select {
124   my ($self, $ident, $select, $condition, $attrs) = @_;
125   my $order = $attrs->{order_by};
126   if (ref $condition eq 'SCALAR') {
127     $order = $1 if $$condition =~ s/ORDER BY (.*)$//i;
128   }
129   my @args = ('select', $attrs->{bind}, $ident, $select, $condition, $order);
130   if ($self->sql_maker->_default_limit_syntax eq "GenericSubQ") {
131     $attrs->{software_limit} = 1;
132   } else {
133     push @args, $attrs->{rows}, $attrs->{offset};
134   }
135   my ($rv, $sth, @bind) = $self->_execute(@args);
136   return $self->cursor->new($sth, \@bind, $attrs);
137 }
138
139 sub select_single {
140   my ($self, $ident, $select, $condition, $attrs) = @_;
141   my $order = $attrs->{order_by};
142   if (ref $condition eq 'SCALAR') {
143     $order = $1 if $$condition =~ s/ORDER BY (.*)$//i;
144   }
145   my @args = ('select', $attrs->{bind}, $ident, $select, $condition, $order);
146   if ($self->sql_maker->_default_limit_syntax eq "GenericSubQ") {
147     $attrs->{software_limit} = 1;
148   } else {
149     push @args, 1, $attrs->{offset};
150   }  
151   my ($rv, $sth, @bind) = $self->_execute(@args);
152   return $sth->fetchrow_array;
153 }
154
155 sub sth {
156   shift->dbh->prepare(@_);
157 }
158
159 1;
160
161 =back
162
163 =head1 AUTHORS
164
165 Matt S. Trout <mst@shadowcatsystems.co.uk>
166
167 Andy Grundman <andy@hybridized.org>
168
169 =head1 LICENSE
170
171 You may distribute this code under the same terms as Perl itself.
172
173 =cut
174