#!/usr/bin/perl =head1 NAME dumpsql - dump output of an SQL query =head1 SYNOPSIS dumpsql [ --vertical [ --escape ] | --xhtml [ --style uri ] ] query =head1 DESCRIPTION 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. By default the output is tab-separated. Two alternate formats are available: --vertical prints each field in a separate line in "Columnname: Value" format. Rows are separated by empty lines. --Escape escapes unprintable characters. --xhtml prints the table as an XHTML file. Optionally a style sheet can be specified with --style. =head1 BUGS The --escape option only works with --vertical. It should also work with the other two styles. =cut use warnings; use strict; use DBI; use Getopt::Long; use Encode qw(:fallbacks encode); use I18N::Langinfo qw(langinfo CODESET); use Pod::Usage; my $charset = langinfo(CODESET); binmode STDOUT, "encoding($charset)"; my $help; my $vertical; # use vertical output format my $escape; # escape non-printable characters my $xhtml; # produce XHTML output my $style; # produce XHTML output my $separator; # if set, produce CSV with this separator and double-quoted fields GetOptions( 'help|?' => \$help, 'vertical' => \$vertical, 'xhtml' => \$xhtml, 'escape' => \$escape, 'style:s' => \$style, 'separator:s' => \$separator, ) || 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+/, $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}); my $driver = $dbh->{Driver}->{Name}; if ($driver eq 'Pg') { $dbh->{pg_enable_utf8} = 1; } 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] // "NULL", "\n"; } } print "\n"; } } elsif ($separator) { no warnings 'uninitialized'; print join($separator, @{$sth->{NAME}}), "\n"; while (my @a = $sth->fetchrow_array()) { for (@a) { if (/[$separator"]/) { s/"/""/g; s/.*/"$&"/; } } print join($separator, @a), "\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); }