Initial commit of OpenSPARC T2 design and verification files.

[OpenSPARC-T2-DV] / tools / perl-5.8.0 / lib / site_perl / 5.8.0 / sun4-solaris / DBI / Shell.pm

package DBI::Shell;

=head1 NAME

DBI::Shell - Interactive command shell for the DBI

=head1 SYNOPSIS

  perl -MDBI::Shell -e shell [<DBI data source> [<user> [<password>]]]

or

  dbish [<DBI data source> [<user> [<password>]]]

=head1 DESCRIPTION

The DBI::Shell module (and dbish command, if installed) provide a
simple but effective command line interface for the Perl DBI module.

DBI::Shell is very new, very experimental and very subject to change.
Your milage I<will> vary. Interfaces I<will> change with each release.

=cut

###
###	See TO DO section in the docs at the end.
###


BEGIN { require 5.004 }
BEGIN { $^W = 1 }

use strict;
use vars qw(@ISA @EXPORT $VERSION $SHELL);
use Exporter ();
use Carp;

@ISA = qw(Exporter);
@EXPORT = qw(shell);
$VERSION = sprintf "%d.%02d", '$Revision: 10.11 $ ' =~ /(\d+)\.(\d+)/;

my $warning = <<'EOM';

WARNING: The DBI::Shell interface and functionality are
=======  very likely to change in subsequent versions!

EOM

sub shell {
    my @args = @_ ? @_ : @ARGV;
    $SHELL = DBI::Shell::Std->new(@args);
    $SHELL->load_plugins;
    $SHELL->run;
}


# -------------------------------------------------------------
package DBI::Shell::Std;

use vars qw(@ISA);
@ISA = qw(DBI::Shell::Base);

# XXX this package might be used to override commands etc.


# -------------------------------------------------------------
package DBI::Shell::Base;

use Carp;
use Text::Abbrev ();
use Term::ReadLine;
use Getopt::Long 2.17;	# upgrade from CPAN if needed: http://www.perl.com/CPAN

use DBI 1.00 qw(:sql_types :utils);
use DBI::Format;

my $haveTermReadKey;


sub usage {
    warn <<USAGE;
Usage: perl -MDBI::Shell -e shell [<DBI data source> [<user> [<password>]]]
USAGE
}

sub log {
    my $sh = shift;
    ($sh->{batch}) ? warn @_,"\n" : print @_,"\n";	# XXX maybe
}

sub alert {	# XXX not quite sure how alert and err relate
    # for msgs that would pop-up an alert dialog if this was a Tk app
    my $sh = shift;
    warn @_,"\n";
}

sub err {	# XXX not quite sure how alert and err relate
    my ($sh, $msg, $die) = @_;
    $msg = "DBI::Shell: $msg\n";
    die $msg if $die;
    $sh->alert($msg);
}



sub add_option {
    my ($sh, $opt, $default) = @_;
    (my $opt_name = $opt) =~ s/[|=].*//;
    croak "Can't add_option '$opt_name', already defined"
	if exists $sh->{$opt_name};
    $sh->{options}->{$opt_name} = $opt;
    $sh->{$opt_name} = $default;
}


sub load_plugins {
    my ($sh) = @_;
    my @pi;
    foreach my $where (qw(DBI/Shell DBI_Shell)) {
	my $mod = $where; $mod =~ s!/!::!g; #/ so vim see the syn correctly
	my @dir = map { -d "$_/$where" ? ("$_/$where") : () } @INC;
	foreach my $dir (@dir) {
	    opendir DIR, $dir or warn "Unable to read $dir: $!\n";
	    push @pi, map { s/\.pm$//; "${mod}::$_" } grep { /\.pm$/ }
	        readdir DIR;
	    closedir DIR;
	}
    }
    foreach my $pi (@pi) {
	local $DBI::Shell::SHELL = $sh; # publish the current shell
	$sh->log("Loading $pi");
	eval qq{ use $pi };
	$sh->alert("Unable to load $pi: $@") if $@;
    }
    # plug-ins should remove options they recognise from (localized) @ARGV
    # by calling Getopt::Long::GetOptions (which is already in pass_through mode).
    foreach my $pi (@pi) {
	local *ARGV = $sh->{unhandled_options};
	$pi->init($sh);
    }
}


sub new {
    my ($class, @args) = @_;
    my $sh = bless {}, $class;

    #
    # Set default configuration options
    #
    foreach my $opt_ref (
	 [ 'command_prefix=s'	=> '/' ],
	 [ 'chistory_size=i'	=> 50 ],
	 [ 'rhistory_size=i'	=> 50 ],
	 [ 'rhistory_head=i'	=>  5 ],
	 [ 'rhistory_tail=i'	=>  5 ],
	 [ 'editor|ed=s'	=> ($ENV{VISUAL} || $ENV{EDITOR} || 'vi') ],
	 [ 'batch'		=> 0 ],
	 [ 'displaymode|display'=> 'neat' ],
	 [ 'columnseparator=s' => ',' ],
	# defaults for each new database connect:
	 [ 'init_trace|trace=i' => 0 ],
	 [ 'init_autocommit|autocommit=i' => 1 ],
	 [ 'debug|d=i'		=> ($ENV{DBISH_DEBUG} || 0) ],
    ) {
	$sh->add_option(@$opt_ref);
    }


    #
    # Install default commands
    #
    # The sub is passed a reference to the shell and the @ARGV-style
    # args it was invoked with.
    #
    $sh->{commands} = {

    'help' => {
	    hint => "display this list of commands",
    },
    'quit' => {
	    hint => "exit",
    },
    'exit' => {
	    hint => "exit",
    },
    'trace' => {
	    hint => "set DBI trace level for current database",
    },
    'connect' => {
	    hint => "connect to another data source/DSN",
    },

    # --- execute commands
    'go' => {
	    hint => "execute the current statement",
    },
    'do' => {
	    hint => "execute the current (non-select) statement",
    },
    'perl' => {
	    hint => "evaluate the current statement as perl code",
    },
    'commit' => {
	    hint => "commit changes to the database",
    },
    'rollback' => {
	    hint => "rollback changes to the database",
    },
    # --- information commands
    'table_info' => {
	    hint => "display tables that exist in current database",
    },
    'type_info' => {
	    hint => "display data types supported by current server",
    },
    'drivers' => {
	    hint => "display available DBI drivers",
    },

    # --- statement/history management commands
    'clear' => {
	    hint => "erase the current statement",
    },
    'redo' => {
	    hint => "re-execute the previously executed statement",
    },
    'get' => {
	    hint => "make a previous statement current again",
    },
    'current' => {
	    hint => "display current statement",
    },
    'edit' => {
	    hint => "edit current statement in an external editor",
    },
    'chistory' => {
	    hint => "display command history",
    },
    'rhistory' => {
	    hint => "display result history",
    },
    'format' => {
	    hint => "set display format for selected data (Neat|Box)",
    },
    'history' => {
	    hint => "display combined command and result history",
    },
    'option' => {
	    hint => "display or set an option value",
    },
    'describe' => {
	    hint => "display information about a table",
    },

    };


    # Source config file which may override the defaults.
    # Default is $ENV{HOME}/.dbish_config.
    # Can be overridden with $ENV{DBISH_CONFIG}.
    # Make $ENV{DBISH_CONFIG} empty to prevent sourcing config file.
    # XXX all this will change
    my $homedir = $ENV{HOME}				# unix
		|| "$ENV{HOMEDRIVE}$ENV{HOMEPATH}";	# NT
    $sh->{config_file} = $ENV{DBISH_CONFIG} || "$homedir/.dbish_config";
    if ($sh->{config_file} && -f $sh->{config_file}) {
	require $sh->{config_file};
    }
    
    #
    # Handle command line parameters
    #
    # data_source and user command line parameters overrides both 
    # environment and config settings.
    #
    local (@ARGV) = @args;
    my @options = values %{ $sh->{options} };
    Getopt::Long::config('pass_through');	# for plug-ins
    unless (GetOptions($sh, 'help|h', @options)) {
	$class->usage;
	croak "DBI::Shell aborted.\n";
    }
    if ($sh->{help}) {
	$class->usage;
	return;
    }
    $sh->{unhandled_options} = [];
    @args = ();
    foreach my $arg (@ARGV) {
	if ($arg =~ /^-/) {	# expected to be in "--opt=value" format
	    push @{$sh->{unhandled_options}}, $arg;
	}
	else {
	    push @args, $arg;
	}
    }

    $sh->do_format($sh->{displaymode});

    $sh->{data_source}	= shift(@args) || $ENV{DBI_DSN}  || '';
    $sh->{user}		= shift(@args) || $ENV{DBI_USER} || '';
    $sh->{password}	= shift(@args) || $ENV{DBI_PASS} || undef;

    $sh->{chistory} = [];	# command history
    $sh->{rhistory} = [];	# result  history

    #
    # Setup Term
    #
    my $mode;
    if ($sh->{batch} || ! -t STDIN) {
	$sh->{batch} = 1;
	$mode = "in batch mode";
    }
    else {
	$sh->{term} = new Term::ReadLine($class);
	$mode = "";
    }

    $sh->log("DBI::Shell $DBI::Shell::VERSION using DBI $DBI::VERSION $mode");
    $sh->log("DBI::Shell loaded from $INC{'DBI/Shell.pm'}") if $sh->{debug};

    return $sh;
}


sub run {
    my $sh = shift;

    die "Unrecognised options: @{$sh->{unhandled_options}}\n"
	if @{$sh->{unhandled_options}};

    $sh->log($warning) unless $sh->{batch};

    # Use valid "dbi:driver:..." to connect with source.
    $sh->do_connect( $sh->{data_source} );

    #
    # Main loop
    #
    $sh->{abbrev} = undef;
    $sh->{abbrev} = Text::Abbrev::abbrev(keys %{$sh->{commands}})
	unless $sh->{batch};
    $sh->{current_buffer} = '';
    my $current_line = '';

    while (1) {
	my $prefix = $sh->{command_prefix};

	$current_line = $sh->readline($sh->prompt());
	$current_line = "${prefix}quit" unless defined $current_line;

	if ( $current_line =~ /
		^(.*?)
		$prefix
		(?:(\w*)([^\|>]*))?
		((?:\||>>?).+)?
		$
	/x) {
	    my ($stmt, $cmd, $args_string, $output) = ($1, $2, $3, $4||''); 

	    $sh->{current_buffer} .= "$stmt\n" if length $stmt;

	    $cmd = 'go' if $cmd eq '';
	    my @args = split ' ', $args_string||'';

	    warn("command='$cmd' args='$args_string' output='$output'") 
		    if $sh->{debug};

	    my $command;
	    if ($sh->{abbrev}) {
		$command = $sh->{abbrev}->{$cmd};
	    }
	    else {
		$command = ($sh->{commands}->{$cmd}) ? $cmd : undef;
	    }
	    if ($command) {
		$sh->run_command($command, $output, @args);
	    }
	    else {
		if ($sh->{batch}) {
		    die "Command '$cmd' not recognised";
		}
		$sh->alert("Command '$cmd' not recognised ",
		    "(enter ${prefix}help for help).");
	    }
	}
	elsif ($current_line ne "") {
	    $sh->{current_buffer} .= $current_line . "\n";
	    # print whole buffer here so user can see it as
	    # it grows (and new users might guess that unrecognised
	    # inputs are treated as commands)
	    $sh->run_command('current', undef,
		"(enter '$prefix' to execute or '${prefix}help' for help)");
	}
    }
}
	



#
# Internal methods
#

sub readline {
    my ($sh, $prompt) = @_;
    my $rv;
    if ($sh->{term}) {
	$rv = $sh->{term}->readline($prompt);
    }
    else {
	chop($rv = <STDIN>);
    }
    return $rv;
}


sub run_command {
    my ($sh, $command, $output, @args) = @_;
    return unless $command;
    local(*STDOUT) if $output;
    local(*OUTPUT) if $output;
    if ($output) {
	if (open(OUTPUT, $output)) {
	    *STDOUT = *OUTPUT;
	} else {
	    $sh->err("Couldn't open output '$output'");
	    $sh->run_command('current', undef, '');
	}
    }
    eval {
	my $code = "do_$command";
	$sh->$code(@args);
    };
    close OUTPUT if $output;
    $sh->err("$command failed: $@") if $@;
}


sub print_list {
    my ($sh, $list_ref) = @_;
    for(my $i = 0; $i < @$list_ref; $i++) {
	print $i+1,":  $$list_ref[$i]\n";
    }
}


sub print_buffer {
    my ($sh, $buffer) = @_;
    print $sh->prompt(), $buffer, "\n";
}


sub get_data_source {
    my ($sh, $dsn, @args) = @_;
    my $driver;

    if ($dsn) {
	if ($dsn =~ m/^dbi:.*:/i) {	# has second colon
	    return $dsn;		# assumed to be full DSN
	}
	elsif ($dsn =~ m/^dbi:([^:]*)/i) {
	    $driver = $1		# use DriverName part
	}
	else {
	    print "Ignored unrecognised DBI DSN '$dsn'.\n";
	}
    }

    if ($sh->{batch}) {
	die "Missing or unrecognised DBI DSN.";
    }

    print "\n";
    while (!$driver) {
	print "Available DBI drivers:\n";
	my @drivers = DBI->available_drivers;
	for( my $cnt = 0; $cnt <= $#drivers; $cnt++ ) {
	    printf "%2d: dbi:%s\n", $cnt+1, $drivers[$cnt];
	} 
	$driver = $sh->readline(
		"Enter driver name or number, or full 'dbi:...:...' DSN: ");
	exit unless defined $driver;	# detect ^D / EOF
	print "\n";

	return $driver if $driver =~ /^dbi:.*:/i; # second colon entered

	if ( $driver =~ /^\s*(\d+)/ ) {
	    $driver = $drivers[$1-1];
	} else {
	    $driver = $1;
	    $driver =~ s/^dbi://i if $driver # incase they entered 'dbi:Name'
	}
	# XXX try to install $driver (if true)
	# unset $driver if install fails.
    }

    my $source;
    while (!defined $source) {
	my $prompt;
	my @data_sources = DBI->data_sources($driver);
	if (@data_sources) {
	    print "Enter data source to connect to: \n";
	    for( my $cnt = 0; $cnt <= $#data_sources; $cnt++ ) {
		printf "%2d: %s\n", $cnt+1, $data_sources[$cnt];
	    } 
	    $prompt = "Enter data source or number,";
	}
	else {
	    print "(The data_sources method returned nothing.)\n";
	    $prompt = "Enter data source";
	}
	$source = $sh->readline(
		"$prompt or full 'dbi:...:...' DSN: ");
	return if !defined $source;	# detect ^D / EOF
	if ($source =~ /^\s*(\d+)/) {
	    $source = $data_sources[$1-1]
	}
	elsif ($source =~ /^dbi:([^:]+)$/) { # no second colon
	    $driver = $1;		     # possibly new driver
	    $source = undef;
	}
	print "\n";
    }

    return $source;
}


sub prompt_for_password {
    my ($sh) = @_;
    if (!defined($haveTermReadKey)) {
	$haveTermReadKey = eval { require Term::ReadKey } ? 1 : 0;
    }
    local $| = 1;
    print "Password for $sh->{user} (",
	($haveTermReadKey ? "not " : "Warning: "),
	"echoed to screen): ";
    if ($haveTermReadKey) {
        Term::ReadKey::ReadMode('noecho');
	$sh->{password} = Term::ReadKey::ReadLine(0);
	Term::ReadKey::ReadMode('restore');
    } else {
	$sh->{password} = <STDIN>;
    }
    chomp $sh->{password};
    print "\n";
}

sub prompt {
    my ($sh) = @_;
    return "" if $sh->{batch};
    return "(not connected)> " unless $sh->{dbh};
    return "$sh->{user}\@$sh->{data_source}> ";
}


sub push_chistory {
    my ($sh, $cmd) = @_;
    $cmd = $sh->{current_buffer} unless defined $cmd;
    $sh->{prev_buffer} = $cmd;
    my $chist = $sh->{chistory};
    shift @$chist if @$chist >= $sh->{chistory_size};
    push @$chist, $cmd;
}


#
# Command methods
#

sub do_help {
    my ($sh, @args) = @_;
    my $prefix = $sh->{command_prefix};
    my $commands = $sh->{commands};
    print "Defined commands, in alphabetical order:\n";
    foreach my $cmd (sort keys %$commands) {
	my $hint = $commands->{$cmd}->{hint} || '';
	printf "  %s%-10s %s\n", $prefix, $cmd, $hint;
    }
    print "Commands can be abbreviated.\n" if $sh->{abbrev};
}


sub do_format {
    my ($sh, @args) = @_;
    my $mode = $args[0] || '';
    my $col_sep = $args[1];
    my $class = eval { DBI::Format->formatter($mode) };
    unless ($class) {
	$sh->alert("Unable to select '$mode': $@");
	return;
    }
    $sh->log("Using formatter class '$class'") if $sh->{debug};
    $sh->{display} = $class->new($sh);
    $sh->do_option("columnseparator=$col_sep") if $col_sep;
}


sub do_go {
    my ($sh, @args) = @_;

    return if $sh->{current_buffer} eq '';

    $sh->{prev_buffer} = $sh->{current_buffer};

    $sh->push_chistory;
    
    eval {
	my $sth = $sh->{dbh}->prepare($sh->{current_buffer});

	$sh->sth_go($sth, 1);
    };
    if ($@) {
	my $err = $@;
	$err =~ s: at \S*DBI/Shell.pm line \d+(,.*?chunk \d+)?::
		if !$sh->{debug} && $err =~ /^DBD::\w+::\w+ \w+/;
	print "$err";
    }

    # There need to be a better way, maybe clearing the
    # buffer when the next non command is typed.
    # Or sprinkle <$sh->{current_buffer} ||= $sh->{prev_buffer};>
    # around in the code.
    $sh->{current_buffer} = '';
}


sub sth_go {
    my ($sh, $sth, $execute) = @_;

    my $rv;
    if ($execute || !$sth->{Active}) {
	my @params;
	my $params = $sth->{NUM_OF_PARAMS} || 0;
	print "Statement has $params parameters:\n" if $params;
	foreach(1..$params) {
	    my $val = $sh->readline("Parameter $_ value: ");
	    push @params, $val;
	}
	$rv = $sth->execute(@params);
    }
	
    if (!$sth->{'NUM_OF_FIELDS'}) { # not a select statement
	local $^W=0;
	$rv = "undefined number of" unless defined $rv;
	$rv = "unknown number of"   if $rv == -1;
	print "[$rv row" . ($rv==1 ? "" : "s") . " affected]\n";
	return;
    }

    $sh->{sth} = $sth;

    #
    # Remove oldest result from history if reached limit
    #
    my $rhist = $sh->{rhistory};
    shift @$rhist if @$rhist >= $sh->{rhistory_size};
    push @$rhist, [];

    #
    # Keep a buffer of $sh->{rhistory_tail} many rows,
    # when done with result add those to rhistory buffer.
    # Could use $sth->rows(), but not all DBD's support it.
    #
    my @rtail;
    my $i = 0;
    my $display = $sh->{display} || die "panic: no display set";
    $display->header($sth, \*STDOUT, $sh->{columnseparator});
    while (my $rowref = $sth->fetchrow_arrayref()) {
	$i++;

	$display->row($rowref);

	if ($i <= $sh->{rhistory_head}) {
	    push @{$rhist->[-1]}, [@$rowref];
	}
	else {
	    shift @rtail if @rtail == $sh->{rhistory_tail};
	    push @rtail, [@$rowref];
	}

    }
    $display->trailer($i);

    if (@rtail) {
	my $rows = $i;
	my $ommitted = $i - $sh->{rhistory_head} - @rtail;
	    push(@{$rhist->[-1]},
		 [ "[...$ommitted rows out of $rows ommitted...]"]);
	foreach my $rowref (@rtail) {
	    push @{$rhist->[-1]}, $rowref;
	}
    }

    #$sh->{sth} = undef;
    #$sth->finish();	# drivers which need this are broken
}


sub do_do {
    my ($sh, @args) = @_;
    $sh->push_chistory;
    my $rv = $sh->{dbh}->do($sh->{current_buffer});
    print "[$rv row" . ($rv==1 ? "" : "s") . " affected]\n"
	if defined $rv;

    # XXX I question setting the buffer to '' here.
    # I may want to edit my line without having to scroll back.
    $sh->{current_buffer} = '';
}


sub do_disconnect {
    my ($sh, @args) = @_;
    return unless $sh->{dbh};
    $sh->log("Disconnecting from $sh->{data_source}.");
    eval {
	$sh->{sth}->finish if $sh->{sth};
	$sh->{dbh}->rollback unless $sh->{dbh}->{AutoCommit};
	$sh->{dbh}->disconnect;
    };
    $sh->alert("Error during disconnect: $@") if $@;
    $sh->{sth} = undef;
    $sh->{dbh} = undef;
}


sub do_connect {
    my ($sh, $dsn, $user, $pass) = @_;

    $dsn = $sh->get_data_source($dsn);
    return unless $dsn;

    $sh->do_disconnect if $sh->{dbh};

    $sh->{data_source} = $dsn;
    if (defined $user and length $user) {
	$sh->{user}     = $user;
	$sh->{password} = undef;	# force prompt below
    }

    $sh->log("Connecting to '$sh->{data_source}' as '$sh->{user}'...");
    if ($sh->{user} and !defined $sh->{password}) {
	$sh->prompt_for_password();
    }
    $sh->{dbh} = DBI->connect(
	$sh->{data_source}, $sh->{user}, $sh->{password}, {
	    AutoCommit => $sh->{init_autocommit},
	    PrintError => 0,
	    RaiseError => 1,
	    LongTruncOk => 1,	# XXX
    });
    $sh->{dbh}->trace($sh->{init_trace}) if $sh->{init_trace};
}


sub do_current {
    my ($sh, $msg, @args) = @_;
    $msg = $msg ? " $msg" : "";
    $sh->log("Current statement buffer$msg:\n" . $sh->{current_buffer});
}


sub do_trace {
    shift->{dbh}->trace(@_);
}

sub do_commit {
    shift->{dbh}->commit(@_);
}

sub do_rollback {
    shift->{dbh}->rollback(@_);
}


sub do_quit {
    my ($sh, @args) = @_;
    $sh->do_disconnect if $sh->{dbh};
    undef $sh->{term};
    exit 0;
}

# Until the alias command is working each command requires definition.
sub do_exit { shift->do_quit(@_); }

sub do_clear {
    my ($sh, @args) = @_;
    $sh->{current_buffer} = '';
}


sub do_redo {
    my ($sh, @args) = @_;
    $sh->{current_buffer} = $sh->{prev_buffer} || '';
    $sh->run_command('go') if $sh->{current_buffer};
}


sub do_chistory {
    my ($sh, @args) = @_;
    $sh->print_list($sh->{chistory});
}

sub do_history {
    my ($sh, @args) = @_;
    for(my $i = 0; $i < @{$sh->{chistory}}; $i++) {
	print $i+1, ":\n", $sh->{chistory}->[$i], "--------\n";
	foreach my $rowref (@{$sh->{rhistory}[$i]}) {
	    print "    ", join(", ", @$rowref), "\n";
	}
    }
}

sub do_rhistory {
    my ($sh, @args) = @_;
    for(my $i = 0; $i < @{$sh->{rhistory}}; $i++) {
	print $i+1, ":\n";
	foreach my $rowref (@{$sh->{rhistory}[$i]}) {
	    print "    ", join(", ", @$rowref), "\n";
	}
    }
}


sub do_get {
    my ($sh, $num, @args) = @_;
    if (!$num || $num !~ /^\d+$/ || !defined($sh->{chistory}->[$num-1])) {
	$sh->err("No such command number '$num'. Use /chistory to list previous commands.");
	return;
    }
    $sh->{current_buffer} = $sh->{chistory}->[$num-1];
    $sh->print_buffer($sh->{current_buffer});
}


sub do_perl {
    my ($sh, @args) = @_;
	$DBI::Shell::eval::dbh = $sh->{dbh};
    eval "package DBI::Shell::eval; $sh->{current_buffer}";
    if ($@) { $sh->err("Perl failed: $@") }
    $sh->run_command('clear');
}


sub do_edit {
    my ($sh, @args) = @_;

    $sh->run_command('get', '', $&) if @args and $args[0] =~ /^\d+$/;
    $sh->{current_buffer} ||= $sh->{prev_buffer};
	    
    # Find an area to write a temp file into.
    my $tmp_dir = $ENV{DBISH_TMP} || # Give people the choice.
	    $ENV{TMP}  ||            # Is TMP set?
	    $ENV{TEMP} ||            # How about TEMP?
	    $ENV{HOME} ||            # Look for HOME?
	    $ENV{HOMEDRIVE} . $ENV{HOMEPATH} || # Last env checked.
	    ".";       # fallback: try to write in current directory.
    my $tmp_file = "$tmp_dir/dbish$$.sql";

    local (*FH);
    open(FH, ">$tmp_file") ||
	    $sh->err("Can't create $tmp_file: $!\n", 1);
    print FH $sh->{current_buffer} if defined $sh->{current_buffer};
    close(FH) || $sh->err("Can't write $tmp_file: $!\n", 1);

    my $command = "$sh->{editor} $tmp_file";
    system($command);

    # Read changes back in (editor may have deleted and rewritten file)
    open(FH, "<$tmp_file") || $sh->err("Can't open $tmp_file: $!\n");
    $sh->{current_buffer} = join "", <FH>;
    close(FH);
    unlink $tmp_file;

    $sh->run_command('current');
}


sub do_drivers {
    my ($sh, @args) = @_;
    $sh->log("Available drivers:");
    my @drivers = DBI->available_drivers;
    foreach my $driver (sort @drivers) {
	$sh->log("\t$driver");
    }
}


sub do_type_info {
    my ($sh, @args) = @_;
    my $dbh = $sh->{dbh};
    my $ti = $dbh->type_info_all;
    my $ti_cols = shift @$ti;
    my @names = sort { $ti_cols->{$a} <=> $ti_cols->{$b} } keys %$ti_cols;
    my $sth = $sh->prepare_from_data("type_info", $ti, \@names);
    $sh->sth_go($sth, 0);
}

sub do_describe {
    my ($sh, $tab, @argv) = @_;
	$sh->log( "Describle: $tab" );
	my $dbh = $sh->{dbh};
	my $sql = qq{select * from $tab where 1 = 0};
	my $sth = $dbh->prepare( $sql );
	$sth->execute;
	my $cnt = $#{$sth->{NAME}};  #
    	my @names = qw{NAME TYPE NULLABLE};
	my @ti;
	#push( @j, join( "\t", qw{NAME TYPE PRECISION SCALE NULLABLE}));
	for ( my $c = 0; $c <= $cnt; $c++ ) {
		push( my @j, $sth->{NAME}->[$c] || 0 );
		my $m = $dbh->type_info($sth->{TYPE}->[$c]);
		my $s;
		if (ref $m eq 'HASH') {
			$s = $m->{TYPE_NAME};
		} elsif (not defined $m) {
			 $s = q{undef } . $sth->{TYPE}->[$c];
		} else {
			warn "describe: can't parse data ($m) from type_info!";
		}

		if (defined $sth->{PRECISION}->[$c]) {
			$s .= "(" . $sth->{PRECISION}->[$c] || '';
			$s .= "," . $sth->{SCALE}->[$c] 
			if ( defined $sth->{SCALE}->[$c] 
				and $sth->{SCALE}->[$c] ne 0);
			$s .= ")";
		}
		push(@j, $s,
			 $sth->{NULLABLE}->[$c] ne 1? qq{N}: qq{Y} );
		push(@ti,\@j);
	}
	$sth->finish;
	$sth = $sh->prepare_from_data("describe", \@ti, \@names);
	$sh->sth_go($sth, 0);
}


sub prepare_from_data {
    my ($sh, $statement, $data, $names, %attr) = @_;
    my $sponge = DBI->connect("dbi:Sponge:","","",{ RaiseError => 1 });
    my $sth = $sponge->prepare($statement, { rows=>$data, NAME=>$names, %attr });
    return $sth;
}


# Do option: sets or gets an option
sub do_option {
    my ($sh, @args) = @_;

    unless (@args) {
	foreach my $opt (sort keys %{ $sh->{options}}) {
	    my $value = (defined $sh->{$opt}) ? $sh->{$opt} : 'undef';
	    $sh->log(sprintf("%20s: %s", $opt, $value));
	}
	return;
    }

    my $options = Text::Abbrev::abbrev(keys %{$sh->{options}});

    # Expecting the form [option=value] [option=] [option]
    foreach my $opt (@args) {
	my ($opt_name, $value) = $opt =~ /^\s*(\w+)(?:=(.*))?/;
	$opt_name = $options->{$opt_name} || $opt_name if $opt_name;
	if (!$opt_name || !$sh->{options}->{$opt_name}) {
	    $sh->log("Unknown or ambiguous option name '$opt_name' (use name=value format)");
	    next;
	}
	my $crnt = (defined $sh->{$opt_name}) ? $sh->{$opt_name} : 'undef';
	my $log;
	if (not defined $value) {
	    $log = "$opt_name=$crnt";
	}
	else {
	    $log = "/option $opt_name=$value  (was $crnt)";
	    $sh->{$opt_name} = ($value eq 'undef') ? undef : $value;
	}
	$sh->log($sh->{command_prefix}."option $log");
    }
}


sub do_table_info {
    my ($sh, @args) = @_;
    my $dbh = $sh->{dbh};
    my $sth = $dbh->table_info(@args);
    unless(ref $sth) {
	print "Driver has not implemented the table_info() method, ",
		"trying tables()\n";
	my @tables = $dbh->tables(@args); # else try list context
	unless (@tables) {
	    print "No tables exist ",
		  "(or driver hasn't implemented the tables method)\n";
	    return;
	}
	$sth = $sh->prepare_from_data("tables",
		[ map { [ $_ ] } @tables ],
		[ "TABLE_NAME" ]
	);
    }
    $sh->sth_go($sth, 0);
}



1;
__END__

=head1 TO DO

Proper docs - but not yet, too much is changing.

"/source file" command to read command file.
Allow to nest via stack of command file handles.
Add command log facility to create batch files.

Commands:
	load (query?) from file
	save (query?) to file

Use Data::ShowTable if available.

Define DBI::Shell plug-in semantics.
	Implement import/export as plug-in module

Clarify meaning of batch mode

Completion hooks

Set/Get DBI handle attributes

Portability

Emulate popular command shell modes (Oracle, Ingres etc)?

=head1 COMMANDS

Many commands - few documented, yet!

=over 4

=item help

  /help

=item chistory

  /chistory          (display history of all commands entered)
  /chistory | YourPager (display history with paging)

=item clear

  /clear             (Clears the current command buffer)

=item commit

  /commit            (commit changes to the database)

=item connect

  /connect           (pick from available drivers and sources)
  /connect dbi:Oracle (pick source from based on driver)
  /connect dbi:YourDriver:YourSource i.e. dbi:Oracle:mysid

Use this option to change userid or password.

=item current

  /current            (Display current statement in the buffer)

=item do

  /do                 (execute the current (non-select) statement)

	dbish> create table foo ( mykey integer )
	dbish> /do

	dbish> truncate table OldTable /do (Oracle truncate)

=item drivers

  /drivers            (Display available DBI drivers)

=item edit

  /edit               (Edit current statement in an external editor)

Editor is defined using the enviroment variable $VISUAL or
$EDITOR or default is vi.  Use /option editor=new editor to change
in the current session.

To read a file from the operating system invoke the editor (/edit)
and read the file into the editor buffer.

=item exit

  /exit              (Exits the shell)

=item get

  /get               (Retrieve a previous command to the current buffer)

=item go

  /go                (Execute the current statement)

Run (execute) the statement in the current buffer.  This is the default
action if the statement ends with /

	dbish> select * from user_views/

	dbish> select table_name from user_tables
	dbish> where table_name like 'DSP%'
	dbish> /

	dbish> select table_name from all_tables/ | more

=item history

  /history            (Display combined command and result history)
  /history | more

=item option

  /option [option1[=value]] [option2 ...]
  /option            (Displays the current options)
  /option   MyOption (Displays the value, if exists, of MyOption)
  /option   MyOption=4 (defines and/or sets value for MyOption)

=item perl

  /perl               (Evaluate the current statement as perl code)

=item quit

  /quit               (Leaves shell.  Same as exit)

=item redo

  /redo               (Re-execute the previously executed statement)

=item rhistory

  /rhistory           (Display result history)

=item rollback

  /rollback           (rollback changes to the database)

For this to be useful, turn the autocommit off. /option autocommit=0

=item table_info

  /table_info         (display all tables that exist in current database)
  /table_info | more  (for paging)

=item trace

  /trace              (set DBI trace level for current database)

Adjust the trace level for DBI 0 - 4.  0 off.  4 is lots of information.
Useful for determining what is really happening in DBI.  See DBI.

=item type_info

  /type_info          (display data types supported by current server)

=back

=head1 AUTHORS and ACKNOWLEDGEMENTS

The DBI::Shell has a long lineage.

It started life around 1994-1997 as the pmsql script written by Andreas