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