192 lines
4.2 KiB
Perl
Executable File
192 lines
4.2 KiB
Perl
Executable File
#!/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 = <FN>;
|
|
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{<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">\n};
|
|
print qq{<html>\n};
|
|
print qq{<head>\n};
|
|
print qq{<title>}, xmlencode($query), qq{</title>\n};
|
|
if ($style) {
|
|
print qq{<link rel='stylesheet' type='text/css' href='},
|
|
xmlencode($style),
|
|
qq{'/>\n};
|
|
}
|
|
print qq{</head>\n};
|
|
print qq{<head>\n};
|
|
print qq{<body>\n};
|
|
print qq{<h1>}, xmlencode($query), qq{</h1>\n};
|
|
if (@args) {
|
|
print qq{<ul>\n};
|
|
for (@args) {
|
|
print qq{<li>}, xmlencode($_), qq{</li>\n};
|
|
}
|
|
print qq{</ul>\n};
|
|
}
|
|
print qq{<table>\n};
|
|
print qq{<tr>},
|
|
(
|
|
map {
|
|
"<th>" . xmlencode($_) . "</th>"
|
|
} @{$sth->{NAME}}
|
|
),
|
|
"</tr>\n";
|
|
while (my @a = $sth->fetchrow_array()) {
|
|
print qq{<tr>},
|
|
(
|
|
map {
|
|
"<td>"
|
|
. (defined($_) ? xmlencode($_) : '<em>NULL</em>')
|
|
. "</td>"
|
|
} @a
|
|
),
|
|
"</tr>\n";
|
|
}
|
|
print qq{</table>\n};
|
|
print qq{</body>\n};
|
|
print qq{</html>\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);
|
|
}
|