#!/usr/local/bin/perl =head1 NAME dumpsql - dump output of an SQL query =head1 SYNOPSIS dumpsql query Connects to the database identified by the environment variable DBI_CREDENTIAL_FILE, executes the query given on the command line and prints the output to stdout. =cut use warnings; use strict; use DBI; use Getopt::Long; use Encode qw(:fallbacks encode); my $help; my $vertical; # use vertical output format my $escape; # escape non-printable characters my $xhtml; # produce XHTML output my $style; # produce XHTML output GetOptions( 'help|?' => \$help, 'vertical' => \$vertical, 'xhtml' => \$xhtml, 'escape' => \$escape, 'style:s' => \$style, ) || pod2usage(2); pod2usage(1) if $help; # read credits from file sub _read_cred { my ($fn) = @_; open(FN, "<$fn") or die "cannot open $fn: $!"; my $line = ; close(FN); my @cred = split(/[\s\n]/, $line); return @cred; } my $dbh; sub dbiconnect { my $cred_file = $ENV{DBI_CREDENTIAL_FILE}; if (! defined($cred_file)) { $cred_file = "$ENV{HOME}/.dbi/default"; } elsif ($cred_file !~ m{/}) { $cred_file = "$ENV{HOME}/.dbi/$cred_file"; } $dbh = DBI->connect(_read_cred($cred_file), {RaiseError => 1, AutoCommit => 0}); return $dbh; } $dbh = dbiconnect(); $dbh->{LongReadLen} = 0x1_0000; my $query = shift(@ARGV); my @args = @ARGV; my $sth = $dbh->prepare($query); $sth->execute(@args); if ($xhtml) { print qq{\n}; print qq{\n}; print qq{\n}; print qq{}, xmlencode($query), qq{\n}; if ($style) { print qq{\n}; } print qq{\n}; print qq{\n}; print qq{\n}; print qq{

}, xmlencode($query), qq{

\n}; if (@args) { print qq{\n}; } print qq{\n}; print qq{}, ( map { "" } @{$sth->{NAME}} ), "\n"; while (my @a = $sth->fetchrow_array()) { print qq{}, ( map { "" } @a ), "\n"; } print qq{
" . xmlencode($_) . "
" . (defined($_) ? xmlencode($_) : 'NULL') . "
\n}; print qq{\n}; print qq{\n}; } elsif ($vertical) { while (my @a = $sth->fetchrow_array()) { for my $i (0 .. $#a) { print $sth->{NAME}[$i], ": "; if ($escape) { if (defined($a[$i])) { print encode("us-ascii", $a[$i], FB_PERLQQ), "\n"; } else { print "NULL\n"; } } else { print "$a[$i]\n"; } } print "\n"; } } else { no warnings 'uninitialized'; print join("\t", @{$sth->{NAME}}), "\n"; while (my @a = $sth->fetchrow_array()) { print join("\t", @a), "\n"; } } sub xmlencode { my ($s) = @_; return encode("us-ascii", $s, FB_XMLCREF); }