From http://perl.apache.org/docs/1.0/guide/performance.html#Work_With_Databases


my @select_fields = qw(a b c);
# create a list of cols values
my @cols = ();
@cols[0..$#select_fields] = ();
$sth = $dbh->prepare($do_sql);
$sth->execute;
# Bind perl variables to columns.
$sth->bind_columns(undef,\(@cols));
print q{<table border="0">};
while($sth->fetch) {
print q{<tr>},
map(qq{<td>$_</td>}, @cols),
q{</tr>};
}
print q{</table>};


“As a bonus, I wanted to write a single sub that flexibly processes any query. It would accept conditions, a call-back closure sub, select fields and restrictions.”

# Usage:
# $o->dump(\%conditions,\&callback_closure,\@select_fields,@restrictions);
#
sub dump{
my $self = shift;
my %param = %{+shift}; # dereference hash
my $rsub = shift;
my @select_fields = @{+shift}; # dereference list
my @restrict = shift || '';

# create a list of cols values
my @cols = ();
@cols[0..$#select_fields] = ();

my $do_sql = ”;
my @where = ();

# make a @where list
map { push @where, “$_=\’$param{$_}\'” if $param{$_};} keys %param;

# prepare the sql statement
$do_sql = “SELECT “;
$do_sql .= join(” “, @restrict) if @restrict; # append restriction list
$do_sql .= ” ” .join(“,”, @select_fields) ; # append select list
$do_sql .= ” FROM $DBConfig{TABLE} “; # from table

# we will not add the WHERE clause if @where is empty
$do_sql .= ” WHERE ” . join ” AND “, @where if @where;

print “SQL: $do_sql \n” if $debug;

$dbh->{RaiseError} = 1; # do this, or check every call for errors
$sth = $dbh->prepare($do_sql);
$sth->execute;
# Bind perl variables to columns.
$sth->bind_columns(undef,\(@cols));
while($sth->fetch) {
&$rsub(@cols);
}
# print the tail or “no records found” message
# according to the previous calls
&$rsub();

} # end of sub dump


“Now a callback closure sub can do lots of things. We need a closure to know what stage are we in: header, body or tail. For example, we want a callback closure for formatting the rows to print:”

my $rsub = eval {
# make a copy of @fields list, since it might go
# out of scope when this closure is called
my @fields = @fields;
my @query_fields = qw(user dir tool act); # no date field!!!
my $header = 0;
my $tail = 0;
my $counter = 0;
my %cols = (); # columns name=> value hash

# Closure with the following behavior:
# 1. Header’s code will be executed on the first call only and
# if @_ was set
# 2. Row’s printing code will be executed on every call with @_ set
# 3. Tail’s code will be executed only if Header’s code was
# printed and @_ isn’t set
# 4. “No record found” code will be executed if Header’s code
# wasn’t executed

sub {
# Header
if (@_ and !$header){
print “<TABLE>\n”;
print $q->Tr(map{ $q->td($_) } @fields );
$header = 1;
}

# Body
if (@_) {
print $q->Tr(map{$q->td($_)} @_ );
$counter++;
return;
}

# Tail, will be printed only at the end
if ($header and !($tail or @_)){
print “</TABLE>\n $counter records found”;
$tail = 1;
return;
}

# No record found
unless ($header){
print $q->p($q->center($q->b(“No record was found!\n”)));
}

} # end of sub {}
}; # end of my $rsub = eval {


“Here is the updated code fragment which employs this [tag substitution] optimization:”
# ...
my $dbh = DBI->connect('dbi:Oracle:host', 'user', 'pass')
|| die $DBI::errstr;

my $baz = $r->param('baz');

eval {
my $sth = $dbh->prepare(qq{
SELECT foo
FROM bar
WHERE baz = :baz
});
$sth->bind_param(':baz', $baz);
$sth->execute;

while (my @row = $sth->fetchrow_array) {
# do HTML stuff
}

$sth->finish;

my $sph = $dbh->prepare(qq{
BEGIN
my_procedure(
arg_in => :baz
);
END;
});
$sph->bind_param(':baz', $baz);
$sph->execute;
$sph->finish;

$dbh->commit;
};
if ($@) {
$dbh->rollback;
}
# ...