File Coverage

lib/SQL/Shell.pm
Criterion Covered Total %
statement 275 730 37.6
branch 106 372 28.4
condition 30 100 30.0
subroutine 54 95 56.8
pod 39 41 95.1
total 504 1338 37.6


line stmt bran cond sub pod time code
1             ##############################################################################
2             # Purpose : SQL Shell API
3             # Author : John Alden
4             # Created : Jul 2006 (refactored from sqlsh.pl)
5             # CVS : $Header: /home/cvs/software/cvsroot/db_utils/lib/SQL/Shell.pm,v 1.14 2006/12/05 14:31:33 andreww Exp $
6             ###############################################################################
7              
8             package SQL::Shell;
9              
10 1     1   25721 use strict;
  1         4  
  1         30  
11              
12 1     1   4 use Carp;
  1         2  
  1         60  
13 1     1   1565 use DBI;
  1         18362  
  1         60  
14 1     1   6 use File::Path;
  1         2  
  1         63  
15 1     1   475 use IO::File;
  1         8331  
  1         102  
16 1     1   479 use URI::Escape;
  1         1378  
  1         57  
17              
18 1     1   7 use vars qw($VERSION);
  1         2  
  1         102  
19             $VERSION = ('$Revision: 1.17 $' =~ /([\d\._]+)/)[0];
20              
21 1   50 1   6 use constant HISTORY_SIZE => $ENV{HISTSIZE} || $ENV{HISTFILESIZE} || 50;
  1         2  
  1         82  
22 1     1   6 use vars qw(%Renderers %Commands %Settings);
  1         1  
  1         7258  
23              
24             #Available rendering routines
25             %Renderers = (
26             'delimited' => \&_render_delimited,
27             'box' => \&_render_box,
28             'spaced' => \&_render_spaced,
29             'record' => \&_render_record,
30             'sql' => \&_render_sql,
31             'xml' => \&_render_xml,
32             );
33              
34             #Commands available by default
35             %Commands = (
36             qr/^(list|show) +drivers$/i => \&show_drivers,
37             qr/^(?:list|show) datasources (\w+)$/i => \&show_datasources,
38             qr/^(show )?history$/i => \&show_history,
39             qr/^clear history$/i => \&clear_history,
40             qr/^load history from ([\w\-\.\/~]+)$/i => \&load_history,
41             qr/^save history to ([\w\-\.\/~]+)$/i => \&save_history,
42             qr/^connect (\S+) ?(\S+)? ?(\S+)?/i => \&connect,
43             qr/^disconnect$/i => \&disconnect,
44             qr/^show +\$dbh +(.*)/i => \&show_dbh,
45             qr/^(list|show) +schema$/i => \&show_schema,
46             qr/^(list|show) +tablecounts$/i => \&show_tablecounts,
47             qr/^(list|show) +(tables|catalogs|schemas|tabletypes)(?: like)?( .*)?$/i => \&show_objects,
48             qr/^(list|show) +charsets$/i => \&show_charsets,
49             qr/^(list|show) +settings$/i => \&show_settings,
50             qr/^(?:desc|describe) +(.*)/i => \&describe,
51             qr/^((?:select|explain|recv)\s+.*)/is => \&run_query,
52             qr/^((?:create|alter|drop|insert|replace|update|delete|grant|revoke|send) .*)/is => \&do_sql,
53             qr/^begin work/i => \&begin_work,
54             qr/^rollback/i => \&rollback,
55             qr/^commit/i => \&commit,
56             qr/^wipe(?: all)? tables$/i => \&wipe_tables,
57             qr/^load ([^\s]+) into ([\w\-\.\/]+)(?: delimited by (\S+))?(?: (uri-decode))?(?: from (\S+))?(?: to (\S+))?/i => \&load_data,
58             qr/^dump (.+) into ([\w\-\.\/~]+)(?: delimited by (\S+))?/i => \&dump_data,
59             qr/^set +(.*?)\s+(.*)/i => \&set_param,
60             qr/^(?:execute|source) +(.*)/i => \&run_script,
61             qr/^no log$/i => \&disable_logging,
62             qr/^log +(.*?) +(?:(?:to|into) +)?(.*)/i => \&enable_logging,
63             );
64              
65             %Settings = map {$_ => 1} qw(GetHistory SetHistory AddHistory MaxHistory Interactive Verbose NULL Renderer Logger Delimiter Width LogLevel EscapeStrategy AutoCommit LongTruncOk LongReadLen MultiLine);
66              
67             my %viewable_settings = (
68             'auto-commit' => 'AutoCommit',
69             delimiter => 'Delimiter',
70             'enter-whitespace' => 'EnterWhitespace',
71             'escape' => 'EscapeStrategy',
72             longreadlen => 'LongReadLen',
73             longtruncok => 'LongTruncOk',
74             multiline => 'MultiLine',
75             verbose => 'Verbose',
76             width => 'Width',
77             );
78              
79             my %boolean_settings = map {$_ => 1} qw (AutoCommit LongTruncOk MultiLine Verbose);
80              
81             #######################################################################
82             #
83             # Public methods - these should croak on error
84             #
85             #######################################################################
86              
87             sub new
88             {
89 1     1 1 404 my ($class, $overrides) = @_;
90              
91             #Default storage for history information (used by closures)
92 1         2 my @history;
93              
94             #Default settings
95             my $settings = {
96             Interactive => $overrides->{Interactive} || 0,
97             Verbose => $overrides->{Verbose} || 0,
98             Renderer => _renderer($overrides->{Renderer}) || \&_render_box,
99             Logger => _renderer($overrides->{Logger}) || \&_render_delimited,
100             Delimiter => $overrides->{Delimiter} || "\t",
101             Width => $overrides->{Width} || 80,
102             MaxHistory => $overrides->{MaxHistory} || HISTORY_SIZE,
103             LogLevel => $overrides->{LogLevel},
104             AutoCommit => $overrides->{AutoCommit} || 0,
105             LongTruncOk => exists $overrides->{LongTruncOk}? $overrides->{LongTruncOk} : 1,
106             LongReadLen => $overrides->{LongReadLen} || 512,
107             MultiLine => $overrides->{MultiLine} || 0,
108 3     3   329 GetHistory => $overrides->{GetHistory} || sub {return \@history},
109 3     3   325 SetHistory => $overrides->{SetHistory} || sub {my $n = shift; @history = @$n},
  3         10  
110 9     9   21 AddHistory => $overrides->{AddHistory} || sub {push @history, shift()},
111 1 50 50     11 NULL => exists $overrides->{NULL}? $overrides->{NULL} : 'NULL',
    50 50        
      50        
      50        
      50        
      50        
      50        
      50        
      50        
      50        
      50        
      50        
      50        
112             };
113              
114 1         16 my %commands = %Commands;
115 1         6 my %renderers = %Renderers;
116              
117 1         4 my $self = {
118             'settings' => $settings,
119             'commands' => \%commands,
120             'renderers' => \%renderers,
121             'current_statement' => ''
122             };
123 1         4 return bless($self, $class);
124             }
125              
126             sub DESTROY
127             {
128 1     1   1215 my $self = shift;
129 1 50       4 if(_is_connected($self->{dbh})) {
130 0         0 $self->{dbh}->disconnect();
131             }
132             }
133              
134             sub set
135             {
136 0     0 1 0 my ($self, $key, $value) = @_;
137 0 0       0 croak("Unknown setting: $key") unless $Settings{$key};
138 0         0 $self->{settings}{$key} = $value;
139             }
140              
141             sub get
142             {
143 2     2 1 1311 my ($self, $key) = @_;
144 2 50       8 croak("Unknown setting: $key") unless $Settings{$key};
145 2         5 return $self->{settings}{$key};
146             }
147              
148             sub install_renderers
149             {
150 0     0 1 0 my ($self, $renderers) = @_;
151 0 0       0 croak "install_renderers method should be passed a hashref" unless(ref $renderers eq 'HASH');
152 0         0 foreach my $k (keys %$renderers) {
153 0         0 $self->{renderers}{$k} = $renderers->{$k};
154             }
155             }
156              
157             sub uninstall_renderers
158             {
159 0     0 1 0 my ($self, $renderers) = @_;
160 0 0       0 $renderers = $self->{renderers} unless defined ($renderers);
161 0 0       0 croak "uninstall_renderers method should be passed an arrayref" unless(ref $renderers eq 'ARRAY');
162 0         0 for(@$renderers) {
163 0 0       0 delete $self->{renderers}{$_} or carp("$_ not found in list of renderers");
164             }
165             }
166              
167             sub install_cmds
168             {
169 1     1 1 1313 my ($self, $cmds) = @_;
170 1 50       6 croak "install_commands method should be passed a hashref" unless(ref $cmds eq 'HASH');
171 1         5 foreach my $rx(keys %$cmds) {
172 1         4 $self->{commands}{$rx} = $cmds->{$rx};
173             }
174             }
175              
176             sub uninstall_cmds
177             {
178 1     1 1 396 my ($self, $cmds) = @_;
179 1 50       4 $cmds = $self->{commands} unless defined ($cmds);
180 1 50       4 croak "uninstall_commands method should be passed an arrayref" unless(ref $cmds eq 'ARRAY');
181 1         4 for(@$cmds) {
182 1 50       14 delete $self->{commands}{$_} or carp("$_ not found in list of commands");
183             }
184             }
185              
186             sub execute_cmd
187             {
188 33     33 1 125737 my $self = shift;
189 33         110 return $self->_execute(@_);
190             }
191              
192             sub is_connected
193             {
194 0     0 1 0 my $self = shift;
195 0         0 return _is_connected($self->{dbh});
196             }
197              
198             sub dsn
199             {
200 0     0 1 0 my $self = shift;
201 0 0       0 return undef unless _is_connected($self->{dbh});
202 0         0 return sprintf "DBI:%s:%s", $self->{dbh}{Driver}{Name}, $self->{dbh}{Name};
203             }
204              
205             sub render_rowset {
206 1     1 1 2 my $self = shift;
207 1         3 $self->{settings}{Renderer}->($self, \*STDOUT, @_);
208             }
209              
210             sub log_rowset {
211 0     0 1 0 my $self = shift;
212 0         0 $self->{settings}{Logger}->($self, $self->{LogFH}, @_);
213             }
214              
215             ###############################################
216             #
217             # Commands - these should die with /n on error
218             #
219             ###############################################
220              
221             sub run_script
222             {
223 1     1 1 8 my ($self, $script) = @_;
224 1 50       33 print "Executing $script\n" if ($self->{settings}{Verbose});
225 1         9 $script = _expand_filename($script);
226 1 50       11 my $file = new IO::File "$script" or die("Unable to open file $script - $!");
227 1         154 my @cmds = map {chomp; $_} <$file>;
  2         5  
  2         8  
228 1         9 foreach(@cmds)
229             {
230 2 100       9 $self->execute_cmd($_) or die("Command '$_' failed - aborting $script");
231             }
232 0         0 return 1;
233             }
234              
235             sub load_history
236             {
237 1     1 1 3 my $self = shift;
238 1   50     4 my $filename = shift || die("You must specify a file to load the history from");
239              
240 1         5 TRACE("Loading history from $filename");
241 1         4 my $history = _load_history($filename);
242 1 50       6 $self->{settings}{SetHistory}->($history) if(defined $history);
243 1         4 return $history;
244             }
245              
246             sub clear_history
247             {
248 1     1 1 3 my $self = shift;
249 1         3 TRACE("Clearing history");
250 1         3 $self->{settings}{SetHistory}->([]);
251 1         4 return 1;
252             }
253              
254             sub save_history
255             {
256 1     1 1 21 my $self = shift;
257 1   50     5 my $filename = shift || die("You must specify a file to save the history to");
258 1   33     15 my $max_size = shift || $self->{settings}{MaxHistory};
259              
260 1         4 my $history = $self->{settings}{GetHistory}->();
261 1         7 TRACE("Saving history to $filename (contains ".(scalar @$history)." items)");
262 1         4 _save_history($history, $filename, $max_size);
263 1         7 return 1;
264             }
265              
266             sub show_history
267             {
268 1     1 1 2 my $self = shift;
269 1         4 my $history = $self->{settings}{GetHistory}->();
270 1         3 print "\n",(map {" ".$_."\n"} @$history),"\n";
  3         31  
271 1         9 return 1;
272             }
273              
274             sub enable_logging
275             {
276 0     0 1 0 my ($self, $level, $file) = @_;
277 0 0       0 die("Unrecognised logging level: $level\n") unless($level =~ /^(commands|queries|all)$/);
278 0         0 my $settings = $self->{settings};
279 0         0 $file = _expand_filename($file);
280 0 0       0 $self->{LogFH} = new IO::File ">> $file" or die("Unable to open $file for logging - $!\n");
281 0         0 $settings->{LogLevel} = $level;
282 0 0       0 print "Logging $level to $file\n" if($settings->{Verbose});
283 0         0 return 1;
284             }
285              
286             sub disable_logging
287             {
288 0     0 1 0 my ($self) = @_;
289 0         0 my $settings = $self->{settings};
290 0 0 0     0 print "Stopped logging $settings->{LogLevel}\n" if($settings->{Verbose} && defined $self->{LogFH});
291 0         0 $self->{LogFH} = undef;
292 0         0 $settings->{LogLevel} = undef;
293 0         0 return 1;
294             }
295              
296             sub connect
297             {
298 0     0 1 0 my($self, $dsn, $username, $password) = @_;
299 0         0 my $settings = $self->{settings};
300              
301             my $dbh = DBI->connect($dsn, $username, $password,
302             {PrintError => 0, RaiseError => 1, LongTruncOk => $settings->{LongTruncOk},
303 0         0 LongReadLen => $settings->{LongReadLen}});
304              
305 0         0 eval { $dbh->{AutoCommit} = $settings->{AutoCommit} };
  0         0  
306 0 0 0     0 if ($@ && !$settings->{AutoCommit}) {
307 0         0 warn "WARNING: $dsn doesn't appear to support transactions\n";
308             }
309              
310 0         0 $self->{dbh} = $dbh;
311 0         0 return $dbh;
312             }
313              
314             sub disconnect
315             {
316 55     55 1 65 my $self = shift;
317 55 50       85 $self->{dbh}->disconnect if _is_connected($self->{dbh});
318 55         80 $self->{dbh} = undef;
319 55         78 return 1;
320             }
321              
322             sub show_charsets
323             {
324 0     0 1 0 my ($self) = @_;
325 0         0 eval {require Locale::Recode};
  0         0  
326 0 0       0 die "Locale::Recode is not available. Please install it if you want character set support.\n" if($@);
327 0         0 my $charsets = Locale::Recode->getSupported();
328 0         0 print "\n",(map {" ".$_."\n"} sort @$charsets),"\n";
  0         0  
329 0         0 return 1;
330             }
331              
332             sub show_drivers
333             {
334 2     2 1 14 print "\n",(map {" ".$_."\n"} DBI->available_drivers()),"\n";
  14         1013  
335 2         17 return 1;
336             }
337              
338             sub show_datasources
339             {
340 0     0 1 0 my ($self, $driver) = @_;
341 0         0 print "\n",(map {" ".$_."\n"} DBI->data_sources($driver)),"\n";
  0         0  
342 0         0 return 1;
343             }
344              
345             sub show_dbh
346             {
347 1     1 1 4 my ($self, $property) = @_;
348 1 50       4 my $dbh = $self->_dbh() or die "Not connected to database.\n";
349 0         0 $self->render_rowset([$property], [[$dbh->{$property}]]);
350 0         0 return 1;
351             }
352              
353             sub show_schema
354             {
355 0     0 1 0 my $self = shift;
356 0 0       0 my $dbh = $self->_dbh() or die "Not connected to database.\n";
357              
358             #Banner
359 0         0 my($driver, $db, $user) = ($dbh->{Driver}{Name}, $dbh->{Name}, $dbh->{Username});
360 0         0 my $header = ["Schema dump"];
361 0         0 my @data = (
362             ["$driver database $db"],
363             ["connected as $user"],
364             ["on ".localtime()],
365             );
366 0         0 $self->_render_box(\*STDOUT, $header, \@data);
367            
368             #Each table
369 0         0 foreach(_list_tables($dbh))
370             {
371 0         0 print "\n";
372 0         0 $self->_desc_table($_);
373             }
374              
375 0         0 return 1;
376             }
377              
378             # Show the viewable settings:
379             sub show_settings {
380 1     1 1 2 my $self = shift;
381              
382 1         3 my @header = qw{ PARAMETER VALUE };
383 1         2 my @data;
384 1         7 for my $setting (sort keys %viewable_settings) {
385 9         16 my $value = $self->{settings}->{ $viewable_settings{$setting} };
386 9 100       16 $value = '' unless defined $value;
387 9 100       17 if ( exists($boolean_settings{ $viewable_settings{$setting} }) ) {
388 4 100       10 $value = 'on' if $value eq '1';
389 4 100       9 $value = 'off' if $value eq '0';
390             }
391 9 100       14 if ( $setting eq 'escape' ) {
392 1         4 my $mapping = {
393             'ShowWhitespace' => 'show-whitespace',
394             'UriEscape' => 'uri-escape',
395             'EscapeWhitespace' => 'escape-whitespace',
396             '' => 'off'
397             };
398 1         4 $value = $mapping->{$value};
399             }
400 9         18 push @data, _escape_whitespace([ $setting, $value ]);
401             }
402              
403 1         4 $self->render_rowset(\@header, \@data);
404             }
405              
406              
407             # Show tables, schemas, catalogs, or table-types:
408             sub show_objects {
409 1     1 1 4 my $self = shift;
410 1         2 my $command = shift;
411 1         2 my $object = shift;
412 1         2 my $pattern = shift;
413              
414 1 50       5 $pattern = '%' unless defined $pattern;
415              
416 1 50       4 my $dbh = $self->_dbh() or die "Not connected to database.\n";
417 0         0 my $sth = undef;
418              
419 0 0       0 if ( $object eq 'catalogs' ){
    0          
    0          
    0          
420 0         0 $sth = $dbh->table_info($pattern,'','','');
421 0         0 $self->_list_object_attrib($sth, 'TABLE_CAT');
422             }
423             elsif ( $object eq 'schemas' ) {
424 0         0 $sth = $dbh->table_info('',$pattern,'','');
425 0         0 $self->_list_object_attrib($sth, 'TABLE_SCHEM');
426             }
427             elsif ( $object eq 'tables' ) {
428 0 0       0 if ( $pattern eq '%' ) {
429 0         0 $sth = $dbh->table_info();
430             }
431             else {
432 0         0 $sth = $dbh->table_info('','',$pattern,'');
433             }
434 0         0 $self->_list_object_attrib($sth, 'TABLE_NAME');
435             }
436             elsif ( $object eq 'tabletypes' ) {
437 0         0 $sth = $dbh->table_info('','','',$pattern);
438 0         0 $self->_list_object_attrib($sth, 'TABLE_TYPE');
439             }
440              
441 0         0 return 1;
442             }
443              
444             sub show_tablecounts
445             {
446 1     1 1 4 my $self = shift;
447 1 50       4 my $dbh = $self->_dbh() or die "Not connected to database.\n";
448 0         0 $self->render_rowset([qw(table rows)], _summarise_tables($dbh));
449 0         0 return 1;
450             }
451              
452             sub describe
453             {
454 1     1 1 4 my ($self, $table) = @_;
455 1 50       4 my $dbh = $self->_dbh() or die "Not connected to database.\n";
456              
457 0         0 $self->_desc_table($table);
458 0         0 return 1;
459             }
460              
461             sub run_query
462             {
463 1     1 1 5 my ($self, $query) = @_;
464 1 50       4 my $dbh = $self->_dbh() or die "Not connected to database.\n";
465              
466             # Remove the "recv" command, as it is not really a SQL keyword:
467             # (it is there so we can pull data from non-select commands)
468 0 0       0 $query =~ s/^recv\s+//gis if $query =~ m/^recv\s+/gis;
469            
470 0         0 my $settings = $self->{settings};
471 0         0 my($headers, $data) = $self->_execute_query($query);
472 0         0 $self->render_rowset($headers, $data);
473 0 0 0     0 if (defined $settings->{LogLevel} && ($settings->{LogLevel} eq 'queries' || $settings->{LogLevel} eq 'all')) {
      0        
474 0         0 $self->log_rowset($headers, $data);
475             }
476 0         0 return 1;
477             }
478              
479             sub do_sql
480             {
481 0     0 1 0 my ($self, $statement) = @_;
482 0 0       0 my $dbh = $self->_dbh() or die "Not connected to database.\n";
483              
484             # Remove the "send" command, as it is not really a SQL keyword:
485             # (it is there so we can submit commands that would be interpereted by the shell)
486 0 0       0 $statement =~ s/^send\s+//gis if $statement =~ m/^send\s+/gis;
487              
488 0         0 my $rows = $dbh->do($statement);
489 0 0       0 $rows = 0 if $rows eq '0E0';
490              
491 0         0 my $cmd = (split /\s+/, $statement)[0];
492 0 0       0 my $obj =
    0          
    0          
    0          
    0          
493             scalar $cmd =~ /(create|alter|drop)/? ($statement =~ /$1\s+(\S+\s+\S+?)\b/i)[0]
494             : $cmd eq 'insert' ? ($statement =~ /into\s+(\S+?)\b/)[0]
495             : $cmd eq 'select' ? ($statement =~ /into\s+(\S+?)\b/)[0]
496             : $cmd eq 'update' ? ($statement =~/\s+(\S+?)\b/)[0]
497             : $cmd eq 'delete' ? ($statement =~/from\s+(\S+?)\b/)[0]
498             : ''
499             ;
500              
501 0 0 0     0 print "\U$cmd\E $obj: $rows rows affected\n\n" unless($rows == -1 && !$self->{settings}{Verbose});
502 0         0 return 1;
503             }
504              
505             sub begin_work
506             {
507 1     1 1 2 my $self = shift;
508 1 50       3 my $dbh = $self->_dbh() or die "Not connected to database.\n";
509 0         0 $dbh->begin_work;
510 0         0 return 1;
511             }
512              
513             sub commit
514             {
515 1     1 1 3 my $self = shift;
516 1 50       3 my $dbh = $self->_dbh() or die "Not connected to database.\n";
517 0         0 $dbh->commit;
518 0         0 return 1;
519             }
520              
521             sub rollback
522             {
523 1     1 1 2 my $self = shift;
524 1 50       5 my $dbh = $self->_dbh() or die "Not connected to database.\n";
525 0         0 $dbh->rollback;
526 0         0 return 1;
527             }
528              
529             sub wipe_tables
530             {
531 0     0 1 0 my $self = shift;
532 0 0       0 my $dbh = $self->_dbh() or die "Not connected to database.\n";
533 0         0 my @tables = _list_tables($dbh);
534              
535 0 0       0 if($self->{settings}{Interactive}) {
536 0         0 print "Wipe all data from:\n\n",(map {" ".$_."\n"} @tables),"\nAre you sure you want to do this? (type 'yes' if you are) ";
  0         0  
537 0         0 my $response = ;
538 0         0 chomp $response;
539 0 0       0 return 0 unless ($response eq 'yes');
540             }
541              
542 0         0 foreach(@tables)
543             {
544 0         0 $dbh->do("delete from $_");
545             }
546 0 0       0 print "\nWiped all data in database\n\n" if($self->{settings}{Verbose});
547 0         0 return 1;
548             }
549              
550             sub load_data
551             {
552 1     1 1 5 my ($self,$filename, $table, $delimiter, $uri_decode, $cf, $ct) = @_;
553 1   50     3 $uri_decode &&= 1; #Force to boolean (concession to command regex)
554 1 50       6 $delimiter = $self->{settings}{Delimiter} unless(defined $delimiter);
555 1 50 33     5 die "You must supply a character set to recode into!\n" if ($cf && !$ct);
556 1 50 33     7 die "You must supply a source character set for recoding\n" if (!$cf && $ct);
557 1 50 33     5 if($cf && $ct) {
558 0         0 require Locale::Recode;
559 0 0       0 die "Unrecognised character set '$cf'\n" if(not Locale::Recode->resolveAlias($cf));
560 0 0       0 die "Unrecognised character set '$ct'\n" if(not Locale::Recode->resolveAlias($ct));
561             }
562 1 50       3 my $dbh = $self->_dbh() or die "Not connected to database.\n";
563            
564 0 0 0     0 print "Using URI::Decode\n" if ($uri_decode && $self->{settings}{Verbose});
565 0         0 my $recoder;
566 0 0       0 if ($cf) {
567 0 0       0 print "Recoding characters from $cf to $ct\n" if ($self->{settings}{Verbose});
568 0         0 require Locale::Recode;
569 0         0 $recoder = new Locale::Recode('from' => $cf, 'to' => $ct);
570             }
571              
572             #Open file
573 0         0 my $file = new IO::File $filename;
574              
575             #Read headers
576 0         0 my $headers = <$file>; chomp $headers;
  0         0  
577 0         0 my @headers = split($delimiter, $headers);
578              
579             #Build SQL from headers
580 0         0 my $sql = "INSERT into $table (".join(",", @headers).") VALUES (".join(",", map{"?"} @headers).")";
  0         0  
581 0         0 my $sth = $dbh->prepare_cached($sql);
582              
583             #Load data from file
584 0         0 my $counter = 0;
585 0         0 while(<$file>)
586             {
587 0         0 chomp;
588 0         0 my @row = split($delimiter, $_);
589 0 0       0 die "Error: more values in row ".join(",",@row)." than there are headers (".join(",",@headers)."). Aborting load\n" if(scalar @row > scalar @headers);
590              
591             #Fill in short rows with nulls
592 0         0 while(scalar @row < scalar @headers) {
593 0         0 push @row, undef;
594             }
595              
596             #Perform encoding conversions
597 0 0       0 @row = _recode($recoder, @row) if ($recoder);
598 0 0       0 @row = map {uri_unescape($_)} @row if ($uri_decode);
  0         0  
599              
600             #Insert data
601 0         0 eval {
602 0         0 $sth->execute(@row);
603             };
604 0 0       0 die("Error executing $sql with params (" . join(",", @row) . ") at line $. in $filename - $@") if($@);
605              
606 0         0 $counter++;
607             }
608              
609 0 0       0 print "Loaded $counter rows into $table from $filename\n" if($self->{settings}{Verbose});
610 0         0 return 1;
611             }
612              
613             sub dump_data
614             {
615 1     1 1 3 my ($self, $source, $filename, $delimiter) = @_;
616 1 50       4 my $dbh = $self->_dbh() or die "Not connected to database.\n";
617 0         0 $source =~ s/^\s+//g; $source =~ s/\s+$//g; #Trim any whitespace
  0         0  
618 0 0       0 print "Dumping $source into $filename\n" if($self->{settings}{Verbose});
619 0 0       0 if(lc($source) eq 'all tables')
620             {
621 0         0 my $files = $self->_dump_tables($filename, $delimiter);
622 0 0       0 print "Dumped ".scalar(@$files)." tables into $filename:\n" if($self->{settings}{Verbose});
623 0         0 print map {" - $_\n"} @$files;
  0         0  
624             }
625             else
626             {
627 0         0 my $count = $self->_dump_data($source, $filename, $delimiter);
628 0 0       0 print "Dumped $count rows into $filename\n" if($self->{settings}{Verbose});
629             }
630 0         0 return 1;
631             }
632              
633             sub set_param
634             {
635 12     12 1 27 my ($self,$param, $mode) = @_;
636 12         40 TRACE("set $param=$mode");
637 12         20 my $settings = $self->{settings};
638 12         22 my $dbh = $self->_dbh;
639            
640 12         20 my $valid = 1;
641 12 100       70 if($param eq 'display-mode')
    100          
    100          
    100          
    50          
    100          
    100          
    100          
    100          
    100          
    100          
642             {
643 2 100       10 die sprintf "'$mode' is an invalid value for display-mode. Valid values are %s\n", join(", ", sort keys %{$self->{renderers}}) unless (exists $self->{renderers}{$mode});
  1         15  
644 1         4 $settings->{Renderer} = $self->{renderers}{$mode};
645             }
646             elsif($param eq 'log-mode')
647             {
648 1 50       7 die sprintf "'$mode' is an invalid value for log-mode. Valid values are %s\n", join(", ", sort keys %{$self->{renderers}}) unless(exists $self->{renderers}{$mode});
  1         14  
649 0         0 $settings->{Logger} = $self->{renderers}{$mode};
650             }
651             elsif($param eq 'escape')
652             {
653 1 50       14 die("'$mode' is an invalid value for escape should be (off, uri-escape, show-whitespace or escape-whitespace)") unless $mode =~ /(uri-escape|show-whitespace|escape-whitespace|off)/;
654 0         0 my $mapping = {
655             'show-whitespace' => 'ShowWhitespace',
656             'uri-escape' => 'UriEscape',
657             'escape-whitespace' => 'EscapeWhitespace',
658             'off' => undef
659             };
660 0         0 $settings->{EscapeStrategy} = $mapping->{$mode};
661 0 0       0 print "Escape set to $mode\n" if($settings->{Verbose});
662             }
663             elsif($param eq 'enter-whitespace')
664             {
665 1 50       8 my $_onoff = ($mode =~ /^on$/i) ? 1 : ($mode =~ /^off$/i) ? 0 : undef;
    50          
666 1 50       8 die "'$mode' is an invalid value for enter-whitespace (should be 'on' or 'off')\n" unless(defined $_onoff);
667 0         0 $settings->{EnterWhitespace} = $_onoff;
668 0 0       0 print "Whitespace ".($settings->{EnterWhitespace}?"may":"may not")." be entered as \\n, \\r and \\t\n" if($settings->{Verbose});
    0          
669             }
670             elsif($param eq 'delimiter')
671             {
672 0         0 $settings->{Delimiter} = $mode;
673 0 0       0 print "Delimiter is now '$settings->{Delimiter}'\n" if($settings->{Verbose});
674             }
675             elsif($param eq 'width')
676             {
677 1 50       10 die "'$mode' is an invalid value for width (should be an integer)\n" unless($mode =~ /^\d+$/);
678 0         0 $settings->{Width} = $mode;
679 0 0       0 print "Width is now '$settings->{Width}'\n" if($settings->{Verbose});
680             }
681             elsif($param eq 'auto-commit')
682             {
683 1 50       27 my $_onoff = ($mode =~ /^on$/i) ? 1 : ($mode =~ /^off$/i) ? 0 : undef;
    50          
684 1 50       10 die "'$mode' is an invalid value for auto-commit (should be 'on' or 'off')\n" unless (defined $_onoff);
685 0 0       0 eval {$dbh->{AutoCommit} = $_onoff if _is_connected($dbh) };
  0         0  
686 0 0       0 die "Couldn't set AutoCommit to '$mode' - $@\n" if($@);
687 0 0       0 print "AutoCommit is now '\U$mode\E'\n" if($settings->{Verbose});
688 0         0 $settings->{AutoCommit} = $_onoff;
689             }
690             elsif($param eq 'longreadlen')
691             {
692 1 50       10 die "'$mode' is an invalid value for longreadlen (should be an integer)\n" unless($mode =~ /^\d+$/);
693 0 0       0 eval { $dbh->{LongReadLen} = $mode if _is_connected($dbh) };
  0         0  
694 0 0       0 die "Couldn't set LongReadLen to '$mode' - $@\n" if($@);
695 0 0       0 print "LongReadLen set to '$mode'\n" if($settings->{Verbose});
696 0         0 $settings->{LongReadLen} = $mode;
697             }
698             elsif($param eq 'longtruncok')
699             {
700 1 50       9 my $_onoff = ($mode =~ /^on$/i) ? 1 : ($mode =~ /^off$/i) ? 0 : undef;
    50          
701 1 50       9 die "'$mode' is an invalid value for longtruncok (should be 'on' or 'off')\n" unless (defined $_onoff);
702 0 0       0 eval { $dbh->{LongTruncOk} = $_onoff if _is_connected($dbh) };
  0         0  
703 0 0       0 die "Couldn't set LongTruncOk to '\U$mode\E'\n - $@" if($@);
704 0 0       0 print "LongTruncOk set to '\U$mode\E'\n" if($settings->{Verbose});
705 0         0 $settings->{LongTruncOk} = $_onoff;
706             }
707             elsif($param eq 'multiline')
708             {
709 1 50       9 my $_onoff = ($mode =~ /^on$/i) ? 1 : ($mode =~ /^off$/i) ? 0 : undef;
    50          
710 1 50       8 die "'$mode' is an invalid value for multiline (should be 'on' or 'off')\n" unless (defined $_onoff);
711 0         0 $settings->{MultiLine} = $_onoff;
712             }
713             elsif($param eq 'tracing')
714             {
715 1 50       9 if ($mode =~ /^on$/i) {
    50          
    50          
716 0         0 import Log::Trace("print");
717 0 0       0 print "Log::Trace enabled\n" if($settings->{Verbose});
718             }
719             elsif ($mode =~ /^off$/i) {
720 0         0 import Log::Trace();
721 0 0       0 print "Log::Trace disabled\n" if($settings->{Verbose});
722             }
723             elsif ($mode =~ /^deep$/i) {
724 0         0 import Log::Trace("print" => {Deep => 1});
725 0 0       0 print "Log::Trace enabled with deep import into modules\n" if($settings->{Verbose});
726             }
727             else {
728 1         6 die "'$mode' is an invalid value for tracing (should be 'on', 'deep' or 'off')\n";
729             }
730             }
731             else
732             {
733 1         7 die "Unknown parameter '$param' for set command\n";
734             }
735            
736 1         7 return $valid;
737             }
738              
739              
740             #######################################################################
741             #
742             # Private methods
743             #
744             #######################################################################
745              
746             #
747             # Main worker
748             #
749             sub _execute
750             {
751 33     33   67 my($self, $cmd) = @_;
752 33         40 my $valid = 1;
753            
754             #Convenience vars
755 33         64 my $dbh = $self->_dbh;
756 33         53 my $settings = $self->{settings};
757            
758 33 0 0     67 if (defined $settings->{LogLevel} && ($settings->{LogLevel} eq 'all' || $settings->{LogLevel} eq 'commands'))
      33        
759             {
760 0         0 my $log = $self->{LogFH};
761 0         0 my $dont_log = 0; #May want to extend to allow a list of command regexes to be specified "unsuitable for logging"
762 0 0       0 print $log "$cmd\n" unless($dont_log);
763             }
764              
765 33 50       53 if ($settings->{MultiLine})
766             {
767 0         0 $self->{current_statement} .= $cmd."\n";
768 0 0       0 return 1 unless $self->{current_statement} =~ /;\s*$/s;
769 0         0 $cmd = $self->{current_statement};
770 0         0 $cmd =~ s/\n/ /sg;
771             }
772 33         50 $self->{current_statement} = '';
773              
774 33         444 $cmd =~ s/(?:^\s*|\s*;?\s*$)//g;
775 33 50       88 if($settings->{EnterWhitespace})
776             {
777 0         0 $cmd =~ s/\\n/\n/g;
778 0         0 $cmd =~ s/\\r/\r/g;
779 0         0 $cmd =~ s/\\t/\t/g;
780             }
781              
782             #Command recognition
783 33 50       64 if($cmd)
784             {
785             #Look for command in command table
786 33         38 my $found = 0;
787 33         35 foreach my $regex (keys %{$self->{commands}}) {
  33         193  
788 359         7349 my @args = ($cmd =~ $regex);
789 359 100       938 if(@args) {
790             eval
791 31         74 {
792             #Execute command and convert any true return value to 1
793 31   50     109 $valid = $self->{commands}{$regex}->($self, @args) && 1;
794             };
795 31 100       78 if($@) {
796 22         530 print $@;
797 22         61 $valid = 0;
798             }
799 31         45 $found = 1;
800 31         80 last;
801             }
802             }
803            
804 33 100       134 if(not $found) {
805 2 50       8 my $s = length($cmd)>20? substr($cmd,0,20)."..." : $cmd;
806 2         58 warn "Unrecognised command '$s'\n";
807 2         11 $valid = 0;
808             }
809             }
810            
811 33 100 66     215 $settings->{AddHistory}->($cmd) if($cmd =~ /\S/ && $valid); #Add command to history
812 33         202 return $valid;
813             }
814              
815              
816              
817             #######################################################################
818             #
819             # Renderers
820             #
821             #######################################################################
822              
823             sub _render_delimited
824             {
825 0     0   0 my ($self, $fh, $headers, $data) = @_;
826 0         0 my $delim = $self->{settings}{Delimiter};
827 0         0 print $fh join($delim, @$headers)."\n";
828 0         0 foreach(@$data)
829             {
830 0         0 print $fh join($delim, @$_)."\n";
831             }
832 0         0 print $fh "\n";
833             }
834              
835             sub _render_sql
836             {
837 0     0   0 my ($self, $fh, $headers, $data, $table) = @_;
838 0   0     0 $table ||= '$table';
839 0         0 my $sql = "INSERT into $table (".join("," , @$headers).") VALUES (%s);\n";
840 0         0 my $settings = $self->{settings};
841 0         0 my $dbh = $self->_dbh;
842 0 0       0 local $settings->{NULL} = 'NULL' unless -t $fh;
843 0         0 foreach(@$data)
844             {
845             my @fields = map{
846 0         0 defined() ?
847             DBI::looks_like_number($_) ? $_ : $dbh->quote($_)
848             : $settings->{NULL}
849 0 0       0 } @$_;
    0          
850 0         0 printf $fh $sql, join(",", @fields);
851             }
852 0         0 print $fh "\n";
853             }
854              
855             sub _render_xml
856             {
857 0     0   0 my ($self, $fh, $headers, $data) = @_;
858 0         0 require CGI; #For its markup escaping routine
859 0         0 print $fh "\n";
860 0         0 foreach my $record (@$data)
861             {
862 0         0 print $fh "\t\n";
863             print $fh map {
864 0         0 my $val = shift @$record;
  0         0  
865 0         0 $val = CGI::escapeHTML($val);
866 0         0 "\t\t<$_>$val\n"
867             } @$headers;
868 0         0 print $fh "\t\n";
869             }
870 0         0 print $fh "\n";
871 0         0 print $fh "\n";
872             }
873              
874             sub _render_box
875             {
876 1     1   3 my ($self, $fh, $headers, $data, $table) = @_;
877 1         2 my $settings = $self->{settings};
878 1         3 my $widths = _compute_widths($headers,$data);
879 1     1   8 use constant LD_H => '-';
  1         1  
  1         65  
880 1     1   6 use constant LD_V => '|';
  1         2  
  1         53  
881 1     1   6 use constant LD_X => '+';
  1         1  
  1         3023  
882 1         2 my $line = join(LD_X, map{LD_H x ($_+2)} @$widths);
  2         7  
883 1 50       13 local $settings->{NULL} = 'NULL' unless -t $fh;
884              
885             #Table
886 1 50       3 if($table) {
887 0         0 print $fh LD_X . LD_H x (length $line) . LD_X . "\n";
888 0         0 my $str = " " x int(0.5 * (length($line) - length($table)));
889 0         0 $str .= $table;
890 0         0 $str .= " " x (length($line) - length($str));
891 0         0 print LD_V . $str . LD_V . "\n";
892             }
893              
894             #Headers
895 1         25 print $fh LD_X . $line . LD_X . "\n";
896 1         4 my $str = LD_V;
897 1         5 for(my $l = 0; $l<=$#$headers; $l++)
898             {
899 2         10 $str .= " " . $headers->[$l] . " " x ($widths->[$l] - length($headers->[$l])) . " " . LD_V;
900             }
901 1         12 print $fh $str."\n";
902            
903 1         10 print $fh LD_X . $line . LD_X . "\n";
904              
905             #Data
906 1         4 foreach my $row (@$data)
907             {
908 9         19 my $str = LD_V;
909 9         20 for(my $l = 0; $l<=$#$headers; $l++)
910             {
911 18         25 my $value = $row->[$l];
912 18         17 my $len_val;
913 18 50       25 unless (defined $value) {
914 0         0 $value = $settings->{NULL};
915 0         0 $len_val = 4;
916             } else {
917 18         18 $len_val = length $value;
918             }
919 18         50 $str .= " " . $value . " " x ($widths->[$l] - $len_val) . " " . LD_V;
920             }
921 9         82 print $fh $str."\n";
922             }
923              
924 1         19 print $fh LD_X . $line . LD_X . "\n";
925             }
926              
927             sub _render_spaced
928             {
929 0     0   0 my ($self, $fh, $headers, $data) = @_;
930 0         0 my $widths = _compute_widths($headers,$data);
931 0         0 my $format = join($self->{settings}{Delimiter}, map{"%".$_."s"} @$widths)."\n";
  0         0  
932 0         0 TRACE($format);
933 0         0 printf $fh ($format, @$headers);
934 0         0 foreach(@$data)
935             {
936 0 0       0 printf $fh ($format, map {defined() ? $_ : 'NULL'} @$_);
  0         0  
937             }
938 0         0 print $fh "\n";
939             }
940              
941             sub _render_record
942             {
943 0     0   0 my ($self, $fh, $headers, $data) = @_;
944 0         0 my $settings = $self->{settings};
945 0         0 my $header_width = _max_width($headers);
946 0         0 my $line = (LD_H x $settings->{Width})."\n";
947 0 0       0 local $settings->{NULL} = 'NULL' unless -t $fh;
948 0         0 foreach my $record (@$data)
949             {
950 0         0 print $fh $line;
951 0         0 for(my $l = 0; $l<=$#$headers; $l++)
952             {
953 0         0 my $heading = $headers->[$l] . " " x ($header_width - length($headers->[$l])) . " " . LD_V . " ";
954 0         0 my $str;
955 0 0       0 if($settings->{Width} > length($heading))
956             {
957 0         0 my $room = $settings->{Width} - length($heading);
958 0 0       0 my $text = defined $record->[$l] ? $record->[$l] : $settings->{NULL};
959 0         0 my $segments = length($text)/$room;
960 0         0 for(my $i=0; $i<$segments; $i++)
961             {
962 0         0 $str .= $heading . substr($text,$i*$room,$room) . "\n"
963             }
964             }
965             else
966             {
967 0         0 $str="Terminal too narrow\n";
968             }
969 0         0 print $fh $str;
970             }
971 0         0 print $fh $line."\n";
972             }
973             }
974              
975             #######################################################################
976             #
977             # Misc private methods
978             #
979             #######################################################################
980              
981             #Dump data to a logfile
982             sub _dump_data
983             {
984 0     0   0 my($self, $sql, $filename, $delimiter) = @_;
985 0         0 my $table;
986 0 0       0 unless($sql=~/ /) #If it's just one word treat it as a table name
987             {
988 0         0 $table = $sql;
989 0         0 $sql = "select * from $table"; #Allow just table name to be passed
990             }
991 0         0 my ($headers, $data) = $self->_execute_query($sql);
992 0         0 $filename = _expand_filename($filename);
993 0 0       0 my $fh = new IO::File ">$filename" or die ("Unable to write to $filename - $!");
994 0         0 my $settings = $self->{settings};
995 0         0 my $old_delim = $self->{settings}{Delimiter};
996 0         0 eval {
997 0 0       0 $self->{settings}{Delimiter} = $delimiter if($delimiter);
998 0         0 $settings->{Logger}->($self, $fh, $headers, $data, $table);
999             };
1000 0         0 $self->{settings}{Delimiter} = $old_delim; #restore before raising exception
1001 0 0       0 die($@) if($@); #Rethrow exception
1002 0         0 return scalar(@$data);
1003             }
1004              
1005             #Dump all tables to a directory
1006             sub _dump_tables
1007             {
1008 0     0   0 my($self, $dir, $delimiter) = @_;
1009 0         0 $dir = _expand_filename($dir);
1010 0 0       0 mkpath($dir) if(! -e $dir);
1011 0         0 my @files;
1012 0         0 foreach(_list_tables($self->_dbh))
1013             {
1014 0         0 my $filename = $dir."/".$_.".dat";
1015 0         0 push @files, $filename;
1016 0         0 $self->_dump_data($_, $filename, $delimiter);
1017             }
1018 0         0 return \@files;
1019             }
1020              
1021             sub _execute_query
1022             {
1023 0     0   0 my ($self, $sql) = @_;
1024              
1025             #Place to hang future logic for memory-saving database cursors
1026 0         0 my $class = "Tie::Rowset::InMemory";
1027 0         0 TRACE("Executing $sql using $class");
1028              
1029             #Get a handle onto the data that looks like an array of arrays
1030 0         0 my @data;
1031 0         0 my $dbh = $self->_dbh;
1032 0         0 tie @data, $class, $dbh, $sql, {Type => 'Array'};
1033 0         0 my $object = tied @data;
1034 0         0 my $headers = $object->column_names();
1035              
1036             #Attach filter for escaping data as it's accessed
1037 0         0 my $settings = $self->{settings};
1038 0 0       0 if($settings->{EscapeStrategy} eq "EscapeWhitespace")
1039             {
1040 0         0 _escape_whitespace($headers);
1041 0         0 $object->filter(\&_escape_whitespace); #install a filter on the tied rowset
1042             }
1043 0 0       0 if($settings->{EscapeStrategy} eq "ShowWhitespace")
    0          
1044             {
1045 0         0 _show_whitespace($headers);
1046 0         0 $object->filter(\&_show_whitespace); #install a filter on the tied rowset
1047             }
1048             elsif($settings->{EscapeStrategy} eq "UriEscape")
1049             {
1050 0         0 _uri_escape($headers);
1051 0         0 $object->filter(\&_uri_escape); #install a filter on the tied rowset
1052             }
1053              
1054 0         0 return($headers, \@data);
1055             }
1056              
1057             sub _desc_table
1058             {
1059 0     0   0 my ($self, $table) = @_;
1060 0         0 my $dbh = $self->_dbh;
1061 0         0 my $driver = $dbh->{Driver}->{Name};
1062 0         0 my ($headers, $data);
1063 0 0       0 if($driver eq 'mysql')
1064             {
1065 0         0 ($headers, $data) = $self->_execute_query("desc $table");
1066             }
1067             else
1068             {
1069 0         0 $data = _deduce_columns($dbh,$table);
1070 0         0 $headers=['Field','Type','Null'];
1071             }
1072 0         0 my $settings = $self->{settings};
1073 0         0 $self->render_rowset($headers, $data, $table);
1074 0 0 0     0 $self->log_rowset($headers, $data, $table) if($settings->{LogLevel} eq 'queries' || $settings->{LogLevel} eq 'all');
1075             }
1076              
1077             sub _dbh
1078             {
1079 55     55   84 my $self = shift;
1080 55 50       117 if(_is_connected($self->{dbh})) {
1081 0         0 return $self->{dbh};
1082             } else {
1083 55         109 $self->disconnect();
1084 55         142 return undef;
1085             }
1086             }
1087              
1088             #######################################################################
1089             #
1090             # Private routines
1091             #
1092             #######################################################################
1093              
1094             sub _renderer {
1095 2     2   5 my $renderer = shift;
1096 2 50 33     5 if(defined $renderer && ref $renderer ne 'CODE') {
1097 0   0     0 $renderer = $Renderers{$renderer} || die("Unrecognised renderer: $renderer\n");
1098             }
1099 2         44 return $renderer;
1100             }
1101              
1102             sub _is_connected
1103             {
1104 111 50 33 111   283 if(defined $_[0] && ref $_[0] && UNIVERSAL::isa($_[0], 'DBI::db') && $_[0]->ping) {
      33        
      0        
1105 0         0 return 1;
1106             } else {
1107 111         354 return 0;
1108             }
1109             }
1110              
1111             #
1112             # Table manipulation
1113             #
1114              
1115             #List tables and their size
1116             sub _summarise_tables
1117             {
1118 0     0   0 my($dbh) = @_;
1119 0         0 my @results;
1120 0         0 foreach my $table(_list_tables($dbh))
1121             {
1122 0         0 my $sth = $dbh->prepare("select count(*) from $table");
1123 0         0 $sth->execute();
1124 0         0 my ($rows) = $sth->fetchrow_array();
1125 0         0 push @results,[$table, $rows];
1126             }
1127 0         0 return \@results;
1128             }
1129              
1130             sub _list_tables
1131             {
1132 0     0   0 my($dbh) = @_;
1133 0         0 my $driver = $dbh->{Driver}->{Name};
1134 0 0       0 if($driver eq 'Oracle')
1135             {
1136 0         0 my $sth = $dbh->prepare("select table_name from cat where table_type=?");
1137 0         0 $sth->execute('TABLE');
1138 0         0 my $tables = $sth->fetchall_arrayref();
1139 0         0 return map {$_->[0]} @$tables;
  0         0  
1140             }
1141             else
1142             {
1143             #Generic DBI function
1144 0         0 return $dbh->tables();
1145             }
1146             }
1147              
1148              
1149             sub _deduce_columns
1150             {
1151 0     0   0 my ($dbh,$table) = @_;
1152 0         0 my $sth = $dbh->prepare("select * from $table where 0=1");
1153 0         0 $sth->execute();
1154 0         0 my @names = @{$sth->{NAME}};
  0         0  
1155 0         0 my (@types, @nullable);
1156             eval
1157 0         0 {
1158 0         0 my @null = ("NO","YES","");
1159 0         0 my @type_codes = @{$sth->{TYPE}};
  0         0  
1160 0         0 my @precision = @{$sth->{PRECISION}};
  0         0  
1161 0         0 @nullable = map{$null[$_]} @{$sth->{NULLABLE}};
  0         0  
  0         0  
1162 0         0 $sth->finish;
1163              
1164 0         0 foreach(@type_codes)
1165             {
1166 0         0 my $info = $dbh->type_info($_);
1167 0         0 my $type = $info->{TYPE_NAME};
1168 0         0 my $precision = shift @precision;
1169 0 0       0 $type.="($precision)" if(defined $precision);
1170 0         0 push @types, $type;
1171             }
1172             };
1173 0         0 my @data = map {[$_, shift @types, shift @nullable]} @names;
  0         0  
1174 0         0 return \@data;
1175             }
1176              
1177             # Pull and render attributes from an active statement handle.
1178             # A helper routine for show_objects()
1179             sub _list_object_attrib {
1180 0     0   0 my $self = shift;
1181 0         0 my $sth = shift;
1182 0         0 my $attrib = shift;
1183              
1184 0         0 my @header;
1185             my @data;
1186              
1187 0 0       0 if ( $attrib eq 'TABLE_NAME' ) {
1188 0         0 @header = qw{ TABLE_CAT TABLE_SCHEM TABLE_NAME TABLE_TYPE REMARKS };
1189 0         0 while (my $row = $sth->fetchrow_hashref('NAME_uc')) {
1190 0         0 my @data_row = map { $row->{$_} } @header;
  0         0  
1191 0         0 push @data, \@data_row;
1192             }
1193             }
1194             else {
1195 0         0 @header = ( $attrib );
1196 0         0 my $hash_ref = $sth->fetchall_hashref($attrib);
1197 0         0 @data = map { [ $_ ] } sort keys %{ $hash_ref };
  0         0  
  0         0  
1198             }
1199              
1200 0         0 $self->render_rowset(\@header, \@data);
1201            
1202             }
1203              
1204             #
1205             # History
1206             #
1207             sub _load_history {
1208 1     1   2 my $filename = shift;
1209 1         2 local *FH;
1210 1         2 my @hist;
1211 1 50       3 open (FH, _expand_filename($filename)) or die("Unable to load history from $filename - $!");
1212 1         16 while () {
1213 2         6 chomp; push @hist, $_;
  2         10  
1214             }
1215 1         9 close FH;
1216 1         14 TRACE("Loaded ".scalar @hist." items from $filename");
1217 1         5 return \@hist;
1218             }
1219              
1220             sub _save_history {
1221 1     1   2 my $history = shift;
1222 1   50     4 my $filename = shift || die("You must specify a file to save the history to");
1223 1   50     4 my $max_size = shift || HISTORY_SIZE;
1224 1 50       3 my $max_hist = scalar @$history >= $max_size ? $max_size : scalar @$history;
1225 1         5 TRACE("Saving $max_hist items to $filename");
1226 1         5 my @hist = @$history[-$max_hist..-1];
1227 1         3 local *FH;
1228 1 50       5 open (FH, "> " . _expand_filename($filename)) or die("Unable to save history to $filename - $!");
1229 1         11 print FH $_, $/ for @hist;
1230 1         31 close FH;
1231             }
1232              
1233             sub _recode
1234             {
1235 0     0   0 my ($recoder, @rows) = @_;
1236 0         0 foreach (@rows)
1237             {
1238 0         0 my $init = $_;
1239 0 0       0 die $recoder->getError if $recoder->getError;
1240 0 0       0 $recoder->recode($_) or die $recoder->getError;
1241 0         0 TRACE("recoded FROM [$init] to [$_]");
1242             }
1243 0         0 return @rows;
1244             }
1245              
1246             sub _escape_whitespace
1247             {
1248 9     9   11 my $row = shift;
1249 9         12 foreach(@$row)
1250             {
1251 18         22 s/\r/\\r/g;
1252 18         18 s/\n/\\n/g;
1253 18         23 s/\t/\\t/g;
1254             }
1255 9         17 return $row;
1256             }
1257              
1258             sub _show_whitespace
1259             {
1260 0     0   0 my $row = shift;
1261 0         0 $row = _escape_whitespace($row);
1262 0         0 foreach(@$row)
1263             {
1264 0         0 s/ /./g; #Also convert spaces to dots
1265             }
1266 0         0 return $row;
1267             }
1268              
1269             sub _uri_escape
1270             {
1271 0     0   0 my $row = shift;
1272 0         0 my @new = map {uri_escape($_)} @$row;
  0         0  
1273 0         0 return \@new;
1274             }
1275              
1276             sub _compute_widths
1277             {
1278 1     1   2 my ($headers,$data) = @_;
1279 1         3 my @widths = map {length $_} @$headers;
  2         4  
1280 1         3 foreach my $row(@$data)
1281             {
1282 9         14 for(0..$#widths)
1283             {
1284 18 50       22 my $len = defined $row->[$_] ? length($row->[$_]) : length 'NULL';
1285 18 100       33 $widths[$_] = $len if($len > $widths[$_]);
1286             }
1287             }
1288 1         3 return \@widths;
1289             }
1290              
1291             sub _max_width
1292             {
1293 0     0   0 my ($list) = @_;
1294 0         0 my $width = 0;
1295 0         0 foreach (@$list)
1296             {
1297 0         0 my $len = length($_);
1298 0 0       0 $width = $len if($len > $width);
1299             }
1300 0         0 return $width;
1301             }
1302              
1303              
1304             sub _expand_filename {
1305 3     3   7 my $file = shift;
1306 3 50       10 if ($file =~ s/^~([^\/]*)//)
1307             {
1308 0 0       0 my $home = $1 ? ((getpwnam ($1)) [7]) : $ENV{HOME};
1309 0         0 $file = $home . $file;
1310             }
1311 3         105 return $file;
1312             }
1313              
1314             # stubs for Log::Trace
1315       17 0   sub TRACE{}
1316       0 0   sub DUMP{}
1317              
1318             ############################################################################################
1319             #
1320             # Inlined package for the time being whilst Tie::Rowset is being worked on
1321             #
1322             ############################################################################################
1323              
1324             package Tie::Rowset::InMemory;
1325              
1326 1     1   8 use strict;
  1         2  
  1         21  
1327 1     1   4 use Carp;
  1         2  
  1         776  
1328              
1329             ##############################################
1330             # TIE interface
1331             ##############################################
1332              
1333             sub TIEARRAY
1334             {
1335 0     0     my ($class, $dbh, $sql, $options) = @_;
1336 0 0         $options = {} unless defined $options;
1337 0           my $params = $options->{params};
1338             my $self = {
1339             'dbh' => $dbh,
1340             'sql' => $sql,
1341             'params' => defined $params? $params : [],
1342             'type' => $options->{Type} || 'Hash',
1343             'filter' => $options->{Filter},
1344 0 0 0       'count' => undef,
1345             };
1346 0           bless $self, $class;
1347 0           TRACE(__PACKAGE__." constructor");
1348 0           return $self;
1349             }
1350              
1351             sub DESTROY
1352             {
1353 0     0     my $self = shift;
1354 0 0         $self->{sth}->finish() if defined($self->{sth});
1355             }
1356              
1357             sub FETCH
1358             {
1359 0     0     my ($self, $index) = @_;
1360 0           TRACE("FETCH $index");
1361 0 0         $self->_execute_query() unless $self->{data};
1362 0 0         croak("index $index is out of bounds - rowset only has " . scalar @{$self->{data}}." elements") if($index+1 > scalar @{$self->{data}});
  0            
  0            
1363 0           my $rv = $self->{data}->[$index];
1364 0 0         $rv = $self->{filter}->($rv) if defined $self->{filter}; #optionally filter
1365 0           DUMP("Fetch $index", $rv);
1366 0           return $rv;
1367             }
1368              
1369             sub FETCHSIZE
1370             {
1371 0     0     my $self = shift;
1372 0 0         $self->_execute_query() unless $self->{data};
1373 0           TRACE("Fetch size - " . scalar @{$self->{data}});
  0            
1374 0           return scalar @{$self->{data}};
  0            
1375             }
1376              
1377             ##############################################
1378             # Non-tied OO interface (access via tied)
1379             ##############################################
1380              
1381             sub column_names
1382             {
1383 0     0     my $self = shift;
1384 0 0         $self->_execute_query() unless $self->{headers};
1385 0           return $self->{headers};
1386             }
1387              
1388             sub filter
1389             {
1390 0     0     my ($self, $filter) = @_;
1391 0 0         $self->{filter} = $filter if defined($filter);
1392 0           return $self->{filter};
1393             }
1394              
1395             ##############################################
1396             # private methods
1397             ##############################################
1398              
1399             sub _execute_query
1400             {
1401 0     0     my $self = shift;
1402             eval
1403 0           {
1404 0           my $sth = $self->{dbh}->prepare($self->{sql});
1405 0           $sth->execute(@{$self->{params}});
  0            
1406 0           $self->{headers} = $sth->{NAME};
1407 0 0         if($self->{type} eq 'Array') {
1408 0           $self->{data} = $sth->fetchall_arrayref();
1409             } else {
1410 0           my @loh;
1411 0           while(my $hashref = $sth->fetchrow_hashref)
1412             {
1413 0           push @loh, { %$hashref };
1414             }
1415 0           $self->{data} = \@loh;
1416             }
1417             };
1418 0 0         if($@)
1419             {
1420 0           $@ =~ s/\n$//;
1421 0           die("$@ sql=$self->{sql}"); #Decorate error messages with SQL
1422             }
1423             }
1424              
1425             # stubs for Log::Trace
1426       0     sub TRACE{}
1427       0     sub DUMP{}
1428              
1429              
1430             =head1 NAME
1431              
1432             SQL::Shell - command interpreter for DBI shells
1433              
1434             =head1 SYNOPSIS
1435              
1436             use SQL::Shell;
1437            
1438             #Initialise and configure
1439             my $sqlsh = new SQL::Shell(\%settings);
1440             $sqlsh->set($setting, $new_value);
1441             $value = $sqlsh->get($setting);
1442            
1443             #Interpret commands
1444             $sqlsh->execute_command($command);
1445             $sqlsh->run_script($filename);
1446              
1447             =head1 DESCRIPTION
1448              
1449             SQL::Shell is a command-interpreter API for building shells and batch scripts.
1450             A command-line interface with readline support - sqlsh.pl - is included as part of the CPAN distribution. See for a user guide.
1451              
1452             SQL::Shell offers features similar to the mysql or sql*plus client programs but is database independent.
1453             The default command syntax is arguably more user-friendly than dbish not requiring any go, do or slashes to fire SQL statements at the database.
1454              
1455             Features include:
1456              
1457             =over 4
1458              
1459             =item * issuing common SQL statements by simply typing them
1460              
1461             =item * command history
1462              
1463             =item * listing drivers, datasources, tables
1464              
1465             =item * describing a table or the entire schema
1466              
1467             =item * dumping and loading data to/from delimited text files
1468              
1469             =item * character set conversion when loading data
1470              
1471             =item * logging of queries, results or all commands to file
1472              
1473             =item * a number of formats for display/logging data (sql, xml, delimited, boxed)
1474              
1475             =item * executing a series of commands from a file
1476              
1477             =back
1478              
1479             You can also install custom commands, rendering formats and command history mechanisms.
1480             All the commands run by the interpreter are available via the API so if you don't like the default command syntax you can replace the command regexes with your own.
1481            
1482             It's been developed and used in anger with Oracle and mysql but should work with any database with a DBD:: driver.
1483              
1484             =head1 METHODS
1485              
1486             =over 4
1487              
1488             =item $sqlsh = new SQL::Shell(\%settings);
1489              
1490             Constructs a new object and initialises it with a set of settings.
1491             See L for a complete list.
1492              
1493             =item $sqlsh->set($setting, $new_value)
1494              
1495             Changes a setting once the object has been constructed.
1496             See L for a complete list.
1497              
1498             =item $value = $sqlsh->get($setting)
1499              
1500             Fetches a setting.
1501             See L for a complete list.
1502              
1503             =back
1504              
1505             =head2 Commands
1506              
1507             =over 4
1508              
1509             =item $sqlsh->execute_cmd($command)
1510              
1511             Executes a command ($command is a string).
1512              
1513             Returns 1 if the command was successful.
1514             Returns 0 if the command was unsuccessful.
1515              
1516             =item $sqlsh->run_script($filename)
1517              
1518             Executes a sequence of commands in a file.
1519             Dies if there is a problem.
1520              
1521             =item $sqlsh->install_cmds(\%additional_commands)
1522              
1523             %additional_commands should contain a mapping of regex to coderef.
1524             See L for more information.
1525              
1526             =item $sqlsh->uninstall_cmds(\@commands)
1527              
1528             @additional_commands should contain a list of regexes to remove.
1529             If uninstall_cmds is called with no arguments, all commands will be uninstalled.
1530              
1531             =item $sqlsh->set_param($param, $value)
1532              
1533             Equivalent to the "set " command.
1534             In many cases this will affect the internal settings accessible through the C and C methods.
1535              
1536             =back
1537              
1538             =head2 Renderers
1539              
1540             =over 4
1541              
1542             =item $sqlsh->install_renderers(\%additional_renderers)
1543              
1544             %additional_renderers should contain a mapping of renderer name to coderef.
1545             See L for more information.
1546              
1547             =item $sqlsh->uninstall_renderers(\@renderers)
1548              
1549             @renderers should contain a list of renderer names to remove.
1550             If uninstall_renderers is called with no arguments, all renderers will be uninstalled.
1551              
1552             =item $sqlsh->render_rowset(\@headers, \@data, $table)
1553              
1554             Calls the current renderer (writes to STDOUT)
1555              
1556             =item $sqlsh->log_rowset(\@headers, \@data, $table)
1557              
1558             Calls the current logger
1559              
1560             =back
1561              
1562             =head2 Database connection
1563              
1564             =over 4
1565              
1566             =item $dsn = $sqlsh->connect($dsn, $user, $pass)
1567              
1568             Connects to a DBI datasource.
1569             Equivalent to issuing the "connect $dsn $user $pass" command.
1570              
1571             =item $sqlsh->disconnect()
1572              
1573             Disconnects if connected.
1574             Equivalent to issuing the "disconnect" command.
1575              
1576             =item $bool = $sqlsh->is_connected()
1577              
1578             Check if we're connected to the database.
1579              
1580             =item $string = $sqlsh->dsn()
1581              
1582             The datasource we're currently connected as - undef if not connected.
1583              
1584             =back
1585              
1586             =head2 History manipulation
1587              
1588             =over 4
1589              
1590             =item $arrayref = $sqlsh->load_history($filename)
1591              
1592             Loads a sequence of commands from a file into the command history.
1593             Equivalent to "load history from $filename".
1594              
1595             =item $sqlsh->clear_history()
1596              
1597             Clears the command history.
1598             Equivalent to "clear history".
1599              
1600             =item $sqlsh->save_history($filename, $size)
1601              
1602             Saves the command history to a file in a format suitable for C and C.
1603             Equivalent to "save history to $filename", except the maximum number of items can be specified.
1604             $size is optional - if not specified defaults to the MaxHistory setting.
1605              
1606             =item $sqlsh->show_history()
1607              
1608             Displays the command history.
1609             Equivalent to "show history".
1610              
1611             =back
1612              
1613             =head2 Logging
1614              
1615             =over 4
1616              
1617             =item $sqlsh->enable_logging($level, $file)
1618              
1619             Enables logging to a file.
1620             $level should be all, queries or commands.
1621             Equivalent to "log $level $file".
1622              
1623             =item $sqlsh->disable_logging()
1624              
1625             Disables logging to a file.
1626             Equivalent to "no log".
1627              
1628             =back
1629              
1630             =head2 Querying
1631              
1632             =over 4
1633              
1634             =item $sqlsh->show_drivers()
1635              
1636             Outputs a list of database drivers. Equivalent to "show drivers".
1637              
1638             =item $sqlsh->show_datasources($driver)
1639              
1640             Outputs a list of datasources for a driver. Equivalent to "show datasources $driver".
1641              
1642             =item $sqlsh->show_dbh($property)
1643              
1644             Outputs a property of a database handle. Equivalent to "show \$dbh $property".
1645              
1646             =item $sqlsh->show_schema()
1647              
1648             Equivalent to "show schema".
1649              
1650             =item $sqlsh->show_objects()
1651              
1652             Displays a list of tables, schemas, catalogs or table-types depending on the
1653             object argument passed.
1654              
1655             =item $sqlsh->show_tablecounts()
1656              
1657             Displays a list of tables with row counts. Equivalent to "show tablecounts".
1658              
1659             =item $sqlsh->show_settings()
1660              
1661             Displays a list of internal C settings. Equivalent to "show
1662             settings". Not all internal settings are included here yet.
1663              
1664             =item $sqlsh->describe($table)
1665              
1666             Displays the columns in the table. Equivalent to "describe $table".
1667              
1668             =item $sqlsh->run_query($sql)
1669              
1670             Displays the rowset returned by the query. Equivalent to execute_cmd with a select or explain statement.
1671              
1672             =back
1673              
1674             =head2 Modifying data
1675              
1676             =over 4
1677              
1678             =item $sqlsh->do_sql($sql)
1679              
1680             Executes a SQL statement that modifies the database. Equivalent to execute_cmd with a DML or DDL statement.
1681              
1682             =item $sqlsh->begin_work()
1683              
1684             Starts a transaction. Equivalent to "begin work".
1685              
1686             =item $sqlsh->commit()
1687              
1688             Commits a transaction. Equivalent to "commit".
1689              
1690             =item $sqlsh->rollback()
1691              
1692             Rolls back a transaction. Equivalent to "rollback".
1693              
1694             =item $sqlsh->wipe_tables()
1695              
1696             Blanks all the tables in the database.
1697             Will prompt for confirmation if the Interactive setting is enabled.
1698             Equivalent to "wipe tables".
1699              
1700             =back
1701              
1702             =head2 Loading and dumping data
1703              
1704             =over 4
1705              
1706             =item $sqlsh->dump_data($source, $filename, $delimiter)
1707              
1708             Dumps data from a table or query into a delimited file.
1709             $source should either be a table name or a select query.
1710             This is equivalent to the "dump data" command.
1711              
1712             =item $sqlsh->load_data($filename, $table, $delimiter, $uri_decode, $charset_from, $charset_to)
1713              
1714             Loads data from a delimited file into a database table.
1715             $uri_decode is a boolean value - if true the data will be URI-decoded before being inserted.
1716             $charset_from and $charset_to are character set names understood by Locale::Recode.
1717             This is equivalent to the "load data" command.
1718              
1719             =item $sqlsh->show_charsets()
1720              
1721             Lists the character sets supported by the recoding feature of "load data". Equivalent to "show charsets".
1722              
1723             =back
1724              
1725             =head1 CUSTOMISING
1726              
1727             =head2 INSTALLING CUSTOM COMMANDS
1728              
1729             The coderef will be passed the $sqlsh object followed by each argument captured by the regex.
1730              
1731             my %additional_commands = (
1732             qr/^hello from (\.*)/ => sub {
1733             my ($self, $name) = @_;
1734             print "hi there $name\n";
1735             });
1736              
1737             To install this:
1738              
1739             $sqlsh->install_cmds(\%additional_commands)
1740              
1741             Then in sqlsh:
1742              
1743             > hello from John
1744             hi there John
1745              
1746             =head2 INSTALLING CUSTOM RENDERERS
1747              
1748             Renderers are coderefs which are passed the following arguments:
1749              
1750             $sqlsh - the SQL::Shell object
1751             $fh - the filehandle to render to
1752             $headers - an arrayref of column headings
1753             $data - an arrayref of arrays containing the data (row major)
1754             $table - the name of the table being rendered (not defined in all contexts)
1755              
1756             Here's an example to render data in CSV format:
1757              
1758             sub my_renderer {
1759             my ($sqlsh, $fh, $headers, $data, $table) = @_;
1760             my $delim = ",";
1761             print $fh "#Dump of $table" if($table); #Assuming our CSV format support #-style comments
1762             print $fh join($delim, @$headers)."\n";
1763             foreach my $row (@$data)
1764             {
1765             print $fh join($delim, @$row)."\n";
1766             }
1767             }
1768              
1769             To install this:
1770              
1771             $sqlsh->install_renderers({'csv' => \&my_renderer});
1772              
1773             Then in sqlsh:
1774              
1775             > set display-mode csv
1776              
1777             =head2 INSTALLING A CUSTOM HISTORY MECHANISM
1778              
1779             You can install a custom history recording mechanism by overriding the GetHistory, SetHistory and AddHistory callbacks which should take the following arguments and return values:
1780              
1781             =over 4
1782              
1783             =item $arrayref = $GetHistorySub->()
1784              
1785             =item $SetHistorySub->($arrayref)
1786              
1787             =item $AddHistorySub->($string)
1788              
1789             =back
1790              
1791             An example:
1792              
1793             my $term = new Term::ReadLine "My Shell";
1794             my $autohistory = $term->Features()->{autohistory};
1795             my $sqlsh = new SQL::Shell({
1796             'GetHistory' => sub {[$term->GetHistory()]});
1797             'SetHistory' => sub {my $history = shift; $term->SetHistory(@$history)});
1798             'AddHistory' => sub {my $cmd = shift; $term->addhistory($cmd) if !$autohistory});
1799             });
1800              
1801             =head1 SETTINGS
1802              
1803             The following settings can only be set through the constructor or the C method:
1804              
1805             NAME DESCRIPTION DEFAULT
1806             GetHistory Callback to fetch history sub {return \@history}
1807             SetHistory Callback to set history sub {my $n = shift; @history = @$n}
1808             AddHistory Callback to add cmd to history sub {push @history, shift()}
1809             MaxHistory Maximum length of history to save $ENV{HISTSIZE} || $ENV{HISTFILESIZE} || 50
1810             Interactive Should SQL::Shell ask questions? 0
1811             Verbose Should SQL::Shell print messages? 0
1812             NULL How to display null values NULL
1813              
1814             The following are also affected by the C method or the "set" command:
1815              
1816             NAME DESCRIPTION DEFAULT
1817             Renderer Current renderer for screen \&_render_box
1818             Logger Current renderer for logfile \&_render_delimited
1819             Delimiter Delimiter for delimited format \t
1820             Width Width used for record display 80
1821             LogLevel Log what? all|commands|queries undef
1822             EscapeStrategy UriEscape|EscapeWhitespace|ShowWhitespace undef
1823             AutoCommit Commit each statement 0
1824             LongTruncOk OK to truncate LONG datatypes? 1
1825             LongReadLen Amount read from LONG datatypes 512
1826             MultiLine Allows multiline sql statements 0
1827              
1828             =head1 COMMANDS
1829            
1830             show drivers
1831             show datasources
1832             connect [ ] - connect to DBI DSN
1833             disconnect - disconnect from the DB
1834            
1835             show tables - display a list of tables
1836             show catalogs - display a list of catalogs
1837             show schemas - display a list of schemas
1838             show tabletypes - display a list of tabletypes
1839             show schema - display the entire schema
1840             show settings - display some internal settings
1841             desc - display schema of table
1842            
1843             show $dbh - show a database handle object.
1844             some examples:
1845             show $dbh Name
1846             show $dbh LongReadLen
1847             show $dbh mysql_serverinfo (mysql only)
1848            
1849             set display-mode delimited|spaced|box|record|sql|xml - query display mode
1850             set log-mode delimited|spaced|box|record|sql|xml - set the query log mode
1851             set delimiter - set the column delimiter (default is tab)
1852             set escape show-whitespace|escape-whitespace|uri-escape|off
1853             - show-whitespace is just for looking at
1854             - escape-whitespace is compatible with enter-whitespace
1855             - uri-escape is compatible with uri-decode (load command)
1856             set enter-whitespace on|off - allow \r \n and \t in SQL statements
1857             set uri-encode on|off - allow all non ascii characters to be escaped
1858             set auto-commit on|off - commit after every statement (default is OFF)
1859             set longtruncok on|off - See DBI/LongTruncOk (default is on)
1860             set longreadlen - See DBI/LongReadLen (default is 512)
1861             set multiline on|off - multiline statements ending in ; (default is off)
1862             set tracing on|off|deep - debug sqlsh using Log::Trace (default is off)
1863            
1864             log (queries|commands|all) - start logging to
1865             no log - stop logging
1866            
1867             select ...
1868             insert ...
1869             update ...
1870             create ...
1871             alter ...
1872             drop ...
1873             grant ...
1874             revoke ...
1875             begin_work
1876             commit
1877             rollback
1878             send ...
1879             recv ...
1880            
1881             load into (delimited by foo) (uri-decode) (from bar to baz)
1882             - load delimited data from a file
1883             - use uri-decode if file includes uri-encoded data
1884             - from, to can take character set to recode data e.g. from CP1252 to UTF-8
1885             show charsets - display available character sets
1886             dump into (delimited by foo) - dump delimited data
1887             dump into (delimited by foo) - dump delimited data
1888             dump all tables into (delimited by foo) - dump delimited data
1889             wipe tables - remove all data from DB (leaving tables empty)
1890            
1891             show history - display command history
1892             clear history - erases the command history
1893             save history to - saves the command history
1894             load history from - loads the command history
1895             execute - run a set of SQL or sqlsh commands from a file
1896              
1897             =head1 VERSION
1898              
1899             Version 1.17
1900              
1901             =head1 AUTHOR
1902              
1903             John Alden with contributions by Simon Flack and Simon Stevenson
1904              
1905             Miguel Gualdron maintainer.
1906              
1907             =head1 COPYRIGHT
1908              
1909             SQL-Shell: Interactive shell for DBI Databases
1910             Copyright (C) 2006 BBC
1911             Copyright (C) 2019 Miguel Gualdron
1912              
1913             This program is free software; you can redistribute it and/or modify
1914             it under the terms of the GNU General Public License as published by
1915             the Free Software Foundation; either version 2 of the License, or
1916             (at your option) any later version.
1917              
1918             This program is distributed in the hope that it will be useful,
1919             but WITHOUT ANY WARRANTY; without even the implied warranty of
1920             MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
1921             GNU General Public License for more details.
1922              
1923             You should have received a copy of the GNU General Public License
1924             along with this program; if not, write to the Free Software
1925             Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
1926              
1927             See the file COPYING in this distribution, or https://www.gnu.org/licenses/gpl-2.0.html
1928            
1929             =cut