~~startperl~~
#
# dbimon - DBI monitor
#
# Copyright (C) 1997, 1998: Jochen Wiedmann
#
#
# This program implements a simple SQL shell. You can enter queries via
# a comfortable ReadLine interface and retrieve result tables in different
# output modes:
#
# Author: Jochen Wiedmann
# Am Eisteich 9
# 72555 Metzingen
# Germany
#
# Email: joe@ispsoft.de
# Phone: +49 7123 14887
#
# dbimon is based on pmsql, which is
#
# Copyright 1994-1997 Andreas König
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
#
############################################################################
#
# Required modules
#
require 5.004;
use Carp ();
use strict; # Enable for testing only, disable for distributions
# users won't like this for eval's
use DBI ();
use Term::ReadLine ();
use Data::ShowTable ();
use Getopt::Long ();
############################################################################
#
# Constants
#
my $VERSION = "1.2200";
my @VALID_VARS = ("escapeChar", "less", "listWrapMargin", "maxTableWidth",
"noEscape", "quoteChar", "sepChar", "showMode");
############################################################################
#
# Global variables
#
my $term = undef;
my $prompt = "dbimon> ";
my $batchMode = 0;
my $debugging = 0;
my $driver;
my $dbh;
my $dsn;
my $user;
my $password;
my $attribs;
# Variables that may be modified via the 'set' command
my $escapeChar = '"';
my $less = '';
my $listWrapMargin = $Data::ShowTable::List_Wrap_Margin;
my $maxTableWidth = $Data::ShowTable::Max_Table_Width;
my $noEscape = 0;
my $quoteChar = '"';
my $sepChar = ';';
my $showMode = $Data::ShowTable::Show_Mode;
my $dumpStructure = 1;
my $dumpData = 1;
my $dumpNames = 0;
############################################################################
#
# Name: FormatTypeName, FormatDefaultSize, FormatMaxSize
#
# Purpose: Compatibility kludge for statement attributes missing in
# DBI.
#
# Inputs: $sth - statement handle
#
# Returns: Reference to attribute of values, one for each column
#
############################################################################
sub FormatTypeName ($) {
my $sth = shift;
my ($types, $ref);
$@ = '';
if (ref($sth) =~ /.*\:\:(.*)\:\:st$/) {
$ref = eval { $sth->{$1 . '_type_name'} };
}
if ($@ || !$ref) {
$@ = '';
$types = eval { $sth->{TYPE} };
if ($@ || !$types) {
my($num) = scalar(@{$sth->{NAME}});
$ref = [];
while ($num--) {
push(@$ref, 'char');
}
} else {
my ($t, $type);
$ref = [];
while ($t = shift @$types) {
my $found = 0;
foreach $type (@DBI::sql_types) {
if (defined &{$type} && &{$type}() == $t) {
push(@$ref, $type);
$found = 1;
last;
}
}
if (!$found) {
push(@$ref, 'char');
}
}
}
}
$ref;
}
sub FormatDefaultSize ($) {
my $sth = shift;
$@ = '';
my $ref = eval { $sth->{mysql_maxlength} };
if ($@ || !$ref) {
$ref = [];
}
$ref;
}
sub FormatMaxSize ($) {
my $sth = shift;
$@ = '';
my $ref = eval { $sth->{'PRECISION'} };
if ($@ || !$ref) {
$@ = '';
$ref = eval { $sth->{sol_length} };
if ($@ || !$ref) {
$ref = [];
}
}
$ref;
}
############################################################################
#
# Name: FindExe
#
# Purpose: Try's to find an executable in the users PATH
#
# Inputs: $exe - executable name
# $path - reference to array of directory names
#
# Returns: absolute path name of executable, if found; empty string
# otherwise
#
############################################################################
sub FindExe ($$) {
my($exe,$path) = @_;
my($dir);
for $dir (@$path) {
my $abs = "$dir/$exe";
if (-x $abs) {
return $abs;
}
}
'';
}
############################################################################
#
# Name: Connect
#
# Purpose: Attempts to connect to a database.
#
# Inputs: $dsn - datasource name, for example "DBI:mysql:test"
# $user - user name
# $pwd - password
#
# Returns: database handle or 'undef' in case of problems
#
############################################################################
sub Connect (@) {
my ($ndsn, $nuser, $npassword) = @_;
my ($dbh);
if (!defined($ndsn) || $ndsn eq '') {
print "Missing datasource name.\n";
return undef;
}
if ($ndsn !~ /^dbi:/i) {
$ndsn = "DBI:$ndsn";
}
$dbh = eval { DBI->connect($ndsn, $nuser, $npassword); };
if ($@) {
print "Failed to connect, perhaps driver problems: $@\n";
return undef;
}
if (!defined($dbh)) {
my $errmsg = $DBI::errstr;
print "Failed to connect: $errmsg\n";
if (!$batchMode && !defined($npassword) || $npassword eq '') {
$@ = '';
eval { require Term::ReadKey; };
my($readKeyAvailable) = $@ ? 0 : 1;
print "This might be due to a missing password. If so, enter\n";
print "the password, otherwise just type return: ";
if ($readKeyAvailable) {
Term::ReadKey::ReadMode('noecho');
$npassword = Term::ReadKey::ReadLine(0);
Term::ReadKey::ReadMode('restore');
print "\n";
} else {
$npassword = <STDIN>;
}
chomp $npassword;
if (defined($npassword) && $npassword ne '') {
$dbh = DBI->connect($ndsn, $nuser, $npassword);;
if (!defined($dbh)) {
print "Failed to connect: ", $DBI::errstr, "\n";
}
}
}
}
if ($dbh) {
if ($ndsn =~ /^dbi\:([^\:]+)\:(.*)/i) {
$driver = $1;
my($rdsn) = $2;
if ($driver eq 'mSQL' || $driver eq 'mysql') {
my($class) = "DBD::$driver";
my($hash) = {};
$class->_OdbcParse($rdsn, $hash, ["database"]);
if ($hash->{'database'}) {
$prompt = "$driver:" . $hash->{'database'} . "> ";
}
}
} else {
$driver = undef;
}
$dsn = $ndsn;
$user = $nuser;
$password = $npassword;
}
$dbh;
}
############################################################################
#
# Name: Output
#
# Purpose: Formats and prints a query result.
#
# Inputs: $sth - statement handle of query, 'execute' called on
# this sth
#
# Returns: Nothing
#
############################################################################
sub Output ($) {
my ($sth) = @_;
my $restoreStdout = 0;
if (!$batchMode && $less && $less ne 'stdout') {
if (!open(SAVEOUT, ">&STDOUT")) {
print STDERR "Cannot redirect STDOUT: $!\n";
return;
}
if (!open(STDOUT, "| $less")) {
print STDERR "Cannot open pipe to pager $less: $!\n";
open(STDOUT, ">&SAVEOUT");
close(SAVEOUT);
return;
}
$restoreStdout = 1;
}
if ($showMode eq 'Export') {
# Output for export is somewhat simpler ...
my(@res);
my($ePattern, $qPattern, $null, $ref, $quote);
# Create a pattern for escaping one column; we escape the
# $escapeChar, the $quoteChar and \0.
$quote = defined($quoteChar) ? $quoteChar : "";
if (defined($escapeChar) && $escapeChar ne '') {
$ePattern = $escapeChar;
$ePattern =~ s/(\W)/\\$1/g;
if ($quote ne '') {
$qPattern = $quote;
$qPattern =~ s/(\W)/\\$1/g;
if ($ePattern) {
$ePattern = "$ePattern|$qPattern";
} else {
$ePattern = $qPattern;
}
}
$ePattern = "$ePattern|\\0";
} else {
$ePattern = '';
}
$null = 0;
# Now the true output
while (defined($ref = $sth->fetchrow_arrayref())) {
my $add = '';
my $word;
foreach $word (@$ref) {
if ($ePattern) {
$word =~ s/($ePattern)/$escapeChar$1/g;
}
printf ("%s%s%s%s", $add, $quote, $word, $quote);
$add = $sepChar;
}
print "\n";
}
} else {
my @rowCache;
my ($fillCache) = 0;
my ($useCache) = 0;
my ($numFields, $titles, $types, $widths);
eval {
$titles = $sth->{'NAME'} || [];
$types = FormatTypeName($sth);
$widths = FormatDefaultSize($sth);
};
my $row_sub = sub ($) {
if (shift) {
if ($fillCache) {
$fillCache = 0;
$useCache = 1;
return 1;
}
if (!$widths || @$widths != @$titles) {
$fillCache = 1;
return 1;
}
my $col;
foreach $col (@$widths) {
if (!defined(@$widths)) {
$fillCache = 1;
return 1;
}
}
return 0;
}
my $ref;
if ($useCache) {
$ref = shift @rowCache;
} else {
$ref = $sth->fetchrow_arrayref;
if ($ref && $fillCache) {
push(@rowCache, [@$ref]);
}
}
$ref ? @$ref : ();
};
Data::ShowTable::ShowTable { 'titles' => $titles,
'widths' => $widths,
'types' => $types,
'row_sub' => $row_sub,
'show_mode' => $showMode,
'wrap_margin' => $listWrapMargin,
'max_width' => $maxTableWidth,
'no_escape' => $noEscape
};
}
if ($restoreStdout) {
close(STDOUT);
open(STDOUT, ">&SAVEOUT");
close(SAVEOUT);
}
}
############################################################################
#
# Name: RelShow
#
# Purpose: Display list of dsn's, tables or fields
#
# Inputs: $dsn - undef, if list of dsn's should be displayed,
# otherwise dsn being displayed
# $table - undef, if list of tables should be displayed,
# otherwise table being displayed
#
# Returns: Nothing
#
############################################################################
sub DisplayList ($$) { # XXX Replace this with ShowDatabases() and
my ($header, $l) = @_; # ShowTables() as soon as they work. :-(
local( $::current_row ) = 0;
my $row_sub = sub {
&Data::ShowTable::ShowRow($_[0], \$::current_row, $l);
};
Data::ShowTable::ShowTable {'titles' => [$header],
'types' => ['char'],
'widths' => [ ],
'row_sub' => $row_sub};
}
sub DsnList() {
my @l;
eval { @l = DBI->data_sources($driver); };
if (!@l) {
push(@l, $dsn);
}
@l;
}
sub TableList ($) {
my ($rdsn) = shift;
if ($rdsn !~ /\:/) {
$rdsn = "DBI:$driver:$rdsn";
} elsif ($rdsn !~ /\:[^\:]+\:/) {
$rdsn = "DBI:$rdsn";
}
my (@l, $ndbh);
eval {
my $ndbh = ($dsn eq $rdsn) ? $dbh :
DBI->connect($rdsn, $user, $password, {'Warn' => 0});
@l = $ndbh->tables();
};
@l;
}
sub FieldList($$;$) {
my ($rdsn, $table, $dbhRef) = @_;
if ($rdsn !~ /\:/) {
$rdsn = "DBI:$driver:$rdsn";
} elsif ($rdsn !~ /\:[^\:]+\:/) {
$rdsn = "DBI:$rdsn";
}
my($sth, $ndbh);
eval {
$ndbh = ($dsn eq $rdsn) ? $dbh :
DBI->connect($rdsn, $user, $password, {'Warn' => 0});
if ($dbh->{'ImplementorClass'} =~ /\:mysql|mSQL1?\:/) {
$sth = $ndbh->prepare("LISTFIELDS $table");
} else {
$sth = $ndbh->prepare("SELECT * FROM $table WHERE 1 = 0");
}
if (!$sth || !$sth->execute()) {
$sth = undef;
}
};
($sth, $ndbh);
}
sub RelShow (;$$) {
my($dsn, $table) = @_;
if (!defined($dsn)) {
#
# relshow
#
if (!defined($driver)) {
print("Cannot display datasources: Unable to determine driver\n",
" name in dsn $dsn.\n");
} else {
my @l = DsnList();
if ($@) {
print "Cannot get dsn list, perhaps a driver problem: $@.\n";
} elsif (!@l) {
print "No databases found.\n";
} else {
DisplayList('DSN list', \@l);
}
}
return;
}
if (!defined($table)) {
#
# relshow database
#
my @l = TableList($dsn);
if (!@l) {
print "No tables found.\n";
} else {
DisplayList("Table list", \@l);
}
return;
}
my ($sth, $ndbh) = FieldList($dsn, $table);
if ($@) {
print "Cannot get list, perhaps a driver problem: $@.\n";
} else {
#
# relshow database table
#
if (!$sth) {
print "Cannot get field list, error", $DBI::errstr, "\n";
} else {
my ($fLen, $tLen, $lLen, $nLen) = (length("Field"),
length("Type"),
length("Length"),
length("Not Null"));
my ($numFields, $fRef, $tRef, $lRef, $nRef);
eval {
my $ref;
$numFields = $sth->{'NUM_OF_FIELDS'};
if (defined($ref = $sth->{'NAME'}) && ref($ref) eq 'ARRAY') {
$fRef = [@$ref];
}
if (defined($ref = $sth->{'NULLABLE'}) &&
ref($ref) eq 'ARRAY') {
$nRef = [@$ref];
}
if (defined($ref = FormatTypeName($sth)) &&
ref($ref) eq 'ARRAY') {
$tRef = [@$ref];
}
if (defined($ref = FormatMaxSize($sth)) &&
ref($ref) eq 'ARRAY') {
$lRef = [@$ref];
}
};
my $col_num = 0;
my $row_sub = sub ($) {
my ($name, $type, $len, $nullable);
if (shift) {
$col_num = 0;
return 1;
}
if ($col_num >= $numFields) {
return ();
}
if (!$fRef || (ref($fRef) ne 'ARRAY') ||
!defined($name = $$fRef[$col_num])) {
$name = "unknown";
}
if (!$tRef || (ref($tRef) ne 'ARRAY') ||
!defined($type = $$tRef[$col_num])) {
$name = "unknown";
}
if (!$lRef || (ref($lRef) ne 'ARRAY') ||
!defined($len = $$lRef[$col_num])) {
$len = "N/A";
}
if (!$nRef || (ref($nRef) ne 'ARRAY') ||
!defined($nullable = $$nRef[$col_num])) {
$len = "N/A";
} else {
$nullable = $nullable ? "Y" : "N";
}
$col_num++;
($name, $type, $len, $nullable);
};
Data::ShowTable::ShowTable {'titles' => ['Field', 'Type',
'Length', 'Nullable'],
'types' => ['char', 'char', 'int',
'char'],
'widths' => [],
'row_sub' => $row_sub};
}
}
undef $sth; # So statement handle destructor gets called before
# Database handle destructor
}
############################################################################
#
# Name: GetOrSetVal
#
# Purpose: Display and modify one internal variable
#
# Inputs: $key - variable name
# $val - variable value; optional; variable will only be
# queried, if $val is undef
# $complete - if TRUE, this parameter asks for completion
# of $val
#
# Returns: List with variable name and current (probably modified)
# value. $key is undef, if variable name was invalid.
#
############################################################################
sub GetOrSetVal (@) {
my ($key, $val, $complete) = @_;
if ($key =~ /^dumpd(:?a(:?ta?))$/i) {
if ($complete) {
return (); # No completion available
}
if (defined($val)) {
if ($val =~ /^on$/i) {
$dumpData = 1;
} elsif ($val =~ /^off?$/i) {
$dumpData = 0;
} else {
$dumpData = $val ? 1 : 0;
}
}
$val = $dumpData ? "on" : "off";
$key = "dumpData";
} elsif ($key =~ /^dumps(:?n(:?a(:?m(:?es?))))$/i) {
if ($complete) {
return (); # No completion available
}
if (defined($val)) {
if ($val =~ /^on$/i) {
$dumpNames = 1;
} elsif ($val =~ /^off?$/i) {
$dumpNames = 0;
} else {
$dumpNames = $val ? 1 : 0;
}
}
$val = $dumpNames ? "on" : "off";
$key = "dumpNames";
} elsif ($key =~ /^dumps(:?t(:?r(:?u(:?c(:?t(:?u(:?re?)))))))$/i) {
if ($complete) {
return (); # No completion available
}
if (defined($val)) {
if ($val =~ /^on$/i) {
$dumpStructure = 1;
} elsif ($val =~ /^off?$/i) {
$dumpStructure = 0;
} else {
$dumpStructure = $val ? 1 : 0;
}
}
$val = $dumpStructure ? "on" : "off";
$key = "dumpStructure";
} elsif ($key =~ /^e(s(c(a(p(e(c(h(ar?)?)?)?)?)?)?)?)?$/i) {
if ($complete) {
return (); # No completion available
}
if (defined($val)) {
$escapeChar = $val;
}
$val = $escapeChar ? $escapeChar : "off";
$key = "escapeChar";
} elsif ($key =~ /^le(ss?)?$/i) {
if ($complete) {
return (); # No completion available
}
if (defined($val)) {
if ($val && $val ne 'stdout' && ! -x $val) {
print "No such executable: $val\n";
print "Keeping old value.\n";
} else {
$less = $val;
}
}
$val = ($less && $less ne 'stdout') ? $less : "off";
$key = "less";
} elsif ($key =~ /^li(s(t(w(r(a(p(m(a(r(g(in?)?)?)?)?)?)?)?)?)?)?)?$/i) {
if ($complete) {
return (); # No completion available
}
if (defined($val)) {
if ($val =~ /^\d+$/) {
$listWrapMargin = $val;
} elsif ($val eq "off") {
$maxTableWidth = '';
} else {
print "Illegal value for maxTableWidth: $val\n";
print "Keeping old value.\n";
}
}
$val = ($maxTableWidth ne '') ? $maxTableWidth : "off";
$key = "maxTableWidth";
} elsif ($key =~ /^maxt(a(b(l(e(w(i(d(th?)?)?)?)?)?)?)?)?$/i) {
if ($complete) {
return (); # No completion available
}
if (defined($val)) {
if ($val =~ /^\d+$/) {
$maxTableWidth = $val;
} elsif ($val eq "off") {
$maxTableWidth = '';
} else {
print "Illegal value for maxTableWidth: $val\n";
print "Keeping old value.\n";
}
}
$val = ($maxTableWidth ne '') ? $maxTableWidth : "off";
$key = "maxTableWidth";
} elsif ($key =~ /n(o(e(s(c(a(pe?)?)?)?)?)?)?$/i) {
if ($complete) {
if ($val =~ /^on$/i) {
return ('on');
} elsif ($val =~ /^off?$/i) {
return ('off');
} elsif ($val =~ /^o?$/i) {
return ('on', 'off');
} else {
return ();
}
}
if (defined($val)) {
if ($val =~ /^on$/i) {
$noEscape = 1;
} elsif ($val =~ /^off?$/i) {
$noEscape = 0;
} else {
print "Unknown value, use either 'on' or 'off'.\n";
print "Keeping old value.\n";
}
}
$val = $noEscape ? 'on' : 'off';
} elsif ($key =~ /q(u(o(t(e(c(h(ar?)?)?)?)?)?)?)?/i) {
if ($complete) {
return (); # No completion available
}
if (defined($val)) {
$quoteChar = $val;
}
$val = $quoteChar ? $quoteChar : "off";
$key = "quoteChar";
} elsif ($key =~ /se(p(c(h(ar?)?)?)?)?/i) {
if ($complete) {
return (); # No completion available
}
if (defined($val)) {
$sepChar = $val;
}
$val = $sepChar ? $sepChar : "off";
$key = "sepChar";
} elsif ($key =~ /^sh(o(w(m(o(de?)?)?)?)?)?$/i) {
if ($complete) {
if ($val =~ /^b(ox?)?$/i) {
return ('Box');
} elsif ($val =~ /^e(x(p(o(rt?)?)?)?)?$/i) {
return ('Export');
} elsif ($val =~ /^h(t(ml?)?)?$/i) {
return ('HTML');
} elsif ($val =~ /^l(i(st?)?)?$/i) {
return ('List');
} elsif ($val =~ /^t(a(b(le?)?)?)?$/i) {
return ('List');
} elsif ($val eq '') {
return ('Box', 'Export', 'HTML', 'List', 'Table');
} else {
return ();
}
}
if (defined($val)) {
if ($val =~ /^b(ox?)?$/i) {
$showMode = 'Box';
} elsif ($val =~ /^t(a(b(le?)?)?)?$/i) {
$showMode = 'Table';
} elsif ($val =~ /^l(i(st?)?)?$/i) {
$showMode = 'List';
} elsif ($val =~ /^h(t(ml?)?)?$/i) {
$showMode = 'HTML';
} elsif ($val =~ /^e(x(p(o(rt?)?)?)?)?$/i) {
$showMode = 'Export';
} else {
print "Unknown show mode: $val\n";
print "Possible modes are: Box, Table, List, HTML, Export\n";
print "Keeping old value.\n";
}
}
$val = $showMode;
$key = "showMode";
} else {
if ($complete) {
return ();
}
$key = undef;
}
($key, $val);
}
############################################################################
#
# Name: Set
#
# Purpose: Display and modify internal variables
#
# Inputs: @args - command line arguments
#
# Returns: Nothing
#
############################################################################
sub Set (@) {
if (!@_) {
# Display complete list of arguments
printf("Current settings:\n" .
" less: %s\n" .
" showMode: %s\n",
(GetOrSetVal("less"))[1], (GetOrSetVal("showMode"))[1]);
if ($showMode eq 'Export') {
printf(" escapeChar: %s\n" .
" quoteChar: %s\n" .
" sepChar: %s\n",
(GetOrSetVal("escapeChar"))[1],
(GetOrSetVal("quoteChar"))[1],
(GetOrSetVal("sepChar"))[1]);
} elsif ($showMode eq 'Box') {
printf(" maxTableWidth: %s\n",
(GetOrSetVal("maxTableWidth"))[1]);
} elsif ($showMode eq 'HTML') {
printf(" maxTableWidth: %s\n" .
" noEscape: %s\n",
(GetOrSetVal("maxTableWidth"))[1],
(GetOrSetVal("noEscape"))[1]);
} elsif ($showMode eq 'List') {
printf(" listWrapMargin: %s\n" .
" maxTableWidth: %s\n",
(GetOrSetVal("listWrapMargin"))[1],
(GetOrSetVal("maxTableWidth"))[1]);
}
printf(" dumpData: %s\n" .
" dumpNames: %s\n" .
" dumpStructure: %s\n",
GetOrSetVal('dumpData'),
GetOrSetVal('dumpNames'),
GetOrSetVal('dumpStructure'));
} elsif (@_ == 1 || @_ == 2) {
my($key, $val) = @_;
($key, $val) = GetOrSetVal($key, $val);
if (!defined($key)) {
printf("Unknown variable: %s.\n", $key);
} else {
printf("Current value of %s: %s\n", $key, $val);
}
} else {
print "Usage: set [<var> [<val]]\n";
}
}
############################################################################
#
# Name: Complete
#
# Purpose: Simple completion function for ReadLine
#
# Inputs: $word - word to complete
# $line - line to complete
# $pos - ?
#
# Returns: Word to complete
#
############################################################################
sub complete_database ($) {
my $word = shift;
grep /^(.*\:)\Q$word/, DsnList();
}
sub complete_table ($$) {
my($word,$line) = @_;
my($rdsn) = $line =~ /^r\w+\s+(\w+)/;
if ($debugging) {
print STDERR "word[$word] line[$line] dsn[$rdsn]\n";
}
$rdsn ||= $dsn;
if (!$rdsn) {
return ();
}
grep /\b\Q$word/i, TableList($dsn);
}
sub complete_table_or_field {
my($word,$line) = @_;
my(@result) = ();
if ($debugging){
print STDERR "word[$word] line[$line]\n";
}
if ($line =~ /(delete|select)\s.*from\s+\Q$word\E$/i ||
$line =~ /^update\s+\Q$word\E$/i ||
$line =~ /^insert\s.*into\s+\Q$word\E$/i) {
@result = grep /\b\Q$word/i, TableList($dsn);
} elsif ($line =~ /^delete\s.*\sfrom\s+(\w+)/i ||
$line =~ /^select\s.*\sfrom\s+(\w+)/i ||
$line =~ /^update\s+(\w+)/i ||
$line =~ /^insert\s.*into\s+(\w+)/i) {
my $table = $1;
if ($table) {
my($sth) = FieldList($dsn, $table); # Needs array mode
if ($sth) {
my $names = $sth->{'NAME'};
if (ref($names) eq 'ARRAY') {
@result = grep /^\Q$word/, @$names;
}
}
}
}
@result;
}
sub complete_for_relshow ($$) {
my($word, $line) = @_;
my @t = split(' ', $line);
if (@t == 1 || @t == 2 && $word eq $t[1]) {
complete_database($word);
} else {
complete_table($word, $line);
}
}
sub complete_for_set ($$) {
my($word, $line) = @_;
my @t = split(' ', $line);
if (@t == 1 || @t == 2 && $word eq $t[1]) {
grep /^\Q$word/, @VALID_VARS;
} elsif ((@t == 2 && $word eq '') || @t == 3 && $word eq $t[2]) {
my ($key) = $t[1] || '';
my ($val) = $t[2] || '';
GetOrSetVal($t[1], $t[2], 1);
} else {
();
}
}
sub Complete ($$$) {
my($word, $line, $pos) = @_;
$word ||= '';
$line ||= '';
$pos ||= 0;
if ($debugging) {
print STDERR "complete line[$line] word[$word] pos[$pos]\n";
}
# Remove preceding white space
$line =~ s/^\s*//;
if ($pos == 0) {
grep /^$word/i, ('!', '?', 'delete from', 'dsn', 'insert into',
'quit', 'relshow', 'select', 'set', 'update',
'dump');
} elsif ($line =~ /^dsn?/i) {
complete_database($word);
} elsif ($line =~ /^de(l(e(te?)?)?)?/i) {
complete_table_or_field($word,$line);
} elsif ($line =~ /^i(n(s(e(rt?)?)?)?)?/i) {
complete_table_or_field($word,$line);
} elsif ($line =~ /^r(e(l(s(h(ow?)?)?)?)?)?/i) {
complete_for_relshow($word,$line);
} elsif ($line =~ /^sel(e(ct?)?)?/i) {
complete_table_or_field($word,$line);
} elsif ($line =~ /^set/i) {
complete_for_set($word, $line);
} elsif ($line =~ /^u(p(d(a(te?)?)?)?)?/i) {
complete_table_or_field($word,$line);
} else {
();
}
}
sub CompleteGnu ($$$) {
my($word, $line, $pos) = @_;
my(@poss) = Complete($word, $line, $pos);
$attribs->{'completion_word'} = \@poss;
return;
}
############################################################################
#
# Name: Dump
#
# Purpose: Dumps a databases contents to stdout as a sequence of
# SQL queries.
#
# Inputs: $o - Option hash ref
# $dbh - Database handle
#
# Returns: Nothing
#
############################################################################
package DBIx::Table;
sub new {
my($proto, $table, $sth, $o) = @_;
my $self = {%$o,
'Table' => $table,
'Sth' => $sth,
'Names' => $sth->{'NAME'},
'Types' => $sth->{'TYPE'},
'Precs' => $sth->{'PRECISION'},
'Scale' => $sth->{'SCALE'},
'Nullable' => $sth->{'NULLABLE'}
};
bless($self, (ref($proto) || $proto));
}
sub DbHeader { '' }
sub Header { '' }
sub DropCommand {
my $self = shift;
"DROP TABLE $self->{'Table'}\n";
}
package DBIx::Table::mysql;
@DBIx::Table::mysql::ISA = qw(DBIx::Table);
sub DbHeader {
sprintf(<<"EOF", scalar(localtime()));
##
## Dump of database $dsn
## Automatically generated by dbimon at %s
## Do not edit!
##
EOF
}
sub TableHeader { my $self = shift; "## Table $self->{'Table'}\n\n"; }
sub DropCommand {
my $self = shift;
"DROP TABLE IF EXISTS $self->{'Table'}\n";
}
package main;
sub Dump {
my($o, $dbh) = @_;
my @tables = @{$o->{'tables'}};
@tables = $dbh->tables() unless @tables;
my $class = $o->{'output'} ? "DBIx::Table::$o->{'output'}" : "DBIx::Table";
die "Unknown output class: $o->{'output'}"
unless UNIVERSAL::can($class, 'new');
print $class->DbHeader();
foreach my $table (@tables) {
my $msg;
my $sth = $dbh->prepare("SELECT * FROM $table");
if (!$sth) {
$msg = sprintf("Error while preparing dump of table $table: %s",
$dbh->errstr());
} elsif (!$sth->execute()) {
$msg = sprintf("Error while executing dump of table $table: %s",
$sth->errstr());
} else {
my $table = $class->new($table, $sth, $o);
print $table->Header();
print $table->DropCommand() if $o->{'drop'};
print $table->CreateCommand() if $o->{'create'};
print $table->Data() if $o->{'insert'};
}
if ($msg) {
die $msg unless $o->{'ignore-errors'};
print STDERR "$msg\n";
}
}
}
############################################################################
#
# Name: Quit
#
# Purpose: Programs destructor
#
# Inputs: None
#
# Returns: Nothing.
#
############################################################################
sub Quit () {
if (defined($dbh)) {
$dbh->disconnect;
$dbh = undef;
}
}
END { Quit(); }
############################################################################
#
# Name: Help
#
# Purpose: Print help message
#
# Inputs: None
#
# Returns: Nothing.
#
############################################################################
sub Help () {
print qq{
d[sn] <dsn> Disconnect from current dsn and connect to <dsn>
r[elshow] [<dsn> [<table>]] Display list of dsn´s, tables, fields.
s[et] [<var> [<val>]] Display or set values of internal variables.
! <anything> Eval <anything> in perl
? Print this message
q[uit] Leave dbimon
Any other line will be passed as a query to the DMBS.
};
}
############################################################################
#
# Name: Usage
#
# Purpose: Print usage message
#
# Inputs: None
#
# Returns: Nothing, exits with error status
#
############################################################################
sub Usage () {
print STDERR qq{
Usage: $0 [options] dsn [user [password]]
Possible options are:
-h | -help | --help Print this message
-b | -batch | --batch Batch mode
dbimon $VERSION Copyright (C) 1997 Jochen Wiedmann
};
exit 1;
}
############################################################################
#
# This is main().
#
############################################################################
{
my $dumpContents;
my @dumpTables;
my $inputFrom;
my $dieOnError;
# Initialize $less
{
my @path = split ":", $ENV{PATH};
if (exists($ENV{DBIMON_PAGER})) {
$less = $ENV{DBIMON_PAGER};
} elsif (exists($ENV{PAGER})) {
$less = $ENV{PAGER};
} elsif (!defined($less = FindExe("less", [@path])) &&
!defined($less = FindExe("more", [@path]))) {
$less = '';
}
}
my %o = ( 'create' => 1,
'data' => 1,
'short' => 1,
'table' => []
);
Getopt::Long::GetOptions(\%o, "batch", "create!", "debug", "drop",
"dsn=s", "dump", "ignore-errors", "input=s",
"insert!", "help", "output=s",
"password=s", "table=s@", "user=s");
$o{'dsn'} = shift @ARGV unless defined($o{'dsn'});
$o{'user'} = shift @ARGV unless defined($o{'user'});
$o{'password'} = shift @ARGV unless defined($o{'password'});
Usage() if !defined($o{'dsn'}) || $o{'help'};
if (!($dbh = Connect($o{'dsn'}, $o{'user'}, $o{'password'}))) {
print STDERR "Cannot connect: $DBI::errstr\n";
exit 1;
}
if ($o{'dump'}) { Dump(\%o, $dbh); exit(0) }
if ($o{'input'}) {
open(STDIN, "<$o{'input'}")
or die "Failed to open $o{'input'} for input: $!";
}
if (!$batchMode) {
$term = Term::ReadLine->new("dbimon $VERSION");
my($rl_package) = $term->ReadLine();
my($rl_avail);
if ($rl_package eq "Term::ReadLine::Gnu") {
$attribs = $term->Attribs;
$attribs->{'attempted_completion_function'} = \&CompleteGnu;
$attribs->{'completion_entry_function'} =
$attribs->{'list_completion_function'};
$rl_avail = 'enabled';
} else {
$readline::rl_completion_function = 'main::Complete';
if ($rl_package eq 'Term::ReadLine::Perl' ||
$rl_package eq 'Term::ReadLine::readline_pl') {
$rl_avail = 'enabled';
} else {
$rl_avail = "available (get Term::ReadKey and"
. " Term::ReadLine::[Perl|GNU])";
}
}
my $serverinfo = eval { $dbh->func('getserverinfo'); };
if (!defined($serverinfo) || !$@) {
$serverinfo = 'No server information available';
}
print("DBImon $VERSION - the interactive DBI monitor\n",
"Copyright (C) 1997-99, Jochen Wiedmann\n",
"$serverinfo\n",
"Readline support $rl_avail\n\n");
}
# Main loop
my $line;
while ($batchMode ? defined($line = <STDIN>) :
defined($line = $term->readline($prompt))) {
# Remove preceding and trailing blanks, ignore empty lines
# and comments
$line =~ s/^\s+//;
$line =~ s/\s+$//;
if ($line =~ /^$/ || $line =~ /^\#/) {
next;
}
# Handle Perl evaluation
if ($line =~ /^\!/) {
my $command = $';
$command =~ s/^\s+//;
if ($command !~ /^$/) {
if (!$batchMode) {
$term->addhistory($command);
}
# Disable warnings
$^W = 0; eval $command;
if ($@) {
warn $@;
}
$^W = 1;
print "\n";
}
next;
}
# Help mode
if ($line =~ /^\?/) {
Help();
next;
}
# Perhaps this is a command?
my ($command, @args) = split(' ', $line);
if (!defined($command)) {
next;
}
if ($command =~ /^d(sn?)?$/i) {
if (@args) {
my($ndbh);
my($ndsn, $nuser, $npassword) = @args;
if (!($ndbh = Connect($ndsn, $nuser, $npassword))) {
print "Cannot connect: $DBI::errstr\n";
} else {
$dbh->disconnect;
$dbh = $ndbh;
$dsn = $args[0];
}
}
print "Current DSN is: $dsn\n";
} elsif ($command =~ /^q(u(it?)?)?$/i) {
if (!$batchMode) {
print "Goodbye\n";
}
last;
} elsif ($command =~ /^d(:?u(:?mp?))$/i) {
Dump(@args);
} elsif ($command =~ /^r(e(l(s(h(ow?)?)?)?)?)?$/i) {
if (@args > 2) {
print "Usage: relshow [<dsn> [<table>]]\n";
} else {
my ($dsn, $table) = @args;
RelShow($dsn, $table);
}
} elsif ($command =~ /^s(et?)?$/i) {
if (@args > 2) {
print "Usage: set [<var> [<val>]]\n";
} else {
my ($key, $val) = @args;
Set(@args);
}
} else {
# This is a query
$line =~ s/(\\[qgp]|\;)$//;
my $sth = $dbh->prepare($line);
if (!defined($sth)) {
if ($dieOnError) {
print STDERR "Execute error.\n";
print STDERR "Statement: $line\n";
print STDERR "Error message: ", $dbh->errstr(), "\n";
exit 1;
}
printf("Prepare error: %s\n", $dbh->errstr);
next;
}
my $rows = $sth->execute;
if (!$rows) {
if ($dieOnError) {
print STDERR "Execute error.\n";
print STDERR "Statement: $line\n";
print STDERR "Error message: ", $sth->errstr(), "\n";
exit 1;
}
printf("Execute error: %s\n", $sth->errstr);
next;
}
if ($sth->{'NUM_OF_FIELDS'} == 0) {
if (!$batchMode) {
if ($rows != -1) {
print "Query affected $rows rows.\n";
} else {
print "Query affected unknown number of rows.\n";
}
}
next; # Query with no result
}
# Now for the hard part: Create a table output
Output($sth);
$sth->finish;
}
}
exit 0;
}
__END__
=head1 NAME
dbimon - interactive shell with readline for DBI
=head1 SYNOPSIS
C<dbimon E<lt>dsnE<gt> [E<lt>userE<gt> [E<lt>passwordE<gt>]]>
[E<lt>optionsE<gt>]
=head1 DESCRIPTION
dbimon lets you talk to a running SQL server via the database independent
Perl interface DBI. dbimon was inspired by Andreas Koenig's pmsql and
borrows both design ideas and code from it. Thus the look and feel is
almost identical to pmsql, in particular the following holds:
=over 4
=item *
The output is formatted much in the same way as by the msql or mysql
monitor (see below), the msqlexport command and the relshow (mysqlshow)
programs, which are coming with msql or mysql.
=item *
The additional capability is a connection to a readline interface (if
available) and a pipe to your favorite pager.
=item *
Additionally you may switch between hosts and databases within one session
and you don't have to type the nasty C<\g> or C<;> (a trailing C<\g>, C<\q>,
and C<\p> will be ignored).
=back
If a command starts with one of the following reserved words, it's
treated specially, otherwise it is passed on verbatim to the DBMS.
Output from the daemon is piped to your pager specified by either the
DBIMON_PAGER or the PAGER environment variable. If both are undefined,
the PATH is searched for either "less" or "more" and the first program
found is taken. If no pager can be determined or your pager
variable is empty or set to C<stdout>, the program writes to unfiltered
STDOUT.
=over 2
=item C<?>
print usage summary
=item C<dsn E<lt>dsnE<gt>>
Connects to the given E<lt>dsnE<gt>, the old connection is closed.
=item C<q[uit]>
Leave dbimon.
=item C<re[lshow] [E<lt>dsnE<gt> [E<lt>tableE<gt>]]>
Without arguments this lists possible data sources by calling DBI's
I<data_sources> method. Data sources are driver dependent, the driver
of the last connection will be used. Unfortunately DBI offers no
possibilities of specifying a hostname or similar dsn attributes,
so you can hardly list a remote hosts dsns, for example.
If a C<dsn> is given, dbimon will connect to the given dsn and list
its tables. If both C<dsn> and C<table> are present, dbimon will list
the tables fields.
The latter possibilities are not supported by the DBI - these work
with private methods. Currently they are implemented for DBD::mSQL
and DBD::mysql.
=item C<se[t] [E<lt>varE<gt> [E<lt>valE<gt>]]>
This command displays and modifies dbimon's internal variables.
Without arguments, all variables and their current settings are
listed. With a variable name only you query the variables value.
The two argument form modifies a variable. Supported variables
are:
=over 4
=item showMode
This variable controls the output of an SQL result table. Possible values
are C<Box>, C<Export>, C<List>, C<Table> and C<HTML>. These correspond
to modes of the I<Data::ShowTable> module with the exception of C<Export>:
This is handled by dbimon internally, as I<Data::ShowTable> doesn't
offer such a mode. The C<Export> mode is well suited for exporting data to
other database systems. See L<Data::ShowTable(3)>.
=item less
This is the pager variable. You can turn off paging by setting this
to 'stdout'.
=item listWrapMargin
=item maxTableWidth
=item noEscape
These correspond to the variables C<$List_Wrap_Margin>, C<$Max_Table_Width>
and C<$No_Escape> of the I<Data::ShowTable> module. See L<Data::ShowTable(3)>.
=item escapeChar
=item quoteChar
=item sepChar
For C<Export> mode dbimon will use these variables. Columns are
surrounded by the I<quoteChar>, separated by the I<sepChar> and
the I<escapeChar> is used for inserting these special characters.
The defaults are well suited for Excel (I<escapeChar> = C<">,
I<quoteChar> = C<"> and I<sepChar> = C<;>), thus a row with the
values 1, 'walrus' and 'Nat "King" Cole' will be displayed as
"1";"walrus";"Nat ""King"" Cole"
=back
=item C<! EXPR>
Eval the EXPR in perl
=back
=head2 Dumping a database contents
The option B<--dump> forces dump of a databases contents, much like
I<msqldump> or I<mysqldump> do. By default all tables are dumped,
but you can override this with a sequence of B<--table $table> options.
Dumping means to emit a
CREATE TABLE $table (...)
statement (unless the option B<--no-dump-structure> is given), followed
by a sequence of
INSERT INTO $table (...)
statements, one per row, unless you use the option B<--no-dump-data>.
By default INSERT statements don't include column names, but the
option B<--dump-names> can force that.
=head2 Completion
dbimon comes with some basic completion definitions that are far from
being perfect. Completion means, you can use the TAB character to run
some lookup routines on the current dsn or table and use the results
to save a few keystrokes.
The completion mechanism is very basic, and I'm not intending to
refine it in the near future. Feel free to implement your own
refinements and let me know, if you have something better than what we
have here.
=head1 SEE ALSO
You need a readline package installed to get the advantage of a
readline interface. If you don't have it, you won't be able to use the
arrow keys in a meaningful manner. Term::ReadKey and Term::ReadLine do
not come with the perl distribution but are available from CPAN (see
http://www.perl.com/CPAN).
See L<pmsql (1)>, L<DBI (3)>, L<Term::ReadKey (3)>, L<Term::ReadLine (3)>,
=cut