1package DBIx::ContextualFetch;
2
3$VERSION = '1.03';
4
5use strict;
6use warnings;
7no warnings 'uninitialized';
8
9use base 'DBI';
10
11package DBIx::ContextualFetch::db;
12use base 'DBI::db';
13
14package DBIx::ContextualFetch::st;
15use base 'DBI::st';
16
17sub execute {
18	my ($sth) = shift;
19
20	my $rv;
21
22	# Allow $sth->execute(\@param, \@cols) and
23	# $sth->execute(undef, \@cols) syntax.
24	if (  @_ == 2
25		and (!defined $_[0] || ref $_[0] eq 'ARRAY')
26		and ref $_[1] eq 'ARRAY') {
27		my ($bind_params, $bind_cols) = @_;
28		$rv = $sth->_untaint_execute(@$bind_params);
29		$sth->SUPER::bind_columns(@$bind_cols);
30		} else {
31		$sth->_disallow_references(@_);
32		$rv = $sth->_untaint_execute(@_);
33	}
34	return $rv;
35}
36
37sub _disallow_references {
38	my $self = shift;
39	foreach (@_) {
40		next unless ref $_;
41		next if overload::Method($_, q{""});
42		next if overload::Method($_, q{0+});
43		die "Cannot call execute with a reference ($_)\n";
44	}
45}
46
47# local $sth->{Taint} leaks in old perls :(
48sub _untaint_execute {
49	my $sth = shift;
50	my $old_value = $sth->{Taint};
51	$sth->{Taint} = 0;
52	my $ret = $sth->SUPER::execute(@_);
53	$sth->{Taint} = $old_value;
54	return $ret;
55}
56
57sub fetch {
58	my ($sth) = shift;
59	return wantarray
60		? $sth->SUPER::fetchrow_array
61		: $sth->SUPER::fetchrow_arrayref;
62}
63
64sub fetch_hash {
65	my ($sth) = shift;
66	my $row = $sth->SUPER::fetchrow_hashref;
67	return unless defined $row;
68	return wantarray ? %$row : $row;
69}
70
71sub fetchall {
72	my ($sth) = shift;
73	my $rows = $sth->SUPER::fetchall_arrayref;
74	return wantarray ? @$rows : $rows;
75}
76
77# There may be some code in DBI->fetchall_arrayref, but its undocumented.
78sub fetchall_hash {
79	my ($sth) = shift;
80	my (@rows, $row);
81	push @rows, $row while ($row = $sth->SUPER::fetchrow_hashref);
82	return wantarray ? @rows : \@rows;
83}
84
85sub select_row {
86	my ($sth, @args) = @_;
87	$sth->execute(@args);
88	my @row = $sth->fetchrow_array;
89	$sth->finish;
90	return @row;
91}
92
93sub select_col {
94	my ($sth, @args) = @_;
95	my (@row, $cur);
96	$sth->execute(@args);
97	$sth->bind_col(1, \$cur);
98	push @row, $cur while $sth->fetch;
99	$sth->finish;
100	return @row;
101}
102
103sub select_val {
104	my ($sth, @args) = @_;
105	return ($sth->select_row(@args))[0];
106}
107
108return 1;
109
110__END__
111
112=head1 NAME
113
114DBIx::ContextualFetch - Add contextual fetches to DBI
115
116=head1 SYNOPSIS
117
118	my $dbh = DBI->connect(...., { RootClass => "DBIx::ContextualFetch" });
119
120	# Modified statement handle methods.
121	my $rv = $sth->execute;
122	my $rv = $sth->execute(@bind_values);
123	my $rv = $sth->execute(\@bind_values, \@bind_cols);
124
125	# In addition to the normal DBI sth methods...
126	my $row_ref = $sth->fetch;
127	my @row     = $sth->fetch;
128
129	my $row_ref = $sth->fetch_hash;
130	my %row     = $sth->fetch_hash;
131
132	my $rows_ref = $sth->fetchall;
133	my @rows     = $sth->fetchall;
134
135	my $rows_ref = $sth->fetchall_hash;
136	my @tbl      = $sth->fetchall_hash;
137
138=head1 DESCRIPTION
139
140It always struck me odd that DBI didn't take much advantage of Perl's
141context sensitivity. DBIx::ContextualFetch redefines some of the various
142fetch methods to fix this oversight. It also adds a few new methods for
143convenience (though not necessarily efficiency).
144
145=head1 SET-UP
146
147	my $dbh = DBIx::ContextualFetch->connect(@info);
148	my $dbh = DBI->connect(@info, { RootClass => "DBIx::ContextualFetch" });
149
150To use this method, you can either make sure that everywhere you normall
151call DBI->connect() you either call it on DBIx::ContextualFetch, or that
152you pass this as your RootClass. After this DBI will Do The Right Thing
153and pass all its calls through us.
154
155=head1 EXTENSIONS
156
157=head2 execute
158
159	$rv = $sth->execute;
160	$rv = $sth->execute(@bind_values);
161	$rv = $sth->execute(\@bind_values, \@bind_cols);
162
163execute() is enhanced slightly:
164
165If called with no arguments, or with a simple list, execute() operates
166normally.  When when called with two array references, it performs
167the functions of bind_param, execute and bind_columns similar to the
168following:
169
170	$sth->execute(@bind_values);
171	$sth->bind_columns(undef, @bind_cols);
172
173In addition, execute will accept tainted @bind_values.  I can't think of
174what a malicious user could do with a tainted bind value (in the general
175case. Your application may vary.)
176
177Thus a typical idiom would be:
178
179	$sth->execute([$this, $that], [\($foo, $bar)]);
180
181Of course, this method provides no way of passing bind attributes
182through to bind_param or bind_columns. If that is necessary, then you
183must perform the bind_param, execute, bind_col sequence yourself.
184
185=head2 fetch
186
187	$row_ref = $sth->fetch;
188	@row     = $sth->fetch;
189
190A context sensitive version of fetch(). When in scalar context, it will
191act as fetchrow_arrayref. In list context it will use fetchrow_array.
192
193=head2 fetch_hash
194
195	$row_ref = $sth->fetch_hash;
196	%row     = $sth->fetch_hash;
197
198A modification on fetchrow_hashref. When in scalar context, it acts just
199as fetchrow_hashref() does. In list context it returns the complete hash.
200
201=head2 fetchall
202
203	$rows_ref = $sth->fetchall;
204	@rows     = $sth->fetchall;
205
206A modification on fetchall_arrayref. In scalar context it acts as
207fetchall_arrayref. In list it returns an array of references to rows
208fetched.
209
210=head2 fetchall_hash
211
212	$rows_ref = $sth->fetchall_hash;
213	@rows     = $sth->fetchall_hash;
214
215A mating of fetchall_arrayref() with fetchrow_hashref(). It gets all rows
216from the hash, each as hash references. In scalar context it returns
217a reference to an array of hash references. In list context it returns
218a list of hash references.
219
220=head1 ORIGINAL AUTHOR
221
222Michael G Schwern as part of Ima::DBI
223
224=head1 CURRENT MAINTAINER
225
226Tony Bowden <tony@tmtm.com>
227
228=head1 LICENSE
229
230This library is free software; you can redistribute it and/or modify
231it under the same terms as Perl itself.
232
233=head1 SEE ALSO
234
235L<DBI>. L<Ima::DBI>. L<Class::DBI>.
236
237