149 lines
3.1 KiB
Perl
Executable File
149 lines
3.1 KiB
Perl
Executable File
#!/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);
|
|
use I18N::Langinfo qw(langinfo CODESET);
|
|
|
|
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
|
|
|
|
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 = <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});
|
|
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]\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);
|
|
}
|