Commit | Line | Data |
8b445e33 |
1 | package DBIx::Class::Storage::DBI; |
2 | |
20a2c954 |
3 | use strict; |
4 | use warnings; |
8b445e33 |
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}); |
20a2c954 |
88 | $self->throw( "Couldn't insert ".join(', ', map "$_ => $to_insert->{$_}", keys %$to_insert)." into ${ident}" ) |
8b445e33 |
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); |
20a2c954 |
125 | $sth->execute( @{$attrs->{bind}||[]} ); |
8b445e33 |
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 | |