home *** CD-ROM | disk | FTP | other *** search
/ PC Professionell 2004 December / PCpro_2004_12.ISO / files / webserver / tsw / TSW_3.4.0.exe / Apache2 / perl / Shell.pm < prev    next >
Encoding:
Perl POD Document  |  2003-10-02  |  46.1 KB  |  1,892 lines
  1. package DBI::Shell;
  2. # vim:ts=4:sw=4:ai:aw:nowrapscan
  3.  
  4. =head1 NAME
  5.  
  6. DBI::Shell - Interactive command shell for the DBI
  7.  
  8. =head1 SYNOPSIS
  9.  
  10.   perl -MDBI::Shell -e shell [<DBI data source> [<user> [<password>]]]
  11.  
  12. or
  13.  
  14.   dbish [<DBI data source> [<user> [<password>]]]
  15.   dbish --debug [<DBI data source> [<user> [<password>]]]
  16.   dbish --batch [<DBI data source> [<user> [<password>]]] < batch file
  17.  
  18. =head1 DESCRIPTION
  19.  
  20. The DBI::Shell module (and dbish command, if installed) provide a
  21. simple but effective command line interface for the Perl DBI module.
  22.  
  23. DBI::Shell is very new, very experimental and very subject to change.
  24. Your mileage I<will> vary. Interfaces I<will> change with each release.
  25.  
  26. =cut
  27.  
  28. ###
  29. ###    See TO DO section in the docs at the end.
  30. ###
  31.  
  32.  
  33. BEGIN { require 5.004 }
  34. BEGIN { $^W = 1 }
  35.  
  36. use strict;
  37. use vars qw(@ISA @EXPORT $VERSION $SHELL);
  38. use Exporter ();
  39. use Carp;
  40.  
  41. @ISA = qw(Exporter DBI::Shell::Std);
  42. @EXPORT = qw(shell);
  43.  
  44. $VERSION = sprintf( "%d.%02d", q$Revision: 11.93 $ =~ /(\d+)\.(\d+)/ );
  45.  
  46. my $warning = <<'EOM';
  47.  
  48. WARNING: The DBI::Shell interface and functionality are
  49. =======  very likely to change in subsequent versions!
  50.  
  51. EOM
  52.  
  53. sub new {
  54.     my $class = shift;
  55.     my @args = @_ ? @_ : @ARGV;
  56.     #my $sh = bless {}, $class;
  57.     my $sh = $class->SUPER::new(@args);
  58.     # Load configuration files, system and user.  The user configuration may
  59.     # over ride the system configuration.
  60.     my $myconfig = $sh->configuration;
  61.     # Save the configuration file for this instance.
  62.     $sh->{myconfig} = $myconfig;
  63.     # Pre-init plugins.
  64.     $sh->load_plugins($myconfig->{'plug-ins'}->{'pre-init'});
  65.     # Post-init plugins.
  66.     #$sh->SUPER::init(@args);
  67.     $sh->load_plugins($myconfig->{'plug-ins'}->{'post-init'});
  68. return $sh;
  69. }
  70.  
  71. sub shell {
  72.     my @args = @_ ? @_ : @ARGV;
  73.     $SHELL = DBI::Shell::Std->new(@args);
  74.     $SHELL->load_plugins;
  75.     $SHELL->run;
  76. }
  77.  
  78. sub run {
  79.     my $sh = shift;
  80.     die "Unrecognised options: @{$sh->{unhandled_options}}\n"
  81.     if @{$sh->{unhandled_options}};
  82.  
  83.     $sh->log($warning) unless $sh->{batch};
  84.  
  85.     # Use valid "dbi:driver:..." to connect with source.
  86.     $sh->do_connect( $sh->{data_source} );
  87.  
  88.     #
  89.     # Main loop
  90.     #
  91.     $sh->{abbrev} = undef;
  92.     $sh->{abbrev} = Text::Abbrev::abbrev(keys %{$sh->{commands}});
  93.         # unless $sh->{batch};
  94.     $sh->{current_buffer} = '';
  95.     $sh->SUPER::run;
  96.  
  97. }
  98.  
  99.  
  100. # -------------------------------------------------------------
  101. package DBI::Shell::Std;
  102.  
  103. use vars qw(@ISA);
  104. @ISA = qw(DBI::Shell::Base);
  105.  
  106. # XXX this package might be used to override commands etc.
  107. sub do_connect {
  108.     my $sh = shift;
  109.     $sh->load_plugins($sh->{myconfig}->{'plug-ins'}->{'pre-connect'})
  110.         if exists $sh->{myconfig}->{'plug-ins'}->{'pre-connect'};
  111.     $sh->SUPER::do_connect(@_);
  112.     $sh->load_plugins($sh->{myconfig}->{'plug-ins'}->{'post-connect'})
  113.         if exists $sh->{myconfig}->{'plug-ins'}->{'post-connect'};
  114. return;
  115. }
  116.  
  117. sub init {
  118.     my $sh = shift;
  119.     return;
  120. }
  121.  
  122.  
  123. # -------------------------------------------------------------
  124. package DBI::Shell::Base;
  125.  
  126. use Carp;
  127. use Text::Abbrev ();
  128. use Term::ReadLine;
  129. use Getopt::Long 2.17;    # upgrade from CPAN if needed: http://www.perl.com/CPAN
  130. use IO::File;
  131.  
  132. use DBI 1.00 qw(:sql_types :utils);
  133. use DBI::Format;
  134.  
  135. use DBI::Shell::FindSqlFile;
  136.  
  137. use vars qw(@ISA);
  138. @ISA = qw(DBI::Shell::FindSqlFile);
  139.  
  140. use constant ADD_RH => 1;    # Add the results, to rhistory.
  141. use constant  NO_RH => 0;    # Do not add results, to rhistory.
  142.  
  143. my $haveTermReadKey;
  144. my $term;
  145.  
  146.  
  147. sub usage {
  148.     warn <<USAGE;
  149. Usage: perl -MDBI::Shell -e shell [<DBI data source> [<user> [<password>]]]
  150. USAGE
  151. }
  152.  
  153. sub log {
  154.     my $sh = shift;
  155.     return ($sh->{batch}) ? warn @_,"\n" : $sh->print_buffer_nop(@_,"\n");    # XXX maybe
  156. }
  157.  
  158. sub alert {    # XXX not quite sure how alert and err relate
  159.     # for msgs that would pop-up an alert dialog if this was a Tk app
  160.     my $sh = shift;
  161.     return warn @_,"\n";
  162. }
  163.  
  164. sub err {    # XXX not quite sure how alert and err relate
  165.     my ($sh, $msg, $die) = @_;
  166.     $msg = "DBI::Shell: $msg\n";
  167.     die $msg if $die;
  168.     return $sh->alert($msg);
  169. }
  170.  
  171.  
  172.  
  173. sub add_option {
  174.     my ($sh, $opt, $default) = @_;
  175.     (my $opt_name = $opt) =~ s/[|=].*//;
  176.     croak "Can't add_option '$opt_name', already defined"
  177.         if exists $sh->{$opt_name};
  178.     $sh->{options}->{$opt_name} = $opt;
  179.     $sh->{$opt_name} = $default;
  180. }
  181.  
  182. sub load_plugins {
  183.     my ($sh, @ppi) = @_;
  184.     # Output must  not  appear  while  loading  plugins:
  185.     # It  might  happen,  that  batch  mode  is  entered
  186.     # later!
  187.     my @pi;
  188.     return unless(@ppi);
  189.     foreach my $n (0 .. $#ppi) {
  190.         next unless ($ppi[$n]);
  191.         my $pi = $ppi[$n];
  192.  
  193.         if ( ref $pi eq  'HASH' ) {
  194.             # As we descend down the hash reference,
  195.             # we're looking for an array of modules to source in.
  196.             my @mpi = keys %$pi;
  197.             foreach my $opt (@mpi) {
  198.                 #print "Working with $opt\n";
  199.                 if ($opt =~ /^option/i) {
  200.                     # Call the option handling.
  201.                     $sh->install_options( @{$pi->{$opt}} );
  202.                     next;
  203.                 } elsif ( $opt =~ /^database/i ) {
  204.                     # Handle plugs for a named # type of database.
  205.                     next unless $sh->{dbh};
  206.                     # Determine what type of database connection.
  207.                     my $db = $sh->{dbh}->{Driver}->{Name};
  208.                     $sh->load_plugins( $pi->{$opt}->{$db} )
  209.                         if (exists $pi->{$opt}->{$db});
  210.                     next;
  211.                 } elsif ( $opt =~ /^non-database/i ) {
  212.                     $sh->load_plugins( $pi->{$opt} );
  213.                 } else  {
  214.                     $sh->load_plugins( $pi->{$opt} );
  215.                 }
  216.             }
  217.         } elsif ( ref $pi eq 'ARRAY' ) {
  218.             @pi = @$pi;
  219.         } else {
  220.             next unless $pi;
  221.             push(@pi, $pi);
  222.         }
  223.         foreach my $pi (@pi) {
  224.             my $mod = $pi;
  225.             $mod =~ s/\.pm$//;
  226.             #print "Module: $mod\n";
  227.             unshift @DBI::Shell::Std::ISA, $mod;
  228.             eval qq{ use $pi };
  229.             if ($@) {
  230.                 warn "Failed: $@";
  231.                 shift @DBI::Shell::Std::ISA;
  232.                 shift @pi;
  233.             } else {
  234.                 $sh->print_buffer_nop("Loaded plugins $mod\n")
  235.                     unless $sh->{batch};
  236.             }
  237.         }
  238.     }
  239.     local ($|) = 1;
  240.     # plug-ins should remove options they recognise from (localized) @ARGV
  241.     # by calling Getopt::Long::GetOptions (which is already in pass_through mode).
  242.     foreach my $pi (@pi) {
  243.     local *ARGV = $sh->{unhandled_options};
  244.         $pi->init($sh);
  245.     }
  246.     return @pi;
  247. }
  248.  
  249. sub default_config {
  250.     my $sh = shift;
  251.     #
  252.     # Set default configuration options
  253.     #
  254.     foreach my $opt_ref (
  255.      [ 'command_prefix_line=s'    => '/' ],
  256.      [ 'command_prefix_end=s'    => ';' ],
  257.      [ 'command_prefix=s'    => '[/;]' ],
  258.      [ 'chistory_size=i'    => 50 ],
  259.      [ 'rhistory_size=i'    => 50 ],
  260.      [ 'rhistory_head=i'    =>  5 ],
  261.      [ 'rhistory_tail=i'    =>  5 ],
  262.      [ 'user_level=i'        =>  1 ],
  263.      [ 'editor|ed=s'        => ($ENV{VISUAL} || $ENV{EDITOR} || 'vi') ],
  264.      [ 'batch'                => 0 ],
  265.      [ 'format=s'                => 'neat' ],
  266.      [ 'prompt=s'            => undef ],
  267.     # defaults for each new database connect:
  268.      [ 'init_trace|trace=i' => 0 ],
  269.      [ 'init_autocommit|autocommit=i' => 1 ],
  270.      [ 'debug|d=i'            => ($ENV{DBISH_DEBUG} || 0) ],
  271.      [ 'seperator|sep=s'    => ',' ],
  272.      [ 'sqlpath|sql=s'        => '.' ],
  273.      [ 'tmp_dir|tmp_d=s'    => $ENV{DBISH_TMP} ],
  274.      [ 'tmp_file|tmp_f=s'    => qq{dbish$$.sql} ],
  275.      [ 'home_dir|home_d=s'    => $ENV{HOME} || "$ENV{HOMEDRIVE}$ENV{HOMEPATH}" ],
  276.      [ 'desc_show_remarks|show_remarks' => 1 ],
  277.      [ 'desc_show_long|show_long' => 1 ],
  278.      [ 'desc_format=s'        => q{partbox} ],
  279.      [ 'desc_show_columns=s' => q{COLUMN_NAME,DATA_TYPE,TYPE_NAME,COLUMN_SIZE,PK,NULLABLE,COLUMN_DEF,IS_NULLABLE,REMARKS} ],
  280.      @_,
  281.     ) {
  282.     $sh->add_option(@$opt_ref);
  283.     }
  284.  
  285. }
  286.     
  287.  
  288. sub default_commands {
  289.     my $sh = shift;
  290.     #
  291.     # Install default commands
  292.     #
  293.     # The sub is passed a reference to the shell and the @ARGV-style
  294.     # args it was invoked with.
  295.     #
  296.     $sh->{commands} = {
  297.     'help' => {
  298.         hint => "display this list of commands",
  299.     },
  300.     'quit' => {
  301.         hint => "exit",
  302.     },
  303.     'exit' => {
  304.         hint => "exit",
  305.     },
  306.     'trace' => {
  307.         hint => "set DBI trace level for current database",
  308.     },
  309.     'connect' => {
  310.         hint => "connect to another data source/DSN",
  311.     },
  312.     'prompt' => {
  313.           hint => "change the displayed prompt",
  314.     },
  315.     # --- execute commands
  316.     'go' => {
  317.         hint => "execute the current statement",
  318.     },
  319.     'count' => {
  320.         hint => "execute 'select count(*) from table' (on each table listed).",
  321.     },
  322.     'do' => {
  323.         hint => "execute the current (non-select) statement",
  324.     },
  325.     'perl' => {
  326.         hint => "evaluate the current statement as perl code",
  327.     },
  328.     'ping' => {
  329.         hint => "ping the current connection",
  330.     },
  331.     'commit' => {
  332.         hint => "commit changes to the database",
  333.     },
  334.     'rollback' => {
  335.         hint => "rollback changes to the database",
  336.     },
  337.     # --- information commands
  338.     'primary_key_info' => {
  339.         hint => "display primary keys that exist in current database",
  340.     },
  341.     'col_info' => {
  342.         hint => "display columns that exist in current database",
  343.     },
  344.     'table_info' => {
  345.         hint => "display tables that exist in current database",
  346.     },
  347.     'type_info' => {
  348.         hint => "display data types supported by current server",
  349.     },
  350.     'drivers' => {
  351.         hint => "display available DBI drivers",
  352.     },
  353.  
  354.     # --- statement/history management commands
  355.     'clear' => {
  356.         hint => "erase the current statement",
  357.     },
  358.     'redo' => {
  359.         hint => "re-execute the previously executed statement",
  360.     },
  361.     'get' => {
  362.         hint => "make a previous statement current again",
  363.     },
  364.     'current' => {
  365.         hint => "display current statement",
  366.     },
  367.     'edit' => {
  368.         hint => "edit current statement in an external editor",
  369.     },
  370.     'chistory' => {
  371.         hint => "display command history",
  372.     },
  373.     'rhistory' => {
  374.         hint => "display result history",
  375.     },
  376.     'format' => {
  377.         hint => "set display format for selected data (Neat|Box)",
  378.     },
  379.     'history' => {
  380.         hint => "display combined command and result history",
  381.     },
  382.     'option' => {
  383.         hint => "display or set an option value",
  384.     },
  385.     'describe' => {
  386.         hint => "display information about a table (columns, data types).",
  387.     },
  388.     'load' => {
  389.         hint => "load a file from disk to the current buffer.",
  390.     },
  391.     'run' => {
  392.         hint => "load a file from disk to current buffer, then executes.",
  393.     },
  394.     'save' => {
  395.         hint => "save the current buffer to a disk file.",
  396.     },
  397.     'spool' => {
  398.         hint => "send all output to a disk file. usage: spool file name or spool off.",
  399.     },
  400.  
  401.     };
  402.  
  403. }
  404.  
  405. sub default_term {
  406.     my ($sh, $class) = @_;
  407.     #
  408.     # Setup Term
  409.     #
  410.     my $mode;
  411.     if ($sh->{batch} || ! -t STDIN) {
  412.         $sh->{batch} = 1;
  413.         $mode = "in batch mode";
  414.     } else {
  415.         $sh->{term} = new Term::ReadLine($class);
  416.         $mode = "";
  417.     }
  418.  
  419.     return( $mode );
  420. }
  421.  
  422. sub new {
  423.     my ($class, @args) = @_;
  424.  
  425.     my $sh = bless {}, $class;
  426.     
  427.     $sh->default_config;
  428.     $sh->default_commands;
  429.  
  430.     #
  431.     # Handle command line parameters
  432.     #
  433.     # data_source and user command line parameters overrides both 
  434.     # environment and config settings.
  435.     #
  436.  
  437.     $DB::single = 1;
  438.  
  439.     local (@ARGV) = @args;
  440.     my @options = values %{ $sh->{options} };
  441.     Getopt::Long::config('pass_through');    # for plug-ins
  442.     unless (GetOptions($sh, 'help|h', @options)) {
  443.         $class->usage;
  444.         croak "DBI::Shell aborted.\n";
  445.     }
  446.     if ($sh->{help}) {
  447.         $class->usage;
  448.         return;
  449.     }
  450.  
  451.     $sh->{unhandled_options} = [];
  452.     @args = ();
  453.     foreach my $arg (@ARGV) {
  454.         if ($arg =~ /^-/) {    # expected to be in "--opt=value" format
  455.             push @{$sh->{unhandled_options}}, $arg;
  456.         }
  457.         else {
  458.             push @args, $arg;
  459.         }
  460.     }
  461.  
  462.     $sh->do_format($sh->{format});
  463.  
  464.     $sh->{data_source}    = shift(@args) || $ENV{DBI_DSN}  || '';
  465.     $sh->{user}            = shift(@args) || $ENV{DBI_USER} || '';
  466.     $sh->{password}        = shift(@args) || $ENV{DBI_PASS} || undef;
  467.  
  468.     $sh->{chistory} = [];    # command history
  469.     $sh->{rhistory} = [];    # result  history
  470.     $sh->{prompt}   = $sh->{data_source};
  471.  
  472. # set the default io handle.
  473.     $sh->{out_fh}        = \*STDOUT;
  474.  
  475. # support for spool command ...
  476.     $sh->{spooling} = 0; $sh->{spool_file} = undef; $sh->{spool_fh} = undef;
  477.  
  478.     my $mode = $sh->default_term($class);
  479.  
  480.     $sh->log("DBI::Shell $DBI::Shell::VERSION using DBI $DBI::VERSION $mode");
  481.     $sh->log("DBI::Shell loaded from $INC{'DBI/Shell.pm'}") if $sh->{debug};
  482.  
  483.     return $sh;
  484. }
  485.  
  486. # Used to install, configure, or change an option or command.
  487. sub install_options {
  488.     my ($sh, $options) = @_;
  489.  
  490.     my @po;
  491.     $sh->log( "reference type: " . ref $options )
  492.         if $sh->{debug};
  493.  
  494.     if ( ref $options eq 'ARRAY' ) {
  495.  
  496.         foreach my $opt_ref ( @$options )
  497.         #[ 'debug|d=i'        => ($ENV{DBISH_DEBUG} || 0) ],
  498.         #[ 'seperator|sep=s'        => ',' ],) 
  499.         {
  500.             if ( ref $opt_ref eq 'ARRAY' ) {
  501.                 $sh->install_options( $opt_ref );
  502.             } else {
  503.                 push( @po, $opt_ref );
  504.             }
  505.         }
  506.     } elsif ( ref $options eq 'HASH' ) {
  507.         foreach (keys %{$options}) {
  508.             push(@po, $_, $options->{$_});
  509.         }
  510.     } elsif ( ref $options eq 'SCALAR' ) {
  511.         push( @po, $$options );
  512.     } else {
  513.         return unless $options;
  514.         push( @po, $options );
  515.     }
  516.  
  517.     return unless @po;
  518.  
  519.     eval{ $sh->add_option(@po) };
  520.     # Option exists, just change it.
  521.     if ($@ =~ /add_option/) {
  522.         $sh->do_option( join( '=',@po ) );
  523.     } else {
  524.         croak "configuration: $@\n" if $@;
  525.     }
  526. }
  527.  
  528. sub configuration {
  529.     my $sh = shift;
  530.  
  531.     # Source config file which may override the defaults.
  532.     # Default is $ENV{HOME}/.dbish_config.
  533.     # Can be overridden with $ENV{DBISH_CONFIG}.
  534.     # Make $ENV{DBISH_CONFIG} empty to prevent sourcing config file.
  535.     # XXX all this will change
  536.     my $homedir = $ENV{HOME}                # unix
  537.         || "$ENV{HOMEDRIVE}$ENV{HOMEPATH}";    # NT
  538.     $sh->{config_file} = $ENV{DBISH_CONFIG} || "$homedir/.dbish_config";
  539.     my $config;
  540.     if ($sh->{config_file} && -f $sh->{config_file}) {
  541.         $config = require $sh->{config_file};
  542.         # allow for custom configuration options.
  543.         if (exists $config->{'options'} ) {
  544.             $sh->install_options( $config->{'options'} );
  545.         }
  546.     }
  547.     return $config;
  548. }
  549.  
  550.  
  551. sub run {
  552.     my $sh = shift;
  553.  
  554.     my $current_line = '';
  555.  
  556.     while (1) {
  557.     my $prefix = $sh->{command_prefix};
  558.  
  559.     $current_line = $sh->readline($sh->prompt());
  560.     $current_line = "/quit" unless defined $current_line;
  561.  
  562.     my $copy_cline = $current_line; my $eat_line = 0;
  563.     # move past command prefix contained within quotes
  564.     while( $copy_cline =~ s/(['"][^'"]*(?:$prefix).*?['"])//og ) {
  565.         $eat_line = $+[0];
  566.     }
  567.  
  568.     # What's left to check?
  569.     my $line;
  570.     if ($eat_line > 0) {
  571.         $sh->{current_buffer} .= substr( $current_line, 0, $eat_line ) . "\n";
  572.         $current_line = substr( $current_line, $eat_line )
  573.             if (length($current_line) >= $eat_line );
  574.     } else {
  575.         $current_line = $copy_cline;
  576.     }
  577.  
  578.  
  579.     if ( 
  580.         $current_line =~ m/
  581.             ^(.*?)
  582.             (?<!\\)
  583.             $prefix
  584.             (?:(\w*)
  585.             ([^\|><]*))?
  586.             ((?:\||>>?|<<?).+)?
  587.             $
  588.     /x) {
  589.         my ($stmt, $cmd, $args_string, $output) = ($1, $2, $3, $4||''); 
  590.  
  591.         # print "$stmt -- $cmd -- $args_string -- $output\n";
  592.         # $sh->{current_buffer} .= "$stmt\n" if length $stmt;
  593.         if (length $stmt) {
  594.             $stmt =~ s/\\$prefix/$prefix/g;
  595.             $sh->{current_buffer} .= "$stmt\n";
  596.             if ($sh->is_spooling) { print ${$sh->{spool_fh}} ($stmt, "\n\n") }
  597.         }
  598.  
  599.         $cmd = 'go' if $cmd eq '';
  600.         my @args = split ' ', $args_string||'';
  601.  
  602.         warn("command='$cmd' args='$args_string' output='$output'") 
  603.             if $sh->{debug};
  604.  
  605.         my $command;
  606.         if ($sh->{abbrev}) {
  607.             $command = $sh->{abbrev}->{$cmd};
  608.         }
  609.         else {
  610.             $command = ($sh->{command}->{$cmd}) ? $cmd : undef;
  611.         }
  612.         if ($command) {
  613.             $sh->run_command($command, $output, @args);
  614.         }
  615.         else {
  616.         if ($sh->{batch}) {
  617.             die "Command '$cmd' not recognised";
  618.         }
  619.         $sh->alert("Command '$cmd' not recognised ",
  620.             "(enter ${prefix}help for help).");
  621.         }
  622.  
  623.     }
  624.     elsif ($current_line ne "") {
  625.         if ($sh->is_spooling) { print ${$sh->{spool_fh}} ($current_line, "\n") }
  626.         $sh->{current_buffer} .= $current_line . "\n";
  627.         # print whole buffer here so user can see it as
  628.         # it grows (and new users might guess that unrecognised
  629.         # inputs are treated as commands)
  630.         unless ($sh->{user_level}) {
  631.             $sh->run_command('current', undef,
  632.                 "(enter '$prefix' to execute or '${prefix}help' for help)");
  633.         }
  634.     }
  635.     }
  636. }
  637.     
  638.  
  639. #
  640. # Internal methods
  641. #
  642.  
  643. sub readline {
  644.     my ($sh, $prompt) = @_;
  645.     my $rv;
  646.     if ($sh->{term}) {
  647.         $rv = $sh->{term}->readline($prompt);
  648.     }
  649.     else {
  650.         chomp($rv = <STDIN>);
  651.     }
  652.  
  653.     return $rv;
  654. }
  655.  
  656.  
  657. sub run_command {
  658.     my ($sh, $command, $output, @args) = @_;
  659.     return unless $command;
  660.     local(*STDOUT) if $output;
  661.     local(*OUTPUT) if $output;
  662.     if ($output) {
  663.         if (open(OUTPUT, $output)) {
  664.             *STDOUT = *OUTPUT;
  665.         } else {
  666.             $sh->err("Couldn't open output '$output': $!");
  667.             $sh->run_command('current', undef, '');
  668.         }
  669.     }
  670.     eval {
  671.         my $code = "do_$command";
  672.         $sh->$code(@args);
  673.     };
  674.     close OUTPUT if $output;
  675.     $sh->err("$command failed: $@") if $@;    
  676. return;
  677. }
  678.  
  679.  
  680. sub print_list {
  681.     my ($sh, $list_ref) = @_;
  682.     for(my $i = 0; $i < @$list_ref; $i++) {
  683.         print ${$sh->{out_fh}} ($i+1,":  $$list_ref[$i]\n");
  684.     }
  685. return;
  686. }
  687.  
  688.  
  689. #-------------------------------------------------------------------
  690. #
  691. # Print Buffer adding a prompt.
  692. #
  693. #-------------------------------------------------------------------
  694. sub print_buffer {
  695.     my $sh = shift;
  696.     {
  697.         local ($,) = q{ };
  698.         my @out = @_;
  699.         chomp $out[-1];            # Remove any added newline.
  700.         return print ($sh->prompt(), @out,"\n");
  701.     }
  702. }
  703.  
  704. #-------------------------------------------------------------------
  705. #
  706. # Print Buffer without adding a prompt.
  707. #
  708. #-------------------------------------------------------------------
  709. sub print_buffer_nop {
  710.     my $sh = shift;
  711.     {
  712.         local ($,) = q{ };
  713.         my @out = @_;
  714.         chomp $out[-1];            # Remove any added newline.
  715.         return print  (@out,"\n");
  716.     }
  717. }
  718.  
  719. sub get_data_source {
  720.     my ($sh, $dsn, @args) = @_;
  721.     my $driver;
  722.  
  723.     if ($dsn) {
  724.         if ($dsn =~ m/^dbi:.*:/i) {    # has second colon
  725.             return $dsn;        # assumed to be full DSN
  726.         }
  727.         elsif ($dsn =~ m/^dbi:([^:]*)/i) {
  728.             $driver = $1        # use DriverName part
  729.         }
  730.         else {
  731.             $sh->print_buffer_nop ("Ignored unrecognised DBI DSN '$dsn'.\n");
  732.         }
  733.     }
  734.  
  735.     if ($sh->{batch}) {
  736.         die "Missing or unrecognised DBI DSN.";
  737.     }
  738.  
  739.     $sh->print_buffer_nop("\n");
  740.  
  741.     while (!$driver) {
  742.         $sh->print_buffer_nop("Available DBI drivers:\n");
  743.         my @drivers = DBI->available_drivers;
  744.         for( my $cnt = 0; $cnt <= $#drivers; $cnt++ ) {
  745.             $sh->print_buffer_nop(sprintf ("%2d: dbi:%s\n", $cnt+1, $drivers[$cnt]));
  746.         } 
  747.         $driver = $sh->readline(
  748.             "Enter driver name or number, or full 'dbi:...:...' DSN: ");
  749.         exit unless defined $driver;    # detect ^D / EOF
  750.         $sh->print_buffer_nop("\n");
  751.  
  752.         return $driver if $driver =~ /^dbi:.*:/i; # second colon entered
  753.  
  754.         if ( $driver =~ /^\s*(\d+)/ ) {
  755.             $driver = $drivers[$1-1];
  756.         } else {
  757.             $driver = $1;
  758.             $driver =~ s/^dbi://i if $driver # incase they entered 'dbi:Name'
  759.         }
  760.         # XXX try to install $driver (if true)
  761.         # unset $driver if install fails.
  762.     }
  763.  
  764.     my $source;
  765.     while (!defined $source) {
  766.     my $prompt;
  767.     my @data_sources = DBI->data_sources($driver);
  768.     if (@data_sources) {
  769.         $sh->print_buffer_nop("Enter data source to connect to: \n");
  770.         for( my $cnt = 0; $cnt <= $#data_sources; $cnt++ ) {
  771.         $sh->print_buffer_nop(sprintf ("%2d: %s\n", $cnt+1, $data_sources[$cnt]));
  772.         } 
  773.         $prompt = "Enter data source or number,";
  774.     }
  775.     else {
  776.         $sh->print_buffer_nop ("(The data_sources method returned nothing.)\n");
  777.         $prompt = "Enter data source";
  778.     }
  779.     $source = $sh->readline(
  780.         "$prompt or full 'dbi:...:...' DSN: ");
  781.     return if !defined $source;    # detect ^D / EOF
  782.     if ($source =~ /^\s*(\d+)/) {
  783.         $source = $data_sources[$1-1]
  784.     }
  785.     elsif ($source =~ /^dbi:([^:]+)$/) { # no second colon
  786.         $driver = $1;             # possibly new driver
  787.         $source = undef;
  788.     }
  789.         $sh->print_buffer_nop("\n");
  790.     }
  791.  
  792.     return $source;
  793. }
  794.  
  795.  
  796. sub prompt_for_password {
  797.     my ($sh) = @_;
  798.  
  799.     # no prompts in batch mode.
  800.  
  801.     return if ($sh->{batch});
  802.  
  803.     if (!defined($haveTermReadKey)) {
  804.         $haveTermReadKey = eval { require Term::ReadKey } ? 1 : 0;
  805.     }
  806.     local $| = 1;
  807.     $sh->print_buffer_nop ("Password for $sh->{user} (",
  808.     ($haveTermReadKey ? "not " : "Warning: "),
  809.     "echoed to screen): ");
  810.     if ($haveTermReadKey) {
  811.         Term::ReadKey::ReadMode('noecho');
  812.         $sh->{password} = Term::ReadKey::ReadLine(0);
  813.         Term::ReadKey::ReadMode('restore');
  814.     } else {
  815.         $sh->{password} = <STDIN>;
  816.     }
  817.     chomp $sh->{password};
  818.     $sh->print_buffer_nop ("\n");
  819. }
  820.  
  821. sub prompt {
  822.     my ($sh) = @_;
  823.     return "" if $sh->{batch};
  824.     return "(not connected)> " unless $sh->{dbh};
  825.  
  826.     if ( ref $sh->{prompt} ) {
  827.         foreach (@{$sh->{prompt}} ) {
  828.             if ( ref $_ eq "CODE" ) {
  829.                 $sh->{prompt} .= &$_;
  830.             } else {
  831.                 $sh->{prompt} .= $_;
  832.             }
  833.         }
  834.         return "$sh->{user}\@$sh->{prompt}> ";
  835.     } else {
  836.         return "$sh->{user}\@$sh->{prompt}> ";
  837.     }
  838. return;
  839. }
  840.  
  841.  
  842. sub push_chistory {
  843.     my ($sh, $cmd) = @_;
  844.     $cmd = $sh->{current_buffer} unless defined $cmd;
  845.     $sh->{prev_buffer} = $cmd;
  846.     my $chist = $sh->{chistory};
  847.     shift @$chist if @$chist >= $sh->{chistory_size};
  848.     push @$chist, $cmd;
  849. return;
  850. }
  851.  
  852.  
  853. #
  854. # Command methods
  855. #
  856.  
  857. sub do_help {
  858.     my ($sh, @args) = @_;
  859.  
  860.     return "" if $sh->{batch};
  861.  
  862.     my $prefix = $sh->{command_prefix};
  863.     my $commands = $sh->{commands};
  864.     $sh->print_buffer_nop ("Defined commands, in alphabetical order:\n");
  865.     foreach my $cmd (sort keys %$commands) {
  866.     my $hint = $commands->{$cmd}->{hint} || '';
  867.     $sh->print_buffer_nop(sprintf ("  %s%-10s %s\n", $prefix, $cmd, $hint));
  868.     }
  869.     $sh->print_buffer_nop ("Commands can be abbreviated.\n") if $sh->{abbrev};
  870. return;
  871. }
  872.  
  873.  
  874. sub do_format {
  875.     my ($sh, @args) = @_;
  876.     my $mode = $args[0] || '';
  877.     my $class = eval { DBI::Format->formatter($mode,1) };
  878.     unless ($class) {
  879.         return $sh->alert("Unable to select '$mode': $@");
  880.     }
  881.     $sh->log("Using formatter class '$class'") if $sh->{debug};
  882.     $sh->{format} = $mode;
  883.     return $sh->{display} = $class->new($sh);
  884. }
  885.  
  886.  
  887. sub do_go {
  888.     my ($sh, @args) = @_;
  889.  
  890.     # print "do_go\n";
  891.  
  892.     # Modify go to get the last executed statement if called on an
  893.     # empty buffer.
  894.  
  895.     if ($sh->{current_buffer} eq '') {
  896.         $sh->do_get;
  897.         return if $sh->{current_buffer} eq '';
  898.     }
  899.  
  900.     $sh->{prev_buffer} = $sh->{current_buffer};
  901.  
  902.     $sh->push_chistory;
  903.     
  904.     eval {
  905.         # Determine if the single quotes are out of balance.
  906.         my $count = ($sh->{current_buffer} =~ tr/'/'/);
  907.         warn "Quotes out of balance: $count" unless (($count % 2) == 0);
  908.  
  909.         my $sth = $sh->{dbh}->prepare($sh->{current_buffer});
  910.  
  911.         $sh->sth_go($sth, 1);
  912.     };
  913.     if ($@) {
  914.         my $err = $@;
  915.         $err =~ s: at \S*DBI/Shell.pm line \d+(,.*?chunk \d+)?::
  916.             if !$sh->{debug} && $err =~ /^DBD::\w+::\w+ \w+/;
  917.         print STDERR "$err";
  918.     }
  919.     # There need to be a better way, maybe clearing the
  920.     # buffer when the next non command is typed.
  921.     # Or sprinkle <$sh->{current_buffer} ||= $sh->{prev_buffer};>
  922.     # around in the code.
  923. return $sh->{current_buffer} = '';
  924. }
  925.  
  926.  
  927. sub sth_go {
  928.     my ($sh, $sth, $execute, $rh) = @_;
  929.  
  930.     $rh = 1 unless defined $rh;  # Add to results history.  Default 1, Yes.
  931.     my $rv;
  932.     if ($execute || !$sth->{Active}) {
  933.     my @params;
  934.     my $params = $sth->{NUM_OF_PARAMS} || 0;
  935.     $sh->print_buffer_nop("Statement has $params parameters:\n") if $params;
  936.     foreach(1..$params) {
  937.         my $val = $sh->readline("Parameter $_ value: ");
  938.         push @params, $val;
  939.     }
  940.     $rv = $sth->execute(@params);
  941.     }
  942.     
  943.     if (!$sth->{'NUM_OF_FIELDS'}) { # not a select statement
  944.         local $^W=0;
  945.         $rv = "undefined number of" unless defined $rv;
  946.         $rv = "unknown number of"   if $rv == -1;
  947.         $sh->print_buffer_nop ("[$rv row" . ($rv==1 ? "" : "s") . " affected]\n");
  948.         return;
  949.     }
  950.  
  951.     $sh->{sth} = $sth;
  952.  
  953.     #
  954.     # Remove oldest result from history if reached limit
  955.     #
  956.     my $rhist = $sh->{rhistory};
  957.     if ($rh) {
  958.         shift @$rhist if @$rhist >= $sh->{rhistory_size};
  959.         push @$rhist, [];
  960.     }
  961.  
  962.     #
  963.     # Keep a buffer of $sh->{rhistory_tail} many rows,
  964.     # when done with result add those to rhistory buffer.
  965.     # Could use $sth->rows(), but not all DBD's support it.
  966.     #
  967.     my @rtail;
  968.     my $i = 0;
  969.     my $display = $sh->{display} || die "panic: no display set";
  970.     $display->header($sth, $sh->{out_fh}||\*STDOUT, $sh->{seperator});
  971.  
  972.     OUT_ROWS:
  973.     while (my $rowref = $sth->fetchrow_arrayref()) {
  974.         $i++;
  975.  
  976.         my $rslt = $display->row($rowref);
  977.  
  978.         if($rh) {
  979.             if ($i <= $sh->{rhistory_head}) {
  980.                 push @{$rhist->[-1]}, [@$rowref];
  981.             }
  982.             else {
  983.                 shift @rtail if @rtail == $sh->{rhistory_tail};
  984.                 push @rtail, [@$rowref];
  985.             }
  986.         }
  987.  
  988.         unless(defined $rslt) {
  989.             $sh->print_buffer_nop( "row limit reached" );
  990.             last OUT_ROWS;
  991.         }
  992.     }
  993.  
  994.     $display->trailer($i);
  995.  
  996.     if($rh) {
  997.         if (@rtail) {
  998.             my $rows = $i;
  999.             my $ommitted = $i - $sh->{rhistory_head} - @rtail;
  1000. # Only include the omitted message if results are omitted.
  1001.             if ($ommitted) {
  1002.                 push(@{$rhist->[-1]},
  1003.                      [ "[...$ommitted rows out of $rows ommitted...]"]);
  1004.             }
  1005.             foreach my $rowref (@rtail) {
  1006.                 push @{$rhist->[-1]}, $rowref;
  1007.             }
  1008.         }
  1009.     }
  1010.  
  1011. return;
  1012. }
  1013.  
  1014. #------------------------------------------------------------------
  1015. #
  1016. # Generate a select count(*) from table for each table in list.
  1017. #
  1018. #------------------------------------------------------------------
  1019.  
  1020. sub do_count {
  1021.     my ($sh, @args) = @_;
  1022.     foreach my $tab (@args) {
  1023.         $sh->print_buffer_nop ("Counting: $tab\n");
  1024.         $sh->{current_buffer} = "select count(*) as cnt_$tab from $tab";
  1025.         $sh->do_go();
  1026.     }
  1027.     return $sh->{current_buffer} = '';
  1028. }
  1029.  
  1030. sub do_do {
  1031.     my ($sh, @args) = @_;
  1032.     $sh->push_chistory;
  1033.     my $rv = $sh->{dbh}->do($sh->{current_buffer});
  1034.     $sh->print_buffer_nop ("[$rv row" . ($rv==1 ? "" : "s") . " affected]\n")
  1035.         if defined $rv;
  1036.  
  1037.     # XXX I question setting the buffer to '' here.
  1038.     # I may want to edit my line without having to scroll back.
  1039.     return $sh->{current_buffer} = '';
  1040. }
  1041.  
  1042.  
  1043. sub do_disconnect {
  1044.     my ($sh, @args) = @_;
  1045.     return unless $sh->{dbh};
  1046.     $sh->log("Disconnecting from $sh->{data_source}.");
  1047.     eval {
  1048.     $sh->{sth}->finish if $sh->{sth};
  1049.     $sh->{dbh}->rollback unless $sh->{dbh}->{AutoCommit};
  1050.     $sh->{dbh}->disconnect;
  1051.     };
  1052.     $sh->alert("Error during disconnect: $@") if $@;
  1053.     $sh->{sth} = undef;
  1054.     $sh->{dbh} = undef;
  1055. return;
  1056. }
  1057.  
  1058.  
  1059. sub do_connect {
  1060.     my ($sh, $dsn, $user, $pass) = @_;
  1061.  
  1062.     $dsn = $sh->get_data_source($dsn);
  1063.     return unless $dsn;
  1064.  
  1065.     $sh->do_disconnect if $sh->{dbh};
  1066.  
  1067.     # Change from Jeff Zucker, convert literal slash and letter n to newline.
  1068.     $dsn =~ s/\\n/\n/g;
  1069.     $dsn =~ s/\\t/\t/g;
  1070.  
  1071.  
  1072.     $sh->{data_source} = $dsn;
  1073.     if (defined $user and length $user) {
  1074.     $sh->{user}     = $user;
  1075.     $sh->{password} = undef;    # force prompt below
  1076.     }
  1077.  
  1078.     $sh->log("Connecting to '$sh->{data_source}' as '$sh->{user}'...");
  1079.     if ($sh->{user} and !defined $sh->{password}) {
  1080.     $sh->prompt_for_password();
  1081.     }
  1082.     $sh->{dbh} = DBI->connect(
  1083.     $sh->{data_source}, $sh->{user}, $sh->{password}, {
  1084.         AutoCommit => $sh->{init_autocommit},
  1085.         PrintError => 0,
  1086.         RaiseError => 1,
  1087.         LongTruncOk => 1,    # XXX
  1088.     });
  1089.     $sh->{dbh}->trace($sh->{init_trace}) if $sh->{init_trace};
  1090. return;
  1091. }
  1092.  
  1093.  
  1094. sub do_current {
  1095.     my ($sh, $msg, @args) = @_;
  1096.     $msg = $msg ? " $msg" : "";
  1097.     return 
  1098.         $sh->log("Current statement buffer$msg:\n" . $sh->{current_buffer});
  1099. }
  1100.  
  1101. sub do_autoflush {
  1102.  
  1103. return;
  1104. }
  1105.  
  1106. sub do_trace {
  1107.     return shift->{dbh}->trace(@_);
  1108. }
  1109.  
  1110. sub do_commit {
  1111.     return shift->{dbh}->commit(@_);
  1112. }
  1113.  
  1114. sub do_rollback {
  1115.     return shift->{dbh}->rollback(@_);
  1116. }
  1117.  
  1118.  
  1119. sub do_quit {
  1120.     my ($sh, @args) = @_;
  1121.     $sh->do_disconnect if $sh->{dbh};
  1122.     undef $sh->{term};
  1123.     exit 0;
  1124. }
  1125.  
  1126. # Until the alias command is working each command requires definition.
  1127. sub do_exit { shift->do_quit(@_); }
  1128.  
  1129. sub do_clear {
  1130.     my ($sh, @args) = @_;
  1131. return $sh->{current_buffer} = '';
  1132. }
  1133.  
  1134.  
  1135. sub do_redo {
  1136.     my ($sh, @args) = @_;
  1137.     $sh->{current_buffer} = $sh->{prev_buffer} || '';
  1138.     $sh->run_command('go') if $sh->{current_buffer};
  1139. return;
  1140. }
  1141.  
  1142.  
  1143. sub do_chistory {
  1144.     my ($sh, @args) = @_;
  1145.     return $sh->print_list($sh->{chistory});
  1146. }
  1147.  
  1148. sub do_history {
  1149.     my ($sh, @args) = @_;
  1150.     for(my $i = 0; $i < @{$sh->{chistory}}; $i++) {
  1151.         $sh->print_buffer_nop ($i+1, ":\n", $sh->{chistory}->[$i], "--------\n");
  1152.         foreach my $rowref (@{$sh->{rhistory}[$i]}) {
  1153.             $sh->print_buffer_nop("    ", join(", ", map { defined $_ ? $_ : q{undef} }@$rowref), "\n");
  1154.         }
  1155.     }
  1156. return;
  1157. }
  1158.  
  1159. sub do_rhistory {
  1160.     my ($sh, @args) = @_;
  1161.     for(my $i = 0; $i < @{$sh->{rhistory}}; $i++) {
  1162.         $sh->print_buffer_nop ($i+1, ":\n");
  1163.         foreach my $rowref (@{$sh->{rhistory}[$i]}) {
  1164.             $sh->print_buffer_nop ("    ", join(", ", map { defined $_ ? $_ : q{undef} }@$rowref), "\n");
  1165.         }
  1166.     }
  1167. return;
  1168. }
  1169.  
  1170.  
  1171. sub do_get {
  1172.     my ($sh, $num, @args) = @_;
  1173.     # If get is called without a number, retrieve the last command.
  1174.     unless( $num ) {
  1175.         $num = ($#{$sh->{chistory}} + 1);    
  1176.  
  1177.     }
  1178.     # Allow for negative history.  If called with -1, get the second
  1179.     # to last command execute, -2 third to last, ...
  1180.     if ($num and $num =~ /^\-\d+$/) {
  1181.         $sh->print_buffer_nop("Negative number $num: \n");
  1182.         $num = ($#{$sh->{chistory}} + 1) + $num;
  1183.         $sh->print_buffer_nop("Changed number $num: \n");
  1184.     }
  1185.  
  1186.     if (!$num or $num !~ /^\d+$/ or !defined($sh->{chistory}->[$num-1])) {
  1187.         return $sh->err("No such command number '$num'. Use /chistory to list previous commands.");
  1188.     }
  1189.     $sh->{current_buffer} = $sh->{chistory}->[$num-1];
  1190.     $sh->print_buffer($sh->{current_buffer});
  1191.     return $num;
  1192. }
  1193.  
  1194.  
  1195. sub do_perl {
  1196.     my ($sh, @args) = @_;
  1197.     $DBI::Shell::eval::dbh = $sh->{dbh};
  1198.     eval "package DBI::Shell::eval; $sh->{current_buffer}";
  1199.     if ($@) { $sh->err("Perl failed: $@") }
  1200.     return $sh->run_command('clear');
  1201. }
  1202.  
  1203. #-------------------------------------------------------------
  1204. # Ping the current database connection.
  1205. #-------------------------------------------------------------
  1206. sub do_ping {
  1207.     my ($sh, @args) = @_;
  1208.     return $sh->print_buffer_nop (
  1209.     "Connection "
  1210.     , $sh->{dbh}->ping() == '0' ? 'Is' : 'Is Not'
  1211.     , " alive\n" );
  1212. }
  1213.  
  1214. sub do_edit {
  1215.     my ($sh, @args) = @_;
  1216.  
  1217.     $sh->run_command('get', '', $&) if @args and $args[0] =~ /^\d+$/;
  1218.     $sh->{current_buffer} ||= $sh->{prev_buffer};
  1219.         
  1220.     # Find an area to write a temp file into.
  1221.     my $tmp_dir = $sh->{tmp_dir} ||
  1222.         $ENV{DBISH_TMP} || # Give people the choice.
  1223.         $ENV{TMP}  ||            # Is TMP set?
  1224.         $ENV{TEMP} ||            # How about TEMP?
  1225.         $ENV{HOME} ||            # Look for HOME?
  1226.         $ENV{HOMEDRIVE} . $ENV{HOMEPATH} || # Last env checked.
  1227.         ".";       # fallback: try to write in current directory.
  1228.  
  1229.     my $tmp_file = "$tmp_dir/" . ($sh->{tmp_file} || qq{dbish$$.sql});
  1230.  
  1231.     $sh->log( "using tmp file: $tmp_file" ) if $sh->{debug};
  1232.  
  1233.     local (*FH);
  1234.     open(FH, ">$tmp_file") or
  1235.         $sh->err("Can't create $tmp_file: $!\n", 1);
  1236.     print FH $sh->{current_buffer} if defined $sh->{current_buffer};
  1237.     close(FH) or $sh->err("Can't write $tmp_file: $!\n", 1);
  1238.  
  1239.     my $command = "$sh->{editor} $tmp_file";
  1240.     system($command);
  1241.  
  1242.     # Read changes back in (editor may have deleted and rewritten file)
  1243.     open(FH, "<$tmp_file") or $sh->err("Can't open $tmp_file: $!\n");
  1244.     $sh->{current_buffer} = join "", <FH>;
  1245.     close(FH) or $sh->err( "Close failed: $tmp_file: $!\n" );
  1246.     unlink $tmp_file;
  1247.  
  1248.     return $sh->run_command('current');
  1249. }
  1250.  
  1251.  
  1252. #
  1253. # Load a command/file from disk to the current buffer.  Currently this
  1254. # overwrites the current buffer with the file loaded.  This may change
  1255. # in the future.
  1256. #
  1257. sub do_load {
  1258.     my ($sh, $ufile, @args) = @_;
  1259.  
  1260.     unless( $ufile ) {
  1261.         $sh->err ( qq{load what file?} );
  1262.         return;
  1263.     }
  1264.  
  1265.     # Load file for from sqlpath.
  1266.     my $file = $sh->look_for_file($ufile);
  1267.  
  1268.     unless( $file ) {
  1269.         $sh->err( qq{Unable to locate file $ufile} );
  1270.         return;
  1271.     }
  1272.  
  1273.     unless( -f $file ) {
  1274.         $file = q{'undef'} unless $file;
  1275.         $sh->err( qq{Can't load $file: $!} );
  1276.         return;
  1277.     }
  1278.  
  1279.     $sh->log("Loading: $ufile : $file") if $sh->{debug};
  1280.     local (*FH);
  1281.     open(FH, "$file") or $sh->err("Can't open $file: $!");
  1282.     $sh->{current_buffer} = join "", <FH>;
  1283.     close(FH) or $sh->err( "close$file failed: $!" );
  1284.  
  1285.     return $sh->run_command('current');
  1286. }
  1287.  
  1288. sub do_save {
  1289.     my ($sh, $file, @args) = @_;
  1290.  
  1291.     unless( $file ) {
  1292.         $sh->err ( qq{save to what file?} );
  1293.         return;
  1294.     }
  1295.  
  1296.     $sh->log("Saving... ") if $sh->{debug};
  1297.     local (*FH);
  1298.     open(FH, "> $file") or $sh->err("Can't open $file: $!");
  1299.     print FH $sh->{current_buffer};
  1300.     close(FH) or $sh->err( "close$file failed: $!" );
  1301.  
  1302.     $sh->log(" $file") if $sh->{debug};
  1303.     return $sh->run_command('current');
  1304. }
  1305.  
  1306. #
  1307. # run: combines load and go.
  1308. #
  1309. sub do_run {
  1310.     my ($sh, $file, @args) = @_;
  1311.     return unless( ! $sh->do_load( $file ) );
  1312.     $sh->log( "running $file" ) if $sh->{debug};
  1313.     $sh->run_command('go') if $sh->{current_buffer};
  1314.     return;
  1315. }
  1316.  
  1317. sub do_drivers {
  1318.     my ($sh, @args) = @_;
  1319.     $sh->log("Available drivers:");
  1320.     my @drivers = DBI->available_drivers;
  1321.     foreach my $driver (sort @drivers) {
  1322.         $sh->log("\t$driver");
  1323.     }
  1324. return;
  1325. }
  1326.  
  1327.  
  1328. # $sth = $dbh->column_info( $catalog, $schema, $table, $column );
  1329.  
  1330. sub do_col_info {
  1331.     my ($sh, @args) = @_;
  1332.     my $dbh = $sh->{dbh};
  1333.  
  1334.     $sh->log( "col_info( " . join( " ", @args ) . ")" ) if $sh->{debug};
  1335.  
  1336.     my $sth = $dbh->column_info(@args);
  1337.     unless(ref $sth) {
  1338.         $sh->print_buffer_nop ("Driver has not implemented the column_info() method\n");
  1339.         $sth = undef;
  1340.         return;
  1341.     }
  1342. return $sh->sth_go($sth, 0, NO_RH);
  1343. }
  1344.  
  1345.  
  1346. sub do_type_info {
  1347.     my ($sh, @args) = @_;
  1348.     my $dbh = $sh->{dbh};
  1349.     my $ti = $dbh->type_info_all;
  1350.     my $ti_cols = shift @$ti;
  1351.     my @names = sort { $ti_cols->{$a} <=> $ti_cols->{$b} } keys %$ti_cols;
  1352.     my $sth = $sh->prepare_from_data("type_info", $ti, \@names);
  1353.     return $sh->sth_go($sth, 0, NO_RH);
  1354. }
  1355.  
  1356. sub do_describe {
  1357.     my ($sh, $tab, @argv) = @_;
  1358.     my $dbh = $sh->{dbh};
  1359.  
  1360. # Table to describe?
  1361.     return $sh->print_buffer_nop( "Describe what?\n" ) unless (defined $tab);
  1362.  
  1363.     # First attempt the advanced describe using column_info
  1364.     # $sth = $dbh->column_info( $catalog, $schema, $table, $column );
  1365.     #$sh->log( "col_info( " . join( " ", @args ) . ")" ) if $sh->{debug};
  1366.  
  1367. # Need to determine which columns to include with the describe command.
  1368. #    TABLE_CAT,TABLE_SCHEM,TABLE_NAME,COLUMN_NAME,
  1369. #    DATA_TYPE,TYPE_NAME,COLUMN_SIZE,BUFFER_LENGTH,
  1370. #    DECIMAL_DIGITS,NUM_PREC_RADIX,NULLABLE,
  1371. #    REMARKS,COLUMN_DEF,SQL_DATA_TYPE,
  1372. #    SQL_DATETIME_SUB,CHAR_OCTET_LENGTH,ORDINAL_POSITION,
  1373. #    IS_NULLABLE
  1374. #
  1375. # desc_format: partbox
  1376. # desc_show_long: 1
  1377. # desc_show_remarks: 1
  1378.  
  1379.     my @names = ();
  1380.  
  1381.     # Determine if the short or long display type is used
  1382.     if (exists $sh->{desc_show_long} and $sh->{desc_show_long} == 1) {
  1383.  
  1384.         if (exists $sh->{desc_show_columns} and defined
  1385.             $sh->{desc_show_columns}) {
  1386.             @names = map { defined $_ ? uc $_ : () } split( /[,\s+]/,  $sh->{desc_show_columns});
  1387.             unless (@names) { # List of columns is empty
  1388.                 $sh->err ( qq{option desc_show_columns contains an empty list, using default} );
  1389.                 # set the empty list to undef
  1390.                 $sh->{desc_show_columns} = undef;
  1391.                 @names = ();
  1392.                 push @names, qw/COLUMN_NAME DATA_TYPE TYPE_NAME COLUMN_SIZE PK
  1393.                     NULLABLE COLUMN_DEF IS_NULLABLE/;
  1394.             }
  1395.         } else {
  1396.             push @names, qw/COLUMN_NAME DATA_TYPE TYPE_NAME COLUMN_SIZE PK
  1397.                 NULLABLE COLUMN_DEF IS_NULLABLE/;
  1398.         }
  1399.     } else {
  1400.         push @names, qw/COLUMN_NAME TYPE_NAME NULLABLE PK/;
  1401.     }
  1402.  
  1403.     # my @names = qw/COLUMN_NAME DATA_TYPE NULLABLE PK/;
  1404.     push @names, q{REMARKS}
  1405.         if (exists $sh->{desc_show_remarks}
  1406.             and $sh->{desc_show_remarks} == 1
  1407.             and (not grep { m/REMARK/i } @names));
  1408.  
  1409.     my $sth = $dbh->column_info(undef, undef, $tab);
  1410.  
  1411.     if (ref $sth) {
  1412.         
  1413.         # Only attempt the primary_key lookup if using the column_info call.
  1414.  
  1415.         my @key_column_names = $dbh->primary_key( undef, undef, $tab );
  1416.         my %pk_cols;
  1417.         # Convert the column names to lower case for matching
  1418.         foreach my $idx (0 ..$#key_column_names) {
  1419.             $pk_cols{lc($key_column_names[$idx])} = $idx;
  1420.         }
  1421.  
  1422.         my @t_data = ();  # An array of arrays
  1423.             
  1424.         while (my $row = $sth->fetchrow_hashref() ) {
  1425.  
  1426.             my $col_name    = $row->{COLUMN_NAME};
  1427.             my $col_name_lc    = lc $col_name;
  1428.  
  1429.             # Use the Type name, unless undefined, they use the data type
  1430.             # value.  TODO: Change to resolve the data_type to an ANSI data
  1431.             # type ... SQL_
  1432.             my $type = $row->{TYPE_NAME} || $row->{DATA_TYPE};
  1433.  
  1434.             if (defined $row->{COLUMN_SIZE}) {
  1435.                 $type .= "(" . $row->{COLUMN_SIZE} . ")";
  1436.             }
  1437.             my $is_pk = $pk_cols{$col_name_lc} if exists $pk_cols{$col_name_lc};
  1438.  
  1439.             my @out_row;
  1440.             foreach my $dcol (@names) {
  1441.  
  1442.                 # Add primary key
  1443.                 if ($dcol eq q{PK}) {
  1444.                     push @out_row, defined $is_pk  ? $is_pk : q{};
  1445.                     next;
  1446.                 }
  1447.                 if ($dcol eq q{TYPE_NAME} and
  1448.                     (exists $sh->{desc_show_long} and $sh->{desc_show_long} == 0)) {
  1449.                         my $type = $row->{TYPE_NAME} || $row->{DATA_TYPE};
  1450.                         if (defined $row->{COLUMN_SIZE}) {
  1451.                             $type .= "(" . $row->{COLUMN_SIZE} . ")";
  1452.                         }
  1453.                     push @out_row, $type;
  1454.                     next;
  1455.                 }
  1456.  
  1457.                 # Put a blank if not defined.
  1458.                 push @out_row, defined $row->{$dcol} ? $row->{$dcol} :  q{};
  1459.  
  1460.                 # push(my @out_row
  1461.                 # , $col_name
  1462.                 # , $type
  1463.                 # , sprintf( "%4s", ($row->{NULLABLE} eq 0 ? q{N}: q{Y}))
  1464.                 # );
  1465.  
  1466.                 # push @out_row, defined $row->{REMARKS} ? $row->{REMARKS} :  q{}
  1467.                 #     if (exists $sh->{desc_show_remarks}
  1468.                 #     and $sh->{desc_show_remarks} == 1);
  1469.             }
  1470.  
  1471.             push @t_data, \@out_row;
  1472.         }
  1473.  
  1474.         $sth->finish; # Complete the handler from column_info
  1475.  
  1476.  
  1477.         # Create a new statement handler from the data and names.
  1478.         $sth = $sh->prepare_from_data("describe", \@t_data, \@names);
  1479.  
  1480.         # Use the built in formatter to handle data.
  1481.  
  1482.         my $mode = exists $sh->{desc_format} ? $sh->{desc_format} : 'partbox';
  1483.         my $class = eval { DBI::Format->formatter($mode,1) };
  1484.         unless ($class) {
  1485.             return $sh->alert("Unable to select '$mode': $@");
  1486.         }
  1487.  
  1488.         my $display = $class->new($sh);
  1489.  
  1490.         $display->header($sth, $sh->{out_fh}||\*STDOUT, $sh->{seperator});
  1491.  
  1492.         my $i = 0;
  1493.         OUT_ROWS:
  1494.         while (my $rowref = $sth->fetchrow_arrayref()) {
  1495.             $i++;
  1496.             my $rslt = $display->row($rowref);
  1497.         }
  1498.  
  1499.         return $display->trailer($i);
  1500.  
  1501.     }
  1502.  
  1503.     #
  1504.     # This is the old method, if the driver doesn't support the DBI column_info
  1505.     # meta data.
  1506.     #
  1507.     my $sql = qq{select * from $tab where 1 = 0};
  1508.     $sth = $dbh->prepare( $sql );
  1509.     $sth->execute;
  1510.     my $cnt = $#{$sth->{NAME}};  #
  1511.     @names = qw{NAME TYPE NULLABLE};
  1512.     my @ti;
  1513.     for ( my $c = 0; $c <= $cnt; $c++ ) {
  1514.         push( my @j, $sth->{NAME}->[$c] || 0 );
  1515.         my $m = $dbh->type_info($sth->{TYPE}->[$c]);
  1516.         my $s;
  1517.         #print "desc: $c ", $sth->{NAME}->[$c], " ",
  1518.             #$sth->{TYPE}->[$c], "\n";
  1519.         if (ref $m eq 'HASH') {
  1520.             $s = $m->{TYPE_NAME}; #  . q{ } . $sth->{TYPE}->[$c];
  1521.         } elsif (not defined $m) {
  1522.              # $s = q{undef } . $sth->{TYPE}->[$c];
  1523.              $s = $sth->{TYPE}->[$c];
  1524.         } else {
  1525.             warn "describe:  not good.  Not good at all!";
  1526.         }
  1527.  
  1528.         if (defined $sth->{PRECISION}->[$c]) {
  1529.             $s .= "(" . $sth->{PRECISION}->[$c] || '';
  1530.             $s .= "," . $sth->{SCALE}->[$c] 
  1531.             if ( defined $sth->{SCALE}->[$c] 
  1532.                 and $sth->{SCALE}->[$c] ne 0);
  1533.             $s .= ")";
  1534.         }
  1535.         push(@j, $s,
  1536.              $sth->{NULLABLE}->[$c] ne 1? qq{N}: qq{Y} );
  1537.         push(@ti,\@j);
  1538.     }
  1539.  
  1540.     $sth->finish;
  1541.     $sth = $sh->prepare_from_data("describe", \@ti, \@names);
  1542.     return $sh->sth_go($sth, 0, NO_RH);
  1543. }
  1544.  
  1545.  
  1546. sub prepare_from_data {
  1547.     my ($sh, $statement, $data, $names, %attr) = @_;
  1548.     my $sponge = DBI->connect("dbi:Sponge:","","",{ RaiseError => 1 });
  1549.     my $sth = $sponge->prepare($statement, { rows=>$data, NAME=>$names, %attr });
  1550.     return $sth;
  1551. }
  1552.  
  1553.  
  1554. # Do option: sets or gets an option
  1555. sub do_option {
  1556.     my ($sh, @args) = @_;
  1557.  
  1558.     my $value;
  1559.     unless (@args) {
  1560.         foreach my $opt (sort keys %{ $sh->{options}}) {
  1561.             $value = (defined $sh->{$opt}) ? $sh->{$opt} : 'undef';
  1562.             $sh->log(sprintf("%20s: %s", $opt, $value));
  1563.         }
  1564.         return;
  1565.     }
  1566.  
  1567.     my $options = Text::Abbrev::abbrev(keys %{$sh->{options}});
  1568.  
  1569.     # Expecting the form [option=value] [option=] [option]
  1570.     foreach my $opt (@args) {
  1571.         my ($opt_name);
  1572.         ($opt_name, $value) = $opt =~ /^\s*(\w+)(?:=(.*))?/;
  1573.         $opt_name = $options->{$opt_name} || $opt_name if $opt_name;
  1574.         if (!$opt_name || !$sh->{options}->{$opt_name}) {
  1575.             $sh->log("Unknown or ambiguous option name '$opt_name'");
  1576.             next;
  1577.         }
  1578.         my $crnt = (defined $sh->{$opt_name}) ? $sh->{$opt_name} : 'undef';
  1579.         if (not defined $value) {
  1580.             $sh->log("/option $opt_name=$crnt");
  1581.             $value = $crnt;
  1582.         }
  1583.         else {
  1584.             # Need to deal with quoted strings.
  1585.             # 1 while ( $value =~ s/[^\\]?["']//g );  #"'
  1586.             $sh->log("/option $opt_name=$value  (was $crnt)")
  1587.                 unless $sh->{batch};
  1588.             $sh->{$opt_name} = ($value eq 'undef' ) ? undef : $value;
  1589.         }
  1590.     }
  1591. return (defined $value ? $value : undef);
  1592. }
  1593.  
  1594. #
  1595. # Do prompt: sets or gets a prompt
  1596. #
  1597. sub do_prompt {
  1598.     my ($sh, @args) = @_;
  1599.  
  1600.     return $sh->log( $sh->{prompt} ) unless (@args);
  1601. return $sh->{prompt} = join( '', @args );
  1602. }
  1603.  
  1604.  
  1605. sub do_table_info {
  1606.     my ($sh, @args) = @_;
  1607.     my $dbh = $sh->{dbh};
  1608.     my $sth = $dbh->table_info(@args);
  1609.     unless(ref $sth) {
  1610.     $sh->log("Driver has not implemented the table_info() method, ",
  1611.         "trying tables()\n");
  1612.     my @tables = $dbh->tables(@args); # else try list context
  1613.     unless (@tables) {
  1614.         $sh->print_buffer_nop ("No tables exist ",
  1615.           "(or driver hasn't implemented the tables method)\n");
  1616.         return;
  1617.     }
  1618.     $sth = $sh->prepare_from_data("tables",
  1619.         [ map { [ $_ ] } @tables ],
  1620.         [ "TABLE_NAME" ]
  1621.     );
  1622.     }
  1623. return $sh->sth_go($sth, 0, NO_RH);
  1624. }
  1625.  
  1626. # Support functions.
  1627. sub is_spooling    ( ) { return shift->{spooling}        }
  1628. sub spool_on    ( ) { return shift->{spooling} = 1    }
  1629. sub spool_off    ( ) { return shift->{spooling} = 0    }
  1630.  
  1631. 1;
  1632. __END__
  1633.  
  1634. =head1 TO DO
  1635.  
  1636. Proper docs - but not yet, too much is changing.
  1637.  
  1638. "source file" command to read command file.
  1639. Allow to nest via stack of command file handles.
  1640. Add command log facility to create batch files.
  1641.  
  1642. Commands:
  1643.  
  1644. Use Data::ShowTable if available.
  1645.  
  1646. Define DBI::Shell plug-in semantics.
  1647.     Implement import/export as plug-in module
  1648.  
  1649. Clarify meaning of batch mode
  1650.  
  1651. Completion hooks
  1652.  
  1653. Set/Get DBI handle attributes
  1654.  
  1655. Portability
  1656.  
  1657. Emulate popular command shell modes (Oracle, Ingres etc)?
  1658.  
  1659. =head1 ARGUMENTS
  1660.  
  1661. =over 4
  1662.  
  1663. =item debug
  1664.  
  1665. dbish --debug    enable debug messages
  1666.  
  1667. =item batch
  1668.  
  1669. dbish --batch < batch_file
  1670.  
  1671. =back
  1672.  
  1673. =head1 COMMANDS
  1674.  
  1675. Many commands - few documented, yet!
  1676.  
  1677. =over 4
  1678.  
  1679. =item help
  1680.  
  1681.   help
  1682.  
  1683. =item chistory
  1684.  
  1685.   chistory          (display history of all commands entered)
  1686.   chistory | YourPager (display history with paging)
  1687.  
  1688. =item clear
  1689.  
  1690.   clear             (Clears the current command buffer)
  1691.  
  1692. =item commit
  1693.  
  1694.   commit            (commit changes to the database)
  1695.  
  1696. =item connect
  1697.  
  1698.   connect           (pick from available drivers and sources)
  1699.   connect dbi:Oracle (pick source from based on driver)
  1700.   connect dbi:YourDriver:YourSource i.e. dbi:Oracle:mysid
  1701.  
  1702. Use this option to change userid or password.
  1703.  
  1704. =item count
  1705.  
  1706.     count table1 [...]
  1707.  
  1708. Run a select count(*) from table on each table listed with this command.
  1709.  
  1710. =item current
  1711.  
  1712.   current            (Display current statement in the buffer)
  1713.  
  1714. =item do
  1715.  
  1716.   do                 (execute the current (non-select) statement)
  1717.  
  1718.     dbish> create table foo ( mykey integer )
  1719.     dbish> /do
  1720.  
  1721.     dbish> truncate table OldTable /do (Oracle truncate)
  1722.  
  1723. =item drivers
  1724.  
  1725.   drivers            (Display available DBI drivers)
  1726.  
  1727. =item edit
  1728.  
  1729.   edit               (Edit current statement in an external editor)
  1730.  
  1731. Editor is defined using the environment variable $VISUAL or
  1732. $EDITOR or default is vi.  Use option editor=new editor to change
  1733. in the current session.
  1734.  
  1735. To read a file from the operating system invoke the editor (edit)
  1736. and read the file into the editor buffer.
  1737.  
  1738. =item exit
  1739.  
  1740.   exit              (Exits the shell)
  1741.  
  1742. =item get
  1743.  
  1744.     get            Retrieve a previous command to the current buffer.
  1745.  
  1746.     get 1            Retrieve the 1 command executed into the current 
  1747.                     buffer.
  1748.  
  1749.     get -1         Retrieve the second to last command executed into
  1750.                     the current buffer.
  1751.  
  1752. =item go
  1753.  
  1754.   go                (Execute the current statement)
  1755.  
  1756. Run (execute) the statement in the current buffer.  This is the default
  1757. action if the statement ends with /
  1758.  
  1759.     dbish> select * from user_views/
  1760.  
  1761.     dbish> select table_name from user_tables
  1762.     dbish> where table_name like 'DSP%'
  1763.     dbish> /
  1764.  
  1765.     dbish> select table_name from all_tables/ | more
  1766.  
  1767. =item history
  1768.  
  1769.   history            (Display combined command and result history)
  1770.   history | more
  1771.  
  1772. =item load
  1773.  
  1774.   load file name    (read contains of file into the current buffer)
  1775.  
  1776. The contains of the file is loaded as the current buffer.
  1777.  
  1778. =item option
  1779.  
  1780.   option [option1[=value]] [option2 ...]
  1781.   option            (Displays the current options)
  1782.   option   MyOption (Displays the value, if exists, of MyOption)
  1783.   option   MyOption=4 (defines and/or sets value for MyOption)
  1784.  
  1785. =item perl
  1786.  
  1787.   perl               (Evaluate the current statement as perl code)
  1788.  
  1789. =item quit
  1790.  
  1791.   quit               (quit shell.  Same as exit)
  1792.  
  1793. =item redo
  1794.  
  1795.   redo               (Re-execute the previously executed statement)
  1796.  
  1797. =item rhistory
  1798.  
  1799.   rhistory           (Display result history)
  1800.  
  1801. =item rollback
  1802.  
  1803.   rollback           (rollback changes to the database)
  1804.  
  1805. For this to be useful, turn the autocommit off. option autocommit=0
  1806.  
  1807. =item run
  1808.  
  1809.   run file name      (load and execute a file.)
  1810.  
  1811. This commands load the file (may include full path) and executes.  The
  1812. file is loaded (replaces) the current buffer.  Only 1 statement per
  1813. file is allowed (at this time).
  1814.  
  1815. =item save
  1816.  
  1817.   save file name    (write contains of current buffer to file.)
  1818.  
  1819. The contains of the current buffer is written to file.  Currently,
  1820. this command will overwrite a file if it exists.
  1821.  
  1822. =item spool
  1823.  
  1824.   spool file name  (Starts sending all output to file name)
  1825.   spool on         (Starts sending all output to on.lst)
  1826.   spool off        (Stops sending output)
  1827.   spool            (Displays the status of spooling)
  1828.  
  1829. When spooling, everything seen in the command window is written to a file
  1830. (except some of the prompts).
  1831.  
  1832. =item table_info
  1833.  
  1834.   table_info         (display all tables that exist in current database)
  1835.   table_info | more  (for paging)
  1836.  
  1837. =item trace
  1838.  
  1839.   trace              (set DBI trace level for current database)
  1840.  
  1841. Adjust the trace level for DBI 0 - 4.  0 off.  4 lots of information.
  1842. Useful for determining what is really happening in DBI.  See DBI.
  1843.  
  1844. =item type_info
  1845.  
  1846.   type_info          (display data types supported by current server)
  1847.  
  1848. =back
  1849.  
  1850. =head1 ENVIRONMENT
  1851.  
  1852. =over 4
  1853.  
  1854. =item DBISH_TMP
  1855.  
  1856. Where to write temporary files.
  1857.  
  1858. =item DBISH_CONFIG
  1859.  
  1860. Which configuration file used.  Unset to not read any additional
  1861. configurations.
  1862.  
  1863. =back
  1864.  
  1865.  
  1866. =head1 AUTHORS and ACKNOWLEDGEMENTS
  1867.  
  1868. The DBI::Shell has a long lineage.
  1869.  
  1870. It started life around 1994-1997 as the pmsql script written by Andreas
  1871. K÷nig. Jochen Wiedmann picked it up and ran with it (adding much along
  1872. the way) as I<dbimon>, bundled with his DBD::mSQL driver modules. In
  1873. 1998, around the time I wanted to bundle a shell with the DBI, Adam
  1874. Marks was working on a dbish modeled after the Sybase sqsh utility.
  1875.  
  1876. Wanting to start from a cleaner slate than the feature-full but complex
  1877. dbimon, I worked with Adam to create a fairly open modular and very
  1878. configurable DBI::Shell module. Along the way Tom Lowery chipped in
  1879. ideas and patches. As we go further along more useful code and concepts
  1880. from Jochen's dbimon is bound to find it's way back in.
  1881.  
  1882. =head1 COPYRIGHT
  1883.  
  1884. The DBI::Shell module is Copyright (c) 1998 Tim Bunce. England.
  1885. All rights reserved. Portions are Copyright by Jochen Wiedmann,
  1886. Adam Marks and Tom Lowery.
  1887.  
  1888. You may distribute under the terms of either the GNU General Public
  1889. License or the Artistic License, as specified in the Perl README file.
  1890.  
  1891. =cut
  1892.