| 1 | package DBI::Shell; |
| 2 | |
| 3 | =head1 NAME |
| 4 | |
| 5 | DBI::Shell - Interactive command shell for the DBI |
| 6 | |
| 7 | =head1 SYNOPSIS |
| 8 | |
| 9 | perl -MDBI::Shell -e shell [<DBI data source> [<user> [<password>]]] |
| 10 | |
| 11 | or |
| 12 | |
| 13 | dbish [<DBI data source> [<user> [<password>]]] |
| 14 | |
| 15 | =head1 DESCRIPTION |
| 16 | |
| 17 | The DBI::Shell module (and dbish command, if installed) provide a |
| 18 | simple but effective command line interface for the Perl DBI module. |
| 19 | |
| 20 | DBI::Shell is very new, very experimental and very subject to change. |
| 21 | Your milage I<will> vary. Interfaces I<will> change with each release. |
| 22 | |
| 23 | =cut |
| 24 | |
| 25 | ### |
| 26 | ### See TO DO section in the docs at the end. |
| 27 | ### |
| 28 | |
| 29 | |
| 30 | BEGIN { require 5.004 } |
| 31 | BEGIN { $^W = 1 } |
| 32 | |
| 33 | use strict; |
| 34 | use vars qw(@ISA @EXPORT $VERSION $SHELL); |
| 35 | use Exporter (); |
| 36 | use Carp; |
| 37 | |
| 38 | @ISA = qw(Exporter); |
| 39 | @EXPORT = qw(shell); |
| 40 | $VERSION = sprintf "%d.%02d", '$Revision: 10.11 $ ' =~ /(\d+)\.(\d+)/; |
| 41 | |
| 42 | my $warning = <<'EOM'; |
| 43 | |
| 44 | WARNING: The DBI::Shell interface and functionality are |
| 45 | ======= very likely to change in subsequent versions! |
| 46 | |
| 47 | EOM |
| 48 | |
| 49 | sub shell { |
| 50 | my @args = @_ ? @_ : @ARGV; |
| 51 | $SHELL = DBI::Shell::Std->new(@args); |
| 52 | $SHELL->load_plugins; |
| 53 | $SHELL->run; |
| 54 | } |
| 55 | |
| 56 | |
| 57 | # ------------------------------------------------------------- |
| 58 | package DBI::Shell::Std; |
| 59 | |
| 60 | use vars qw(@ISA); |
| 61 | @ISA = qw(DBI::Shell::Base); |
| 62 | |
| 63 | # XXX this package might be used to override commands etc. |
| 64 | |
| 65 | |
| 66 | # ------------------------------------------------------------- |
| 67 | package DBI::Shell::Base; |
| 68 | |
| 69 | use Carp; |
| 70 | use Text::Abbrev (); |
| 71 | use Term::ReadLine; |
| 72 | use Getopt::Long 2.17; # upgrade from CPAN if needed: http://www.perl.com/CPAN |
| 73 | |
| 74 | use DBI 1.00 qw(:sql_types :utils); |
| 75 | use DBI::Format; |
| 76 | |
| 77 | my $haveTermReadKey; |
| 78 | |
| 79 | |
| 80 | sub usage { |
| 81 | warn <<USAGE; |
| 82 | Usage: perl -MDBI::Shell -e shell [<DBI data source> [<user> [<password>]]] |
| 83 | USAGE |
| 84 | } |
| 85 | |
| 86 | sub log { |
| 87 | my $sh = shift; |
| 88 | ($sh->{batch}) ? warn @_,"\n" : print @_,"\n"; # XXX maybe |
| 89 | } |
| 90 | |
| 91 | sub alert { # XXX not quite sure how alert and err relate |
| 92 | # for msgs that would pop-up an alert dialog if this was a Tk app |
| 93 | my $sh = shift; |
| 94 | warn @_,"\n"; |
| 95 | } |
| 96 | |
| 97 | sub err { # XXX not quite sure how alert and err relate |
| 98 | my ($sh, $msg, $die) = @_; |
| 99 | $msg = "DBI::Shell: $msg\n"; |
| 100 | die $msg if $die; |
| 101 | $sh->alert($msg); |
| 102 | } |
| 103 | |
| 104 | |
| 105 | |
| 106 | sub add_option { |
| 107 | my ($sh, $opt, $default) = @_; |
| 108 | (my $opt_name = $opt) =~ s/[|=].*//; |
| 109 | croak "Can't add_option '$opt_name', already defined" |
| 110 | if exists $sh->{$opt_name}; |
| 111 | $sh->{options}->{$opt_name} = $opt; |
| 112 | $sh->{$opt_name} = $default; |
| 113 | } |
| 114 | |
| 115 | |
| 116 | sub load_plugins { |
| 117 | my ($sh) = @_; |
| 118 | my @pi; |
| 119 | foreach my $where (qw(DBI/Shell DBI_Shell)) { |
| 120 | my $mod = $where; $mod =~ s!/!::!g; #/ so vim see the syn correctly |
| 121 | my @dir = map { -d "$_/$where" ? ("$_/$where") : () } @INC; |
| 122 | foreach my $dir (@dir) { |
| 123 | opendir DIR, $dir or warn "Unable to read $dir: $!\n"; |
| 124 | push @pi, map { s/\.pm$//; "${mod}::$_" } grep { /\.pm$/ } |
| 125 | readdir DIR; |
| 126 | closedir DIR; |
| 127 | } |
| 128 | } |
| 129 | foreach my $pi (@pi) { |
| 130 | local $DBI::Shell::SHELL = $sh; # publish the current shell |
| 131 | $sh->log("Loading $pi"); |
| 132 | eval qq{ use $pi }; |
| 133 | $sh->alert("Unable to load $pi: $@") if $@; |
| 134 | } |
| 135 | # plug-ins should remove options they recognise from (localized) @ARGV |
| 136 | # by calling Getopt::Long::GetOptions (which is already in pass_through mode). |
| 137 | foreach my $pi (@pi) { |
| 138 | local *ARGV = $sh->{unhandled_options}; |
| 139 | $pi->init($sh); |
| 140 | } |
| 141 | } |
| 142 | |
| 143 | |
| 144 | sub new { |
| 145 | my ($class, @args) = @_; |
| 146 | my $sh = bless {}, $class; |
| 147 | |
| 148 | # |
| 149 | # Set default configuration options |
| 150 | # |
| 151 | foreach my $opt_ref ( |
| 152 | [ 'command_prefix=s' => '/' ], |
| 153 | [ 'chistory_size=i' => 50 ], |
| 154 | [ 'rhistory_size=i' => 50 ], |
| 155 | [ 'rhistory_head=i' => 5 ], |
| 156 | [ 'rhistory_tail=i' => 5 ], |
| 157 | [ 'editor|ed=s' => ($ENV{VISUAL} || $ENV{EDITOR} || 'vi') ], |
| 158 | [ 'batch' => 0 ], |
| 159 | [ 'displaymode|display'=> 'neat' ], |
| 160 | [ 'columnseparator=s' => ',' ], |
| 161 | # defaults for each new database connect: |
| 162 | [ 'init_trace|trace=i' => 0 ], |
| 163 | [ 'init_autocommit|autocommit=i' => 1 ], |
| 164 | [ 'debug|d=i' => ($ENV{DBISH_DEBUG} || 0) ], |
| 165 | ) { |
| 166 | $sh->add_option(@$opt_ref); |
| 167 | } |
| 168 | |
| 169 | |
| 170 | # |
| 171 | # Install default commands |
| 172 | # |
| 173 | # The sub is passed a reference to the shell and the @ARGV-style |
| 174 | # args it was invoked with. |
| 175 | # |
| 176 | $sh->{commands} = { |
| 177 | |
| 178 | 'help' => { |
| 179 | hint => "display this list of commands", |
| 180 | }, |
| 181 | 'quit' => { |
| 182 | hint => "exit", |
| 183 | }, |
| 184 | 'exit' => { |
| 185 | hint => "exit", |
| 186 | }, |
| 187 | 'trace' => { |
| 188 | hint => "set DBI trace level for current database", |
| 189 | }, |
| 190 | 'connect' => { |
| 191 | hint => "connect to another data source/DSN", |
| 192 | }, |
| 193 | |
| 194 | # --- execute commands |
| 195 | 'go' => { |
| 196 | hint => "execute the current statement", |
| 197 | }, |
| 198 | 'do' => { |
| 199 | hint => "execute the current (non-select) statement", |
| 200 | }, |
| 201 | 'perl' => { |
| 202 | hint => "evaluate the current statement as perl code", |
| 203 | }, |
| 204 | 'commit' => { |
| 205 | hint => "commit changes to the database", |
| 206 | }, |
| 207 | 'rollback' => { |
| 208 | hint => "rollback changes to the database", |
| 209 | }, |
| 210 | # --- information commands |
| 211 | 'table_info' => { |
| 212 | hint => "display tables that exist in current database", |
| 213 | }, |
| 214 | 'type_info' => { |
| 215 | hint => "display data types supported by current server", |
| 216 | }, |
| 217 | 'drivers' => { |
| 218 | hint => "display available DBI drivers", |
| 219 | }, |
| 220 | |
| 221 | # --- statement/history management commands |
| 222 | 'clear' => { |
| 223 | hint => "erase the current statement", |
| 224 | }, |
| 225 | 'redo' => { |
| 226 | hint => "re-execute the previously executed statement", |
| 227 | }, |
| 228 | 'get' => { |
| 229 | hint => "make a previous statement current again", |
| 230 | }, |
| 231 | 'current' => { |
| 232 | hint => "display current statement", |
| 233 | }, |
| 234 | 'edit' => { |
| 235 | hint => "edit current statement in an external editor", |
| 236 | }, |
| 237 | 'chistory' => { |
| 238 | hint => "display command history", |
| 239 | }, |
| 240 | 'rhistory' => { |
| 241 | hint => "display result history", |
| 242 | }, |
| 243 | 'format' => { |
| 244 | hint => "set display format for selected data (Neat|Box)", |
| 245 | }, |
| 246 | 'history' => { |
| 247 | hint => "display combined command and result history", |
| 248 | }, |
| 249 | 'option' => { |
| 250 | hint => "display or set an option value", |
| 251 | }, |
| 252 | 'describe' => { |
| 253 | hint => "display information about a table", |
| 254 | }, |
| 255 | |
| 256 | }; |
| 257 | |
| 258 | |
| 259 | # Source config file which may override the defaults. |
| 260 | # Default is $ENV{HOME}/.dbish_config. |
| 261 | # Can be overridden with $ENV{DBISH_CONFIG}. |
| 262 | # Make $ENV{DBISH_CONFIG} empty to prevent sourcing config file. |
| 263 | # XXX all this will change |
| 264 | my $homedir = $ENV{HOME} # unix |
| 265 | || "$ENV{HOMEDRIVE}$ENV{HOMEPATH}"; # NT |
| 266 | $sh->{config_file} = $ENV{DBISH_CONFIG} || "$homedir/.dbish_config"; |
| 267 | if ($sh->{config_file} && -f $sh->{config_file}) { |
| 268 | require $sh->{config_file}; |
| 269 | } |
| 270 | |
| 271 | # |
| 272 | # Handle command line parameters |
| 273 | # |
| 274 | # data_source and user command line parameters overrides both |
| 275 | # environment and config settings. |
| 276 | # |
| 277 | local (@ARGV) = @args; |
| 278 | my @options = values %{ $sh->{options} }; |
| 279 | Getopt::Long::config('pass_through'); # for plug-ins |
| 280 | unless (GetOptions($sh, 'help|h', @options)) { |
| 281 | $class->usage; |
| 282 | croak "DBI::Shell aborted.\n"; |
| 283 | } |
| 284 | if ($sh->{help}) { |
| 285 | $class->usage; |
| 286 | return; |
| 287 | } |
| 288 | $sh->{unhandled_options} = []; |
| 289 | @args = (); |
| 290 | foreach my $arg (@ARGV) { |
| 291 | if ($arg =~ /^-/) { # expected to be in "--opt=value" format |
| 292 | push @{$sh->{unhandled_options}}, $arg; |
| 293 | } |
| 294 | else { |
| 295 | push @args, $arg; |
| 296 | } |
| 297 | } |
| 298 | |
| 299 | $sh->do_format($sh->{displaymode}); |
| 300 | |
| 301 | $sh->{data_source} = shift(@args) || $ENV{DBI_DSN} || ''; |
| 302 | $sh->{user} = shift(@args) || $ENV{DBI_USER} || ''; |
| 303 | $sh->{password} = shift(@args) || $ENV{DBI_PASS} || undef; |
| 304 | |
| 305 | $sh->{chistory} = []; # command history |
| 306 | $sh->{rhistory} = []; # result history |
| 307 | |
| 308 | # |
| 309 | # Setup Term |
| 310 | # |
| 311 | my $mode; |
| 312 | if ($sh->{batch} || ! -t STDIN) { |
| 313 | $sh->{batch} = 1; |
| 314 | $mode = "in batch mode"; |
| 315 | } |
| 316 | else { |
| 317 | $sh->{term} = new Term::ReadLine($class); |
| 318 | $mode = ""; |
| 319 | } |
| 320 | |
| 321 | $sh->log("DBI::Shell $DBI::Shell::VERSION using DBI $DBI::VERSION $mode"); |
| 322 | $sh->log("DBI::Shell loaded from $INC{'DBI/Shell.pm'}") if $sh->{debug}; |
| 323 | |
| 324 | return $sh; |
| 325 | } |
| 326 | |
| 327 | |
| 328 | sub run { |
| 329 | my $sh = shift; |
| 330 | |
| 331 | die "Unrecognised options: @{$sh->{unhandled_options}}\n" |
| 332 | if @{$sh->{unhandled_options}}; |
| 333 | |
| 334 | $sh->log($warning) unless $sh->{batch}; |
| 335 | |
| 336 | # Use valid "dbi:driver:..." to connect with source. |
| 337 | $sh->do_connect( $sh->{data_source} ); |
| 338 | |
| 339 | # |
| 340 | # Main loop |
| 341 | # |
| 342 | $sh->{abbrev} = undef; |
| 343 | $sh->{abbrev} = Text::Abbrev::abbrev(keys %{$sh->{commands}}) |
| 344 | unless $sh->{batch}; |
| 345 | $sh->{current_buffer} = ''; |
| 346 | my $current_line = ''; |
| 347 | |
| 348 | while (1) { |
| 349 | my $prefix = $sh->{command_prefix}; |
| 350 | |
| 351 | $current_line = $sh->readline($sh->prompt()); |
| 352 | $current_line = "${prefix}quit" unless defined $current_line; |
| 353 | |
| 354 | if ( $current_line =~ / |
| 355 | ^(.*?) |
| 356 | $prefix |
| 357 | (?:(\w*)([^\|>]*))? |
| 358 | ((?:\||>>?).+)? |
| 359 | $ |
| 360 | /x) { |
| 361 | my ($stmt, $cmd, $args_string, $output) = ($1, $2, $3, $4||''); |
| 362 | |
| 363 | $sh->{current_buffer} .= "$stmt\n" if length $stmt; |
| 364 | |
| 365 | $cmd = 'go' if $cmd eq ''; |
| 366 | my @args = split ' ', $args_string||''; |
| 367 | |
| 368 | warn("command='$cmd' args='$args_string' output='$output'") |
| 369 | if $sh->{debug}; |
| 370 | |
| 371 | my $command; |
| 372 | if ($sh->{abbrev}) { |
| 373 | $command = $sh->{abbrev}->{$cmd}; |
| 374 | } |
| 375 | else { |
| 376 | $command = ($sh->{commands}->{$cmd}) ? $cmd : undef; |
| 377 | } |
| 378 | if ($command) { |
| 379 | $sh->run_command($command, $output, @args); |
| 380 | } |
| 381 | else { |
| 382 | if ($sh->{batch}) { |
| 383 | die "Command '$cmd' not recognised"; |
| 384 | } |
| 385 | $sh->alert("Command '$cmd' not recognised ", |
| 386 | "(enter ${prefix}help for help)."); |
| 387 | } |
| 388 | } |
| 389 | elsif ($current_line ne "") { |
| 390 | $sh->{current_buffer} .= $current_line . "\n"; |
| 391 | # print whole buffer here so user can see it as |
| 392 | # it grows (and new users might guess that unrecognised |
| 393 | # inputs are treated as commands) |
| 394 | $sh->run_command('current', undef, |
| 395 | "(enter '$prefix' to execute or '${prefix}help' for help)"); |
| 396 | } |
| 397 | } |
| 398 | } |
| 399 | |
| 400 | |
| 401 | |
| 402 | |
| 403 | # |
| 404 | # Internal methods |
| 405 | # |
| 406 | |
| 407 | sub readline { |
| 408 | my ($sh, $prompt) = @_; |
| 409 | my $rv; |
| 410 | if ($sh->{term}) { |
| 411 | $rv = $sh->{term}->readline($prompt); |
| 412 | } |
| 413 | else { |
| 414 | chop($rv = <STDIN>); |
| 415 | } |
| 416 | return $rv; |
| 417 | } |
| 418 | |
| 419 | |
| 420 | sub run_command { |
| 421 | my ($sh, $command, $output, @args) = @_; |
| 422 | return unless $command; |
| 423 | local(*STDOUT) if $output; |
| 424 | local(*OUTPUT) if $output; |
| 425 | if ($output) { |
| 426 | if (open(OUTPUT, $output)) { |
| 427 | *STDOUT = *OUTPUT; |
| 428 | } else { |
| 429 | $sh->err("Couldn't open output '$output'"); |
| 430 | $sh->run_command('current', undef, ''); |
| 431 | } |
| 432 | } |
| 433 | eval { |
| 434 | my $code = "do_$command"; |
| 435 | $sh->$code(@args); |
| 436 | }; |
| 437 | close OUTPUT if $output; |
| 438 | $sh->err("$command failed: $@") if $@; |
| 439 | } |
| 440 | |
| 441 | |
| 442 | sub print_list { |
| 443 | my ($sh, $list_ref) = @_; |
| 444 | for(my $i = 0; $i < @$list_ref; $i++) { |
| 445 | print $i+1,": $$list_ref[$i]\n"; |
| 446 | } |
| 447 | } |
| 448 | |
| 449 | |
| 450 | sub print_buffer { |
| 451 | my ($sh, $buffer) = @_; |
| 452 | print $sh->prompt(), $buffer, "\n"; |
| 453 | } |
| 454 | |
| 455 | |
| 456 | sub get_data_source { |
| 457 | my ($sh, $dsn, @args) = @_; |
| 458 | my $driver; |
| 459 | |
| 460 | if ($dsn) { |
| 461 | if ($dsn =~ m/^dbi:.*:/i) { # has second colon |
| 462 | return $dsn; # assumed to be full DSN |
| 463 | } |
| 464 | elsif ($dsn =~ m/^dbi:([^:]*)/i) { |
| 465 | $driver = $1 # use DriverName part |
| 466 | } |
| 467 | else { |
| 468 | print "Ignored unrecognised DBI DSN '$dsn'.\n"; |
| 469 | } |
| 470 | } |
| 471 | |
| 472 | if ($sh->{batch}) { |
| 473 | die "Missing or unrecognised DBI DSN."; |
| 474 | } |
| 475 | |
| 476 | print "\n"; |
| 477 | while (!$driver) { |
| 478 | print "Available DBI drivers:\n"; |
| 479 | my @drivers = DBI->available_drivers; |
| 480 | for( my $cnt = 0; $cnt <= $#drivers; $cnt++ ) { |
| 481 | printf "%2d: dbi:%s\n", $cnt+1, $drivers[$cnt]; |
| 482 | } |
| 483 | $driver = $sh->readline( |
| 484 | "Enter driver name or number, or full 'dbi:...:...' DSN: "); |
| 485 | exit unless defined $driver; # detect ^D / EOF |
| 486 | print "\n"; |
| 487 | |
| 488 | return $driver if $driver =~ /^dbi:.*:/i; # second colon entered |
| 489 | |
| 490 | if ( $driver =~ /^\s*(\d+)/ ) { |
| 491 | $driver = $drivers[$1-1]; |
| 492 | } else { |
| 493 | $driver = $1; |
| 494 | $driver =~ s/^dbi://i if $driver # incase they entered 'dbi:Name' |
| 495 | } |
| 496 | # XXX try to install $driver (if true) |
| 497 | # unset $driver if install fails. |
| 498 | } |
| 499 | |
| 500 | my $source; |
| 501 | while (!defined $source) { |
| 502 | my $prompt; |
| 503 | my @data_sources = DBI->data_sources($driver); |
| 504 | if (@data_sources) { |
| 505 | print "Enter data source to connect to: \n"; |
| 506 | for( my $cnt = 0; $cnt <= $#data_sources; $cnt++ ) { |
| 507 | printf "%2d: %s\n", $cnt+1, $data_sources[$cnt]; |
| 508 | } |
| 509 | $prompt = "Enter data source or number,"; |
| 510 | } |
| 511 | else { |
| 512 | print "(The data_sources method returned nothing.)\n"; |
| 513 | $prompt = "Enter data source"; |
| 514 | } |
| 515 | $source = $sh->readline( |
| 516 | "$prompt or full 'dbi:...:...' DSN: "); |
| 517 | return if !defined $source; # detect ^D / EOF |
| 518 | if ($source =~ /^\s*(\d+)/) { |
| 519 | $source = $data_sources[$1-1] |
| 520 | } |
| 521 | elsif ($source =~ /^dbi:([^:]+)$/) { # no second colon |
| 522 | $driver = $1; # possibly new driver |
| 523 | $source = undef; |
| 524 | } |
| 525 | print "\n"; |
| 526 | } |
| 527 | |
| 528 | return $source; |
| 529 | } |
| 530 | |
| 531 | |
| 532 | sub prompt_for_password { |
| 533 | my ($sh) = @_; |
| 534 | if (!defined($haveTermReadKey)) { |
| 535 | $haveTermReadKey = eval { require Term::ReadKey } ? 1 : 0; |
| 536 | } |
| 537 | local $| = 1; |
| 538 | print "Password for $sh->{user} (", |
| 539 | ($haveTermReadKey ? "not " : "Warning: "), |
| 540 | "echoed to screen): "; |
| 541 | if ($haveTermReadKey) { |
| 542 | Term::ReadKey::ReadMode('noecho'); |
| 543 | $sh->{password} = Term::ReadKey::ReadLine(0); |
| 544 | Term::ReadKey::ReadMode('restore'); |
| 545 | } else { |
| 546 | $sh->{password} = <STDIN>; |
| 547 | } |
| 548 | chomp $sh->{password}; |
| 549 | print "\n"; |
| 550 | } |
| 551 | |
| 552 | sub prompt { |
| 553 | my ($sh) = @_; |
| 554 | return "" if $sh->{batch}; |
| 555 | return "(not connected)> " unless $sh->{dbh}; |
| 556 | return "$sh->{user}\@$sh->{data_source}> "; |
| 557 | } |
| 558 | |
| 559 | |
| 560 | sub push_chistory { |
| 561 | my ($sh, $cmd) = @_; |
| 562 | $cmd = $sh->{current_buffer} unless defined $cmd; |
| 563 | $sh->{prev_buffer} = $cmd; |
| 564 | my $chist = $sh->{chistory}; |
| 565 | shift @$chist if @$chist >= $sh->{chistory_size}; |
| 566 | push @$chist, $cmd; |
| 567 | } |
| 568 | |
| 569 | |
| 570 | # |
| 571 | # Command methods |
| 572 | # |
| 573 | |
| 574 | sub do_help { |
| 575 | my ($sh, @args) = @_; |
| 576 | my $prefix = $sh->{command_prefix}; |
| 577 | my $commands = $sh->{commands}; |
| 578 | print "Defined commands, in alphabetical order:\n"; |
| 579 | foreach my $cmd (sort keys %$commands) { |
| 580 | my $hint = $commands->{$cmd}->{hint} || ''; |
| 581 | printf " %s%-10s %s\n", $prefix, $cmd, $hint; |
| 582 | } |
| 583 | print "Commands can be abbreviated.\n" if $sh->{abbrev}; |
| 584 | } |
| 585 | |
| 586 | |
| 587 | sub do_format { |
| 588 | my ($sh, @args) = @_; |
| 589 | my $mode = $args[0] || ''; |
| 590 | my $col_sep = $args[1]; |
| 591 | my $class = eval { DBI::Format->formatter($mode) }; |
| 592 | unless ($class) { |
| 593 | $sh->alert("Unable to select '$mode': $@"); |
| 594 | return; |
| 595 | } |
| 596 | $sh->log("Using formatter class '$class'") if $sh->{debug}; |
| 597 | $sh->{display} = $class->new($sh); |
| 598 | $sh->do_option("columnseparator=$col_sep") if $col_sep; |
| 599 | } |
| 600 | |
| 601 | |
| 602 | sub do_go { |
| 603 | my ($sh, @args) = @_; |
| 604 | |
| 605 | return if $sh->{current_buffer} eq ''; |
| 606 | |
| 607 | $sh->{prev_buffer} = $sh->{current_buffer}; |
| 608 | |
| 609 | $sh->push_chistory; |
| 610 | |
| 611 | eval { |
| 612 | my $sth = $sh->{dbh}->prepare($sh->{current_buffer}); |
| 613 | |
| 614 | $sh->sth_go($sth, 1); |
| 615 | }; |
| 616 | if ($@) { |
| 617 | my $err = $@; |
| 618 | $err =~ s: at \S*DBI/Shell.pm line \d+(,.*?chunk \d+)?:: |
| 619 | if !$sh->{debug} && $err =~ /^DBD::\w+::\w+ \w+/; |
| 620 | print "$err"; |
| 621 | } |
| 622 | |
| 623 | # There need to be a better way, maybe clearing the |
| 624 | # buffer when the next non command is typed. |
| 625 | # Or sprinkle <$sh->{current_buffer} ||= $sh->{prev_buffer};> |
| 626 | # around in the code. |
| 627 | $sh->{current_buffer} = ''; |
| 628 | } |
| 629 | |
| 630 | |
| 631 | sub sth_go { |
| 632 | my ($sh, $sth, $execute) = @_; |
| 633 | |
| 634 | my $rv; |
| 635 | if ($execute || !$sth->{Active}) { |
| 636 | my @params; |
| 637 | my $params = $sth->{NUM_OF_PARAMS} || 0; |
| 638 | print "Statement has $params parameters:\n" if $params; |
| 639 | foreach(1..$params) { |
| 640 | my $val = $sh->readline("Parameter $_ value: "); |
| 641 | push @params, $val; |
| 642 | } |
| 643 | $rv = $sth->execute(@params); |
| 644 | } |
| 645 | |
| 646 | if (!$sth->{'NUM_OF_FIELDS'}) { # not a select statement |
| 647 | local $^W=0; |
| 648 | $rv = "undefined number of" unless defined $rv; |
| 649 | $rv = "unknown number of" if $rv == -1; |
| 650 | print "[$rv row" . ($rv==1 ? "" : "s") . " affected]\n"; |
| 651 | return; |
| 652 | } |
| 653 | |
| 654 | $sh->{sth} = $sth; |
| 655 | |
| 656 | # |
| 657 | # Remove oldest result from history if reached limit |
| 658 | # |
| 659 | my $rhist = $sh->{rhistory}; |
| 660 | shift @$rhist if @$rhist >= $sh->{rhistory_size}; |
| 661 | push @$rhist, []; |
| 662 | |
| 663 | # |
| 664 | # Keep a buffer of $sh->{rhistory_tail} many rows, |
| 665 | # when done with result add those to rhistory buffer. |
| 666 | # Could use $sth->rows(), but not all DBD's support it. |
| 667 | # |
| 668 | my @rtail; |
| 669 | my $i = 0; |
| 670 | my $display = $sh->{display} || die "panic: no display set"; |
| 671 | $display->header($sth, \*STDOUT, $sh->{columnseparator}); |
| 672 | while (my $rowref = $sth->fetchrow_arrayref()) { |
| 673 | $i++; |
| 674 | |
| 675 | $display->row($rowref); |
| 676 | |
| 677 | if ($i <= $sh->{rhistory_head}) { |
| 678 | push @{$rhist->[-1]}, [@$rowref]; |
| 679 | } |
| 680 | else { |
| 681 | shift @rtail if @rtail == $sh->{rhistory_tail}; |
| 682 | push @rtail, [@$rowref]; |
| 683 | } |
| 684 | |
| 685 | } |
| 686 | $display->trailer($i); |
| 687 | |
| 688 | if (@rtail) { |
| 689 | my $rows = $i; |
| 690 | my $ommitted = $i - $sh->{rhistory_head} - @rtail; |
| 691 | push(@{$rhist->[-1]}, |
| 692 | [ "[...$ommitted rows out of $rows ommitted...]"]); |
| 693 | foreach my $rowref (@rtail) { |
| 694 | push @{$rhist->[-1]}, $rowref; |
| 695 | } |
| 696 | } |
| 697 | |
| 698 | #$sh->{sth} = undef; |
| 699 | #$sth->finish(); # drivers which need this are broken |
| 700 | } |
| 701 | |
| 702 | |
| 703 | sub do_do { |
| 704 | my ($sh, @args) = @_; |
| 705 | $sh->push_chistory; |
| 706 | my $rv = $sh->{dbh}->do($sh->{current_buffer}); |
| 707 | print "[$rv row" . ($rv==1 ? "" : "s") . " affected]\n" |
| 708 | if defined $rv; |
| 709 | |
| 710 | # XXX I question setting the buffer to '' here. |
| 711 | # I may want to edit my line without having to scroll back. |
| 712 | $sh->{current_buffer} = ''; |
| 713 | } |
| 714 | |
| 715 | |
| 716 | sub do_disconnect { |
| 717 | my ($sh, @args) = @_; |
| 718 | return unless $sh->{dbh}; |
| 719 | $sh->log("Disconnecting from $sh->{data_source}."); |
| 720 | eval { |
| 721 | $sh->{sth}->finish if $sh->{sth}; |
| 722 | $sh->{dbh}->rollback unless $sh->{dbh}->{AutoCommit}; |
| 723 | $sh->{dbh}->disconnect; |
| 724 | }; |
| 725 | $sh->alert("Error during disconnect: $@") if $@; |
| 726 | $sh->{sth} = undef; |
| 727 | $sh->{dbh} = undef; |
| 728 | } |
| 729 | |
| 730 | |
| 731 | sub do_connect { |
| 732 | my ($sh, $dsn, $user, $pass) = @_; |
| 733 | |
| 734 | $dsn = $sh->get_data_source($dsn); |
| 735 | return unless $dsn; |
| 736 | |
| 737 | $sh->do_disconnect if $sh->{dbh}; |
| 738 | |
| 739 | $sh->{data_source} = $dsn; |
| 740 | if (defined $user and length $user) { |
| 741 | $sh->{user} = $user; |
| 742 | $sh->{password} = undef; # force prompt below |
| 743 | } |
| 744 | |
| 745 | $sh->log("Connecting to '$sh->{data_source}' as '$sh->{user}'..."); |
| 746 | if ($sh->{user} and !defined $sh->{password}) { |
| 747 | $sh->prompt_for_password(); |
| 748 | } |
| 749 | $sh->{dbh} = DBI->connect( |
| 750 | $sh->{data_source}, $sh->{user}, $sh->{password}, { |
| 751 | AutoCommit => $sh->{init_autocommit}, |
| 752 | PrintError => 0, |
| 753 | RaiseError => 1, |
| 754 | LongTruncOk => 1, # XXX |
| 755 | }); |
| 756 | $sh->{dbh}->trace($sh->{init_trace}) if $sh->{init_trace}; |
| 757 | } |
| 758 | |
| 759 | |
| 760 | sub do_current { |
| 761 | my ($sh, $msg, @args) = @_; |
| 762 | $msg = $msg ? " $msg" : ""; |
| 763 | $sh->log("Current statement buffer$msg:\n" . $sh->{current_buffer}); |
| 764 | } |
| 765 | |
| 766 | |
| 767 | sub do_trace { |
| 768 | shift->{dbh}->trace(@_); |
| 769 | } |
| 770 | |
| 771 | sub do_commit { |
| 772 | shift->{dbh}->commit(@_); |
| 773 | } |
| 774 | |
| 775 | sub do_rollback { |
| 776 | shift->{dbh}->rollback(@_); |
| 777 | } |
| 778 | |
| 779 | |
| 780 | sub do_quit { |
| 781 | my ($sh, @args) = @_; |
| 782 | $sh->do_disconnect if $sh->{dbh}; |
| 783 | undef $sh->{term}; |
| 784 | exit 0; |
| 785 | } |
| 786 | |
| 787 | # Until the alias command is working each command requires definition. |
| 788 | sub do_exit { shift->do_quit(@_); } |
| 789 | |
| 790 | sub do_clear { |
| 791 | my ($sh, @args) = @_; |
| 792 | $sh->{current_buffer} = ''; |
| 793 | } |
| 794 | |
| 795 | |
| 796 | sub do_redo { |
| 797 | my ($sh, @args) = @_; |
| 798 | $sh->{current_buffer} = $sh->{prev_buffer} || ''; |
| 799 | $sh->run_command('go') if $sh->{current_buffer}; |
| 800 | } |
| 801 | |
| 802 | |
| 803 | sub do_chistory { |
| 804 | my ($sh, @args) = @_; |
| 805 | $sh->print_list($sh->{chistory}); |
| 806 | } |
| 807 | |
| 808 | sub do_history { |
| 809 | my ($sh, @args) = @_; |
| 810 | for(my $i = 0; $i < @{$sh->{chistory}}; $i++) { |
| 811 | print $i+1, ":\n", $sh->{chistory}->[$i], "--------\n"; |
| 812 | foreach my $rowref (@{$sh->{rhistory}[$i]}) { |
| 813 | print " ", join(", ", @$rowref), "\n"; |
| 814 | } |
| 815 | } |
| 816 | } |
| 817 | |
| 818 | sub do_rhistory { |
| 819 | my ($sh, @args) = @_; |
| 820 | for(my $i = 0; $i < @{$sh->{rhistory}}; $i++) { |
| 821 | print $i+1, ":\n"; |
| 822 | foreach my $rowref (@{$sh->{rhistory}[$i]}) { |
| 823 | print " ", join(", ", @$rowref), "\n"; |
| 824 | } |
| 825 | } |
| 826 | } |
| 827 | |
| 828 | |
| 829 | sub do_get { |
| 830 | my ($sh, $num, @args) = @_; |
| 831 | if (!$num || $num !~ /^\d+$/ || !defined($sh->{chistory}->[$num-1])) { |
| 832 | $sh->err("No such command number '$num'. Use /chistory to list previous commands."); |
| 833 | return; |
| 834 | } |
| 835 | $sh->{current_buffer} = $sh->{chistory}->[$num-1]; |
| 836 | $sh->print_buffer($sh->{current_buffer}); |
| 837 | } |
| 838 | |
| 839 | |
| 840 | sub do_perl { |
| 841 | my ($sh, @args) = @_; |
| 842 | $DBI::Shell::eval::dbh = $sh->{dbh}; |
| 843 | eval "package DBI::Shell::eval; $sh->{current_buffer}"; |
| 844 | if ($@) { $sh->err("Perl failed: $@") } |
| 845 | $sh->run_command('clear'); |
| 846 | } |
| 847 | |
| 848 | |
| 849 | sub do_edit { |
| 850 | my ($sh, @args) = @_; |
| 851 | |
| 852 | $sh->run_command('get', '', $&) if @args and $args[0] =~ /^\d+$/; |
| 853 | $sh->{current_buffer} ||= $sh->{prev_buffer}; |
| 854 | |
| 855 | # Find an area to write a temp file into. |
| 856 | my $tmp_dir = $ENV{DBISH_TMP} || # Give people the choice. |
| 857 | $ENV{TMP} || # Is TMP set? |
| 858 | $ENV{TEMP} || # How about TEMP? |
| 859 | $ENV{HOME} || # Look for HOME? |
| 860 | $ENV{HOMEDRIVE} . $ENV{HOMEPATH} || # Last env checked. |
| 861 | "."; # fallback: try to write in current directory. |
| 862 | my $tmp_file = "$tmp_dir/dbish$$.sql"; |
| 863 | |
| 864 | local (*FH); |
| 865 | open(FH, ">$tmp_file") || |
| 866 | $sh->err("Can't create $tmp_file: $!\n", 1); |
| 867 | print FH $sh->{current_buffer} if defined $sh->{current_buffer}; |
| 868 | close(FH) || $sh->err("Can't write $tmp_file: $!\n", 1); |
| 869 | |
| 870 | my $command = "$sh->{editor} $tmp_file"; |
| 871 | system($command); |
| 872 | |
| 873 | # Read changes back in (editor may have deleted and rewritten file) |
| 874 | open(FH, "<$tmp_file") || $sh->err("Can't open $tmp_file: $!\n"); |
| 875 | $sh->{current_buffer} = join "", <FH>; |
| 876 | close(FH); |
| 877 | unlink $tmp_file; |
| 878 | |
| 879 | $sh->run_command('current'); |
| 880 | } |
| 881 | |
| 882 | |
| 883 | sub do_drivers { |
| 884 | my ($sh, @args) = @_; |
| 885 | $sh->log("Available drivers:"); |
| 886 | my @drivers = DBI->available_drivers; |
| 887 | foreach my $driver (sort @drivers) { |
| 888 | $sh->log("\t$driver"); |
| 889 | } |
| 890 | } |
| 891 | |
| 892 | |
| 893 | sub do_type_info { |
| 894 | my ($sh, @args) = @_; |
| 895 | my $dbh = $sh->{dbh}; |
| 896 | my $ti = $dbh->type_info_all; |
| 897 | my $ti_cols = shift @$ti; |
| 898 | my @names = sort { $ti_cols->{$a} <=> $ti_cols->{$b} } keys %$ti_cols; |
| 899 | my $sth = $sh->prepare_from_data("type_info", $ti, \@names); |
| 900 | $sh->sth_go($sth, 0); |
| 901 | } |
| 902 | |
| 903 | sub do_describe { |
| 904 | my ($sh, $tab, @argv) = @_; |
| 905 | $sh->log( "Describle: $tab" ); |
| 906 | my $dbh = $sh->{dbh}; |
| 907 | my $sql = qq{select * from $tab where 1 = 0}; |
| 908 | my $sth = $dbh->prepare( $sql ); |
| 909 | $sth->execute; |
| 910 | my $cnt = $#{$sth->{NAME}}; # |
| 911 | my @names = qw{NAME TYPE NULLABLE}; |
| 912 | my @ti; |
| 913 | #push( @j, join( "\t", qw{NAME TYPE PRECISION SCALE NULLABLE})); |
| 914 | for ( my $c = 0; $c <= $cnt; $c++ ) { |
| 915 | push( my @j, $sth->{NAME}->[$c] || 0 ); |
| 916 | my $m = $dbh->type_info($sth->{TYPE}->[$c]); |
| 917 | my $s; |
| 918 | if (ref $m eq 'HASH') { |
| 919 | $s = $m->{TYPE_NAME}; |
| 920 | } elsif (not defined $m) { |
| 921 | $s = q{undef } . $sth->{TYPE}->[$c]; |
| 922 | } else { |
| 923 | warn "describe: can't parse data ($m) from type_info!"; |
| 924 | } |
| 925 | |
| 926 | if (defined $sth->{PRECISION}->[$c]) { |
| 927 | $s .= "(" . $sth->{PRECISION}->[$c] || ''; |
| 928 | $s .= "," . $sth->{SCALE}->[$c] |
| 929 | if ( defined $sth->{SCALE}->[$c] |
| 930 | and $sth->{SCALE}->[$c] ne 0); |
| 931 | $s .= ")"; |
| 932 | } |
| 933 | push(@j, $s, |
| 934 | $sth->{NULLABLE}->[$c] ne 1? qq{N}: qq{Y} ); |
| 935 | push(@ti,\@j); |
| 936 | } |
| 937 | $sth->finish; |
| 938 | $sth = $sh->prepare_from_data("describe", \@ti, \@names); |
| 939 | $sh->sth_go($sth, 0); |
| 940 | } |
| 941 | |
| 942 | |
| 943 | sub prepare_from_data { |
| 944 | my ($sh, $statement, $data, $names, %attr) = @_; |
| 945 | my $sponge = DBI->connect("dbi:Sponge:","","",{ RaiseError => 1 }); |
| 946 | my $sth = $sponge->prepare($statement, { rows=>$data, NAME=>$names, %attr }); |
| 947 | return $sth; |
| 948 | } |
| 949 | |
| 950 | |
| 951 | # Do option: sets or gets an option |
| 952 | sub do_option { |
| 953 | my ($sh, @args) = @_; |
| 954 | |
| 955 | unless (@args) { |
| 956 | foreach my $opt (sort keys %{ $sh->{options}}) { |
| 957 | my $value = (defined $sh->{$opt}) ? $sh->{$opt} : 'undef'; |
| 958 | $sh->log(sprintf("%20s: %s", $opt, $value)); |
| 959 | } |
| 960 | return; |
| 961 | } |
| 962 | |
| 963 | my $options = Text::Abbrev::abbrev(keys %{$sh->{options}}); |
| 964 | |
| 965 | # Expecting the form [option=value] [option=] [option] |
| 966 | foreach my $opt (@args) { |
| 967 | my ($opt_name, $value) = $opt =~ /^\s*(\w+)(?:=(.*))?/; |
| 968 | $opt_name = $options->{$opt_name} || $opt_name if $opt_name; |
| 969 | if (!$opt_name || !$sh->{options}->{$opt_name}) { |
| 970 | $sh->log("Unknown or ambiguous option name '$opt_name' (use name=value format)"); |
| 971 | next; |
| 972 | } |
| 973 | my $crnt = (defined $sh->{$opt_name}) ? $sh->{$opt_name} : 'undef'; |
| 974 | my $log; |
| 975 | if (not defined $value) { |
| 976 | $log = "$opt_name=$crnt"; |
| 977 | } |
| 978 | else { |
| 979 | $log = "/option $opt_name=$value (was $crnt)"; |
| 980 | $sh->{$opt_name} = ($value eq 'undef') ? undef : $value; |
| 981 | } |
| 982 | $sh->log($sh->{command_prefix}."option $log"); |
| 983 | } |
| 984 | } |
| 985 | |
| 986 | |
| 987 | sub do_table_info { |
| 988 | my ($sh, @args) = @_; |
| 989 | my $dbh = $sh->{dbh}; |
| 990 | my $sth = $dbh->table_info(@args); |
| 991 | unless(ref $sth) { |
| 992 | print "Driver has not implemented the table_info() method, ", |
| 993 | "trying tables()\n"; |
| 994 | my @tables = $dbh->tables(@args); # else try list context |
| 995 | unless (@tables) { |
| 996 | print "No tables exist ", |
| 997 | "(or driver hasn't implemented the tables method)\n"; |
| 998 | return; |
| 999 | } |
| 1000 | $sth = $sh->prepare_from_data("tables", |
| 1001 | [ map { [ $_ ] } @tables ], |
| 1002 | [ "TABLE_NAME" ] |
| 1003 | ); |
| 1004 | } |
| 1005 | $sh->sth_go($sth, 0); |
| 1006 | } |
| 1007 | |
| 1008 | |
| 1009 | |
| 1010 | 1; |
| 1011 | __END__ |
| 1012 | |
| 1013 | =head1 TO DO |
| 1014 | |
| 1015 | Proper docs - but not yet, too much is changing. |
| 1016 | |
| 1017 | "/source file" command to read command file. |
| 1018 | Allow to nest via stack of command file handles. |
| 1019 | Add command log facility to create batch files. |
| 1020 | |
| 1021 | Commands: |
| 1022 | load (query?) from file |
| 1023 | save (query?) to file |
| 1024 | |
| 1025 | Use Data::ShowTable if available. |
| 1026 | |
| 1027 | Define DBI::Shell plug-in semantics. |
| 1028 | Implement import/export as plug-in module |
| 1029 | |
| 1030 | Clarify meaning of batch mode |
| 1031 | |
| 1032 | Completion hooks |
| 1033 | |
| 1034 | Set/Get DBI handle attributes |
| 1035 | |
| 1036 | Portability |
| 1037 | |
| 1038 | Emulate popular command shell modes (Oracle, Ingres etc)? |
| 1039 | |
| 1040 | =head1 COMMANDS |
| 1041 | |
| 1042 | Many commands - few documented, yet! |
| 1043 | |
| 1044 | =over 4 |
| 1045 | |
| 1046 | =item help |
| 1047 | |
| 1048 | /help |
| 1049 | |
| 1050 | =item chistory |
| 1051 | |
| 1052 | /chistory (display history of all commands entered) |
| 1053 | /chistory | YourPager (display history with paging) |
| 1054 | |
| 1055 | =item clear |
| 1056 | |
| 1057 | /clear (Clears the current command buffer) |
| 1058 | |
| 1059 | =item commit |
| 1060 | |
| 1061 | /commit (commit changes to the database) |
| 1062 | |
| 1063 | =item connect |
| 1064 | |
| 1065 | /connect (pick from available drivers and sources) |
| 1066 | /connect dbi:Oracle (pick source from based on driver) |
| 1067 | /connect dbi:YourDriver:YourSource i.e. dbi:Oracle:mysid |
| 1068 | |
| 1069 | Use this option to change userid or password. |
| 1070 | |
| 1071 | =item current |
| 1072 | |
| 1073 | /current (Display current statement in the buffer) |
| 1074 | |
| 1075 | =item do |
| 1076 | |
| 1077 | /do (execute the current (non-select) statement) |
| 1078 | |
| 1079 | dbish> create table foo ( mykey integer ) |
| 1080 | dbish> /do |
| 1081 | |
| 1082 | dbish> truncate table OldTable /do (Oracle truncate) |
| 1083 | |
| 1084 | =item drivers |
| 1085 | |
| 1086 | /drivers (Display available DBI drivers) |
| 1087 | |
| 1088 | =item edit |
| 1089 | |
| 1090 | /edit (Edit current statement in an external editor) |
| 1091 | |
| 1092 | Editor is defined using the enviroment variable $VISUAL or |
| 1093 | $EDITOR or default is vi. Use /option editor=new editor to change |
| 1094 | in the current session. |
| 1095 | |
| 1096 | To read a file from the operating system invoke the editor (/edit) |
| 1097 | and read the file into the editor buffer. |
| 1098 | |
| 1099 | =item exit |
| 1100 | |
| 1101 | /exit (Exits the shell) |
| 1102 | |
| 1103 | =item get |
| 1104 | |
| 1105 | /get (Retrieve a previous command to the current buffer) |
| 1106 | |
| 1107 | =item go |
| 1108 | |
| 1109 | /go (Execute the current statement) |
| 1110 | |
| 1111 | Run (execute) the statement in the current buffer. This is the default |
| 1112 | action if the statement ends with / |
| 1113 | |
| 1114 | dbish> select * from user_views/ |
| 1115 | |
| 1116 | dbish> select table_name from user_tables |
| 1117 | dbish> where table_name like 'DSP%' |
| 1118 | dbish> / |
| 1119 | |
| 1120 | dbish> select table_name from all_tables/ | more |
| 1121 | |
| 1122 | =item history |
| 1123 | |
| 1124 | /history (Display combined command and result history) |
| 1125 | /history | more |
| 1126 | |
| 1127 | =item option |
| 1128 | |
| 1129 | /option [option1[=value]] [option2 ...] |
| 1130 | /option (Displays the current options) |
| 1131 | /option MyOption (Displays the value, if exists, of MyOption) |
| 1132 | /option MyOption=4 (defines and/or sets value for MyOption) |
| 1133 | |
| 1134 | =item perl |
| 1135 | |
| 1136 | /perl (Evaluate the current statement as perl code) |
| 1137 | |
| 1138 | =item quit |
| 1139 | |
| 1140 | /quit (Leaves shell. Same as exit) |
| 1141 | |
| 1142 | =item redo |
| 1143 | |
| 1144 | /redo (Re-execute the previously executed statement) |
| 1145 | |
| 1146 | =item rhistory |
| 1147 | |
| 1148 | /rhistory (Display result history) |
| 1149 | |
| 1150 | =item rollback |
| 1151 | |
| 1152 | /rollback (rollback changes to the database) |
| 1153 | |
| 1154 | For this to be useful, turn the autocommit off. /option autocommit=0 |
| 1155 | |
| 1156 | =item table_info |
| 1157 | |
| 1158 | /table_info (display all tables that exist in current database) |
| 1159 | /table_info | more (for paging) |
| 1160 | |
| 1161 | =item trace |
| 1162 | |
| 1163 | /trace (set DBI trace level for current database) |
| 1164 | |
| 1165 | Adjust the trace level for DBI 0 - 4. 0 off. 4 is lots of information. |
| 1166 | Useful for determining what is really happening in DBI. See DBI. |
| 1167 | |
| 1168 | =item type_info |
| 1169 | |
| 1170 | /type_info (display data types supported by current server) |
| 1171 | |
| 1172 | =back |
| 1173 | |
| 1174 | =head1 AUTHORS and ACKNOWLEDGEMENTS |
| 1175 | |
| 1176 | The DBI::Shell has a long lineage. |
| 1177 | |
| 1178 | It started life around 1994-1997 as the pmsql script written by Andreas |
| 1179 |