Added dumpsql script
This commit is contained in:
hjp
parent
e315472e63
commit
db8cc1f569
|
|
@ -0,0 +1,143 @@
|
|||
#!/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 = <FN>;
|
||||
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{<!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);
|
||||
}
|
||||
Loading…
Reference in New Issue