1#!/usr/bin/perl
2#
3# $Header: /Users/claude/fuzz/lib/Genezzo/RCS/GenDBI.pm,v 7.42 2007/11/20 08:13:22 claude Exp claude $
4#
5# copyright (c) 2003-2007 Jeffrey I Cohen, all rights reserved, worldwide
6#
7#
8package Genezzo::GenDBI;
9
10require 5.005_62;
11use strict;
12use warnings;
13
14require Exporter;
15
16use Carp;
17use Data::Dumper ;
18use Genezzo;
19use Genezzo::Plan;
20use Genezzo::XEval;
21use Genezzo::Dict;
22use Genezzo::Util;
23
24use Term::ReadLine;
25use Text::ParseWords qw(shellwords quotewords parse_line);
26use warnings::register;
27
28# Items to export into callers namespace by default. Note: do not export
29# names by default without a very good reason. Use EXPORT_OK instead.
30# Do not simply export all your public functions/methods/constants.
31
32# This allows declaration	use F2 ':all';
33# If you do not need this, moving things directly into @EXPORT or @EXPORT_OK
34# will save memory.
35
36BEGIN {
37    use Exporter   ();
38
39    our (@ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS);
40
41    @ISA         = qw(Exporter);
42    %EXPORT_TAGS = ( 'all' => [ qw(
43                                   $VERSION $RELSTATUS $RELDATE errstr
44                                   ) ]
45                     );
46
47    @EXPORT_OK = qw( @{ $EXPORT_TAGS{'all'} } );
48
49    @EXPORT = qw( );
50
51}
52
53##our $VERSION   = $Genezzo::VERSION;
54our $VERSION   = '0.72';
55our $RELSTATUS = 'Alpha'; # release status
56# grab the code check-in date and convert to YYYYMMDD
57our $RELDATE   =
58    do { my @r = (q$Date: 2007/11/20 08:13:22 $ =~ m|Date:(\s+)(\d+)/(\d+)/(\d+)|); sprintf ("%04d%02d%02d", $r[1],$r[2],$r[3]); };
59
60our $errstr; # DBI errstr
61
62# build pattern to match commands that require a terminating semicolon
63our $need_semi = '(?i)^(\s)*(' .
64    join('|', qw(SELECT INSERT UPDATE DELETE EXPLAIN))
65    . ')';
66
67#
68# GZERR: the GeneZzo ERRor message handler
69#
70# You can define or redefine an error message handler for Genezzo
71#
72# Arguments:
73#
74# msg (required): an actual message that you can print, carp about, or log.
75# severity (optional): mainly to distinguish between informational
76#   messages and actual errors.  The current set of severities are INFO,
77#   WARN, ERROR, and FATAL, though I'll probably add DEBUG or DBG to replace
78#   the "whisper" messages.
79# self (optional): for object-oriented packages, adding a GZERR attribute
80#   to the $self is a bit cleaner way of propagating a common error routine
81#   to subsequent classes in your hierarchy.
82#
83# Specifications:
84# Your error handler should do something when it gets a message.
85# For example, the gendba.pl error handler prints INFO messages like
86# "5 rows selected" and it flags errors with a prefix like WARNING or ERROR.
87# If you use the dbi-style connect to obtain a database handle, the default
88# handler ignores INFO msgs, but prints all errors and warnings.
89#
90# gendba.pl supplies its own error handler when it calls GenDBI::new,
91# and GenDBI::connect (the DBI-style interface) has its own error handler,
92# which can be overridden in the attribute hash
93#
94# The default error handler declared here is typically not used.
95#
96# dbi gzerr doesn't call $self->gzerr to eliminate recursive hell
97our $dbi_gzerr = sub {
98    my %args = (@_);
99
100    return
101        unless (exists($args{msg}));
102
103    # to process spooling to multiple files
104    my $outfile_h = $args{outfile_list} || undef;
105
106    my $warn = 0;
107    if (exists($args{severity}))
108    {
109        my $sev = uc($args{severity});
110        $sev = 'WARNING'
111            if ($sev =~ m/warn/i);
112
113        return
114            if ($sev =~ m/ignore/i);
115
116        # don't print 'INFO' prefix
117        if ($args{severity} !~ m/info/i)
118        {
119#            printf STDERR ("%s: ", $sev);
120            printf ("%s: ", $sev);
121
122            if (defined($outfile_h))
123            {
124                while (my ($kk, $vv) = each (%{$outfile_h}))
125                {
126                    printf $vv ("%s: ", $sev);
127                }
128            }
129
130            $warn = 1;
131        }
132        else
133        {
134            if (exists($args{no_info}))
135            {
136                # don't print info if no_info set...
137                return;
138            }
139        }
140
141    }
142    # XXX XXX XXX
143#    print STDERR __PACKAGE__, ": ",  $args{msg};
144    print  __PACKAGE__, ": ",  $args{msg};
145    # add a newline if necessary
146#    print STDERR "\n" unless $args{msg}=~/\n$/;
147    print  "\n" unless $args{msg}=~/\n$/;
148#    carp $args{msg}
149#      if (warnings::enabled() && $warn);
150
151    if (defined($outfile_h))
152    {
153        while (my ($kk, $vv) = each (%{$outfile_h}))
154        {
155            print $vv  __PACKAGE__, ": ",  $args{msg};
156            print $vv  "\n" unless $args{msg}=~/\n$/;
157        }
158    }
159
160};
161
162our $GZERR = sub {
163    my %args = (@_);
164
165    # use the error routine supplied to GenDBI class if it exists,
166    # else use package error handler (dbi_gzerr)
167    if (exists($args{self}))
168    {
169        my $self = $args{self};
170        if (defined($self) && exists($self->{GZERR}))
171        {
172            my $err_cb = $self->{GZERR};
173            return &$err_cb(%args);
174        }
175    }
176    return &$dbi_gzerr(%args);
177};
178
179# NOTE: turn off "whisper" debug information.
180# Use "def _QUIETWHISPER=0" to re-enable if necessary.
181$Genezzo::Util::QUIETWHISPER  = 1; # XXX XXX XXX XXX
182$Genezzo::Util::USECARP       = 0;
183#$Genezzo::Util::WHISPERPREFIX = "baz: ";
184#$Genezzo::Util::WHISPERPREFIX = undef;
185#$Genezzo::Util::WHISPER_PRINT = sub { print "baz2: ", @_ ; };
186
187our $FEEBLE_DOWNCASE = 1; # all feeble identifers (tables, cols, etc)
188                          # become lowercase
189
190# Preloaded methods go here.
191
192sub _build_gzerr_wrapper
193{
194    my $gzerr_cb = shift;
195
196    # build a closure to control printing of "INFO" status messages...
197    my $gzerr_print_info = 1;
198    my %gzerr_outfile_h;
199
200    my $gzerr_closure = sub {
201
202        my %nargs = @_;
203
204        if (exists($nargs{get_status}))
205        {
206###            print "\n\nget status !!\n";
207            return $gzerr_print_info;
208        }
209        if (exists($nargs{set_status}))
210        {
211###            print "\n\nset status $nargs{set_status} !!\n";
212            $gzerr_print_info = $nargs{set_status};
213        }
214
215        if (exists($nargs{add_file}) && exists($nargs{fh}))
216        {
217            my $fname = $nargs{add_file};
218
219            $gzerr_outfile_h{$fname} = $nargs{fh};
220
221        }
222        if (exists($nargs{drop_file}))
223        {
224            my $fname = $nargs{drop_file};
225
226            delete $gzerr_outfile_h{$fname}
227                if (exists($gzerr_outfile_h{$fname}));
228        }
229
230        if ($gzerr_print_info == 0)
231        {
232            $nargs{no_info} = 1;
233        }
234
235        $nargs{outfile_list} = \%gzerr_outfile_h;
236
237        return &$gzerr_cb(%nargs);
238
239    };
240
241    return $gzerr_closure;
242}
243
244
245# special printing methods: print to STDOUT and spool to output files
246# simultaneously
247
248# print to STDOUT and spool outfiles
249sub _print_to_all
250{
251    my ($self, $msg) = @_;
252
253    print $msg;
254
255    $self->_print_to_outfiles($msg);
256}
257
258# print to spool outfiles only - special handling for prompts, etc.
259sub _print_to_outfiles
260{
261    my ($self, $msg) = @_;
262
263    while (my ($kk, $vv) = each (%{$self->{outfile_list}}))
264    {
265        print $vv $msg;
266    }
267}
268
269sub _init
270{
271    my $self = shift;
272    my %args = (@_);
273
274    $self->{caller} = $args{exe}
275       if (exists($args{exe}));
276
277# the data dictionary
278    $self->{dictobj} = ();
279
280    $self->{bigstatement} = ();
281    $self->{endwait} = 0;
282
283    my @histlist = ();
284
285    $self->{histlist} = \@histlist;
286    $self->{maxhist}  = 100;
287    $self->{histcounter} = 1;
288    $self->{histsave} = 0; # autosave
289
290    $self->{outfile_list} = {};
291
292    if ((exists($args{gnz_home}))
293        && (defined($args{gnz_home}))
294        && (length($args{gnz_home})))
295    {
296        $self->{gnz_home} = $args{gnz_home};
297    }
298    else
299    {
300        $self->{gnz_home} = $ENV{GNZ_HOME} ||
301            File::Spec->catdir($ENV{HOME} , 'gnz_home');
302    }
303#    print "$self->{gnz_home}\n";
304
305    my %nargs;
306    if (exists($self->{GZERR})) # pass the error reporting routine
307    {
308        $nargs{GZERR} = $self->{GZERR};
309    }
310    $self->{plan}  = Genezzo::Plan->new(%nargs);    # build a real parser
311    return 0
312        unless (defined($self->{plan}));
313    $self->{xeval} = Genezzo::XEval->new(%nargs,   # build evaluator
314                                         plan => $self->{plan}
315                                         );
316    return 0
317        unless (defined($self->{xeval}));
318
319    my $init_db = 0;
320
321    if ((exists($args{dbinit}))
322        && (defined($args{dbinit}))
323        && (length($args{dbinit})))
324    {
325        $init_db = $args{dbinit};
326    }
327
328    my %dictargs;
329
330    if ((exists($args{defs}))
331        && (defined($args{defs}))
332        )
333    {
334        my %legitdefs =
335            (
336             blocksize =>
337             "size of a database block in bytes, e.g. blocksize=4k",
338             force_init_db =>
339             "set =1 to overwrite (and destroy) an existing db",
340             dbsize =>
341             "size of the default datafile, e.g. dbsize=1g",
342
343             use_havok => "set =0 to disable havok subsystem",
344
345             # hidden definitions (use leading underscore)
346             _QUIETWHISPER =>
347             "quiet whisper state"
348             );
349        my %defs2 = %{$args{defs}};
350
351        for my $key (keys(%legitdefs))
352        {
353            if (exists($defs2{$key}))
354            {
355                $dictargs{$key} = $defs2{$key};
356
357                if ($key =~ m/QUIETWHISPER/)
358                {
359                    whisper "quietwhisper is  $Genezzo::Util::QUIETWHISPER";
360                    $Genezzo::Util::QUIETWHISPER = $defs2{$key};
361                    whisper "set quietwhisper to $Genezzo::Util::QUIETWHISPER";
362                }
363                delete $defs2{$key};
364            }
365        }
366
367        if (scalar(keys(%defs2)))
368        {
369            my $getHelp = 0;
370
371            my $msg = "unknown definitions for database initialization:\n";
372            while (my ($kk, $vv) = each (%defs2))
373            {
374                $getHelp = 1
375                    if ($kk =~ m/^help$/i);
376                $msg .=  "\t" .  $kk .  "=" . $vv ."\n";
377            }
378            $msg .= "\nlegal values are:\n";
379            while ( my ($kk, $vv) = each (%legitdefs))
380            {
381                $msg .= "  $kk - $vv\n"
382                    if ($kk !~ /^\_/); # hide defs with leading underscores
383            }
384            $msg .= "\n";
385
386            my %earg = ( msg => $msg, severity => 'info');
387
388            &$GZERR(%earg)
389                if (defined($GZERR));
390
391            return 0
392                if ($getHelp);
393
394            $dictargs{unknown_defs} = \%defs2;
395        }
396
397    }
398
399    if ((exists($args{fhdefs}))
400        && (defined($args{fhdefs}))
401        )
402    {
403        $dictargs{fhdefs} = $args{fhdefs};
404    }
405
406    if (exists($self->{GZERR})) # pass the error reporting routine
407    {
408        $dictargs{GZERR} = $self->{GZERR};
409    }
410
411    $self->{dbh_ctx} = {}; # database handle context
412
413    $self->{dictobj} = Genezzo::Dict->new(gnz_home => $self->{gnz_home},
414                                          init_db => $init_db, %dictargs);
415    return 0
416        unless (defined($self->{dictobj}));
417
418    $self->{init_db} = $init_db;
419
420    # pass dictionary information to the planner
421    $self->{plan}->Dict($self->{dictobj});
422    # pass dictionary information to the evaluator
423    $self->{xeval}->Dict($self->{dictobj});
424
425    return 1;
426}
427
428sub _clearerror
429{
430    my $self = shift;
431    $self->{errstr} = undef;
432    $self->{err}    = undef;
433}
434
435# DBI-style connect
436#
437# Arguments:
438#
439# gnz_home   (required): genezzo home directory
440# username   (required, but ignored): user name
441# password   (required, but ignored): password
442# attributes (optional): hash of attributes
443#
444# example:
445# my $dbh = Genezzo::GenDBI->connect($gnz_home,
446#                                    "NOUSER", "NOPASSWORD",
447#                                    {GZERR => $GZERR,
448#                                     PrintError => 1});
449#
450sub connect # DBI
451{
452    my $invocant = shift;
453    my $class = ref($invocant) || $invocant ;
454    my $self = { };
455
456    my ($gnz_home, $user, $passwd, $attr) = @_;
457
458    my %optional; # some optional values for _init args...
459
460    $self->{PrintError} = 1;
461    $self->{RaiseError} = 0;
462
463    if (defined($attr) && (ref($attr) eq 'HASH'))
464    {
465        # standard DBI-style PrintError, RaiseError
466        if (exists($attr->{PrintError}))
467        {
468            $self->{PrintError} = $attr->{PrintError};
469        }
470        if (exists($attr->{RaiseError}))
471        {
472            $self->{RaiseError} = $attr->{RaiseError};
473        }
474        # Non-standard GZERR argument to supply error message handler
475        if ((exists($attr->{GZERR}))
476                && (defined($attr->{GZERR})))
477        {
478            $optional{GZERR} = $attr->{GZERR};
479        }
480    }
481
482    my $i_gzerr  = sub {
483        my %args = (@_);
484
485        return
486            unless (exists($args{msg}));
487
488        my $warn = 0;
489        if (exists($args{severity}))
490        {
491            my $sev = uc($args{severity});
492            $sev = 'WARNING'
493                if ($sev =~ m/warn/i);
494
495            # don't print 'INFO' prefix
496            if ($args{severity} !~ m/info/i)
497            {
498#                printf ("%s: ", $sev);
499#                $warn = 1;
500            }
501            else
502            {
503#                printf ("%s: ", $sev);
504#                print $args{msg}, "\n";
505                return;
506            }
507        };
508
509        my $l_errstr = $args{msg};
510        # add a newline if necessary
511        $l_errstr .= "\n" unless $l_errstr=~/\n$/;
512
513        $self->{errstr} = $l_errstr;
514
515        warn $l_errstr
516            if $self->{PrintError};
517        die $l_errstr
518            if $self->{RaiseError};
519
520    };
521
522    # if no GZERR was supplied, use the dbi-style handler declared above
523    # with the appropriate printError, raiseError settings.
524    $optional{GZERR} = $i_gzerr
525        unless ((exists($optional{GZERR}))
526                && (defined($optional{GZERR})));
527
528    my %nargs = (%optional,
529                exe => $0,
530                gnz_home => $gnz_home,
531                user => $user,
532                password => $passwd);
533
534    if ((exists($nargs{GZERR}))
535        && (defined($nargs{GZERR}))
536        && (length($nargs{GZERR})))
537    {
538        $self->{GZERR} = _build_gzerr_wrapper($nargs{GZERR});
539        my $err_cb     = $self->{GZERR};
540        # capture all standard error messages
541        $Genezzo::Util::UTIL_EPRINT =
542            sub {
543                &$err_cb(self     => $self,
544                         severity => 'error',
545                         msg      => @_); };
546
547        $Genezzo::Util::WHISPER_PRINT =
548            sub {
549                &$err_cb(self     => $self,
550#                         severity => 'error',
551                         msg      => @_); };
552    }
553
554    return undef
555        unless (_init($self,%nargs));
556
557    my $foo = bless $self, $class;
558
559    return undef
560        unless (Genezzo::GenDBI->build_dict_dbh($foo));
561
562    return $foo;
563
564} # end connect
565
566sub new
567{
568    my $invocant = shift;
569    my $class = ref($invocant) || $invocant ;
570    my $self = { };
571
572    my %args = (@_);
573
574    if ((exists($args{GZERR}))
575        && (defined($args{GZERR}))
576        && (length($args{GZERR})))
577    {
578        # NOTE: don't supply our GZERR here - will get
579        # recursive failure...
580        $self->{GZERR} = _build_gzerr_wrapper($args{GZERR});
581    }
582    else
583    {
584        $self->{GZERR} = _build_gzerr_wrapper($dbi_gzerr);
585    }
586    {
587        my $err_cb     = $self->{GZERR};
588        # capture all standard error messages
589        $Genezzo::Util::UTIL_EPRINT =
590            sub {
591                &$err_cb(self     => $self,
592                         severity => 'error',
593                         msg      => @_); };
594
595        $Genezzo::Util::WHISPER_PRINT =
596            sub {
597                &$err_cb(self     => $self,
598#                         severity => 'error',
599                         msg      => @_); };
600    }
601
602    return undef
603        unless (_init($self,%args));
604
605    my $foo = bless $self, $class;
606
607    return undef
608        unless (Genezzo::GenDBI->build_dict_dbh($foo));
609
610    return $foo;
611
612} # end new
613
614sub build_dict_dbh
615{
616    my $invocant = shift;
617    my $class = ref($invocant) || $invocant ;
618    my $self = { };
619
620    my $old_self = shift @_;
621
622    if (exists($old_self->{GZERR}))
623    {
624        $self->{GZERR} = $old_self->{GZERR};
625    }
626    $self->{gnz_home} = $old_self->{gnz_home};
627    $self->{plan}     = $old_self->{plan};
628    $self->{xeval}    = $old_self->{xeval};
629    $self->{dbh_ctx}  = {}; # database handle context
630    $self->{dictobj}  = $old_self->{dictobj};
631
632    # CLONE the database handle
633    my $foo = bless $self, $class;
634
635    my $stat = $self->{dictobj}->SetDBH($foo, $self->{init_db});
636
637    $self->{init_db} = 0;
638    return $stat;
639
640} # end build_dict_dbh
641
642sub Kgnz_Rem
643{
644    my $self = shift;
645    return 1;
646}
647
648sub SaveHistory
649{
650    my ($self, $fn_args) = @_;
651
652    my $hfile = File::Spec->catdir($ENV{HOME} , '.gnz_history');
653
654    my $h_fh;
655
656    return 0
657        unless (open($h_fh, "> $hfile"));
658
659    my $histlist = $self->{histlist};
660
661    foreach my $aval (@{$histlist})
662    {
663        my ($hcnt, $val) = @{$aval};
664
665        # URL-style substitution to handle spaces, weird chars
666        $val =~ s/([^a-zA-Z0-9])/uc(sprintf("%%%02lx",  ord $1))/eg;
667
668        print $h_fh $val, "\n";
669
670    }
671
672    if (defined($fn_args) && scalar(@{$fn_args}))
673    {
674        $self->{histsave} = 1
675            if ($fn_args->[0] =~ m/autosave/i);
676    }
677
678    return 1;
679
680}
681
682sub LoadHistory
683{
684    my ($self, $term) = @_;
685
686    my $hfile = File::Spec->catdir($ENV{HOME} , '.gnz_history');
687
688    return 0
689        unless (-e $hfile);
690
691    my $h_fh;
692
693    return 0
694        unless (open($h_fh, "< $hfile"));
695
696    while (<$h_fh>)
697    {
698        my $ini = $_;
699
700        chomp($ini);
701
702        # URL-style substitution to handle spaces, weird chars
703        $ini =~ s/\%([A-Fa-f0-9]{2})/pack('C', hex($1))/seg;
704
705        $term->addhistory($ini);
706        $self->histpush($self->{histcounter}, $ini);
707        ($self->{histcounter}) += 1;
708    }
709
710    return 1;
711
712}
713
714
715sub Kgnz_Quit
716{
717    my $self = shift;
718    my %earg = (self => $self, msg => "quitting...\n", severity => 'info');
719
720    &$GZERR(%earg)
721        if (defined($GZERR));
722
723    if ($self->{histsave})
724    {
725        $self->SaveHistory();
726    }
727
728    exit ;
729
730    return 1;
731
732} # end Kgnz_Quit
733
734sub Kgnz_Reload
735{
736    my $self = shift;
737
738    if (exists($self->{caller}))
739    {
740        my $msg  = $self->{caller} . "\n";
741        my %earg = (self => $self, msg => $msg, severity => 'info');
742
743        &$GZERR(%earg)
744            if (defined($GZERR));
745
746        # need to add arg list here ...
747        exec $self->{caller}  ;
748    }
749#    return ;
750}
751
752sub Kgnz_Dump
753{
754    my $self = shift;
755    my $dictobj = $self->{dictobj};
756    return $dictobj->DictDump (@_);
757
758}
759
760sub Kgnz_Explain
761{
762    # explain query plan
763    my $self = shift;
764    my $sqltxt = $self->{current_line};
765
766    # explain [plan [for]] sql statement
767    $sqltxt =~ s/(?i)^(\s)*(explain)((\s)*plan((\s)*(for))?)?//;
768
769    {
770        local $Data::Dumper::Indent   = 1;
771        local $Data::Dumper::Sortkeys = 1;
772
773        my $parse_tree = $self->{plan}->Parse(statement => $sqltxt);
774
775        return 0
776            unless (defined($parse_tree));
777
778        my $msg = Data::Dumper->Dump([$parse_tree],['parse_tree']);
779        $msg .= "\n\n";
780
781        my %earg = (self => $self,  msg => $msg, severity => 'info');
782
783        &$GZERR(%earg)
784            if (defined($GZERR));
785
786        my $algebra = $self->{plan}->Algebra(parse_tree => $parse_tree);
787
788        $msg = Data::Dumper->Dump([$algebra],['algebra']);
789        $msg .= "\n\n";
790
791        %earg = (self => $self,  msg => $msg, severity => 'info');
792
793        &$GZERR(%earg)
794            if (defined($GZERR));
795
796        my ($tc, $err_status)
797            = $self->{plan}->TypeCheck(algebra   => $algebra,
798                                       statement => $sqltxt);
799
800        $msg = Data::Dumper->Dump([$tc],['type_analysis']);
801        $msg .= "\n\n";
802
803        %earg = (self => $self,  msg => $msg, severity => 'info');
804
805        &$GZERR(%earg)
806            if (defined($GZERR));
807
808        unless ($err_status)
809        {
810            ($tc, $err_status)
811                 = $self->{plan}->QueryRewrite(algebra   => $tc,
812                                               statement => $sqltxt);
813
814            $msg = Data::Dumper->Dump([$tc],['query_rewrite']);
815            $msg .= "\n\n";
816
817            %earg = (self => $self,  msg => $msg, severity => 'info');
818
819            &$GZERR(%earg)
820                if (defined($GZERR));
821        }
822    }
823
824    return 1;
825}
826
827sub Kgnz_AddFile
828{
829#    greet @_ ;
830    my $self = shift;
831    my $dictobj = $self->{dictobj};
832    {
833        my $goodargs = 1;
834        my $gothelp  = 0;
835        my %legitdefs =
836            (
837             filesize =>
838             "size of a database file in bytes, e.g. filesize=10M\n\t\t(default - double previous allocation)",
839             filename =>
840             "name of file (default - system-generated)",
841             tsname =>
842             "\tname of associated tablespace (default SYSTEM)",
843             increase_by =>
844             "size in bytes or percentage increase, e.g. increase_by=1M\n\t\tor increase_by=50% (default zero - file size is fixed)"
845             );
846        my %nargs;
847
848        $nargs{dbh_ctx} = $self->{dbh_ctx};
849
850        for my $argval (@_)
851        {
852            if ($argval =~ m/^help$/i)
853            {
854                my $bigMsg;
855                ($bigMsg = <<EOF_Msg) =~ s/^\#//gm;
856#
857# AddFile Help - addfile takes a list of name=value arguments
858# with no spaces around the equal sign, and no commas between arguments
859# e.g: addfile filename=test.dbf filesize=22M
860#
861# If no arguments are specified addfile will create a new datafile
862# double the size of the previous one.
863#
864EOF_Msg
865                my %earg = (self => $self, msg => $bigMsg, severity => 'warn');
866
867                &$GZERR(%earg)
868                    if (defined($GZERR));
869
870                $gothelp  = 1;
871                $goodargs = 0;
872                last;
873            }
874
875            if ($argval =~ m/=/)
876            {
877                my @foo = split('=',$argval, 2);
878                if ((2 == scalar(@foo))
879                    && (defined($foo[0]))
880                    && (exists($legitdefs{$foo[0]})))
881                {
882                    $nargs{$foo[0]} = $foo[1];
883                }
884                else
885                {
886                    my $msg = "invalid argument: $argval\n";
887                    my %earg = (self => $self, msg => $msg,
888                                severity => 'warn');
889
890                    &$GZERR(%earg)
891                        if (defined($GZERR));
892
893                    $goodargs = 0;
894                }
895            }
896            else
897            {
898                my $msg = "invalid argument: $argval\n";
899                my %earg = (self => $self, msg => $msg,
900                            severity => 'warn');
901
902                &$GZERR(%earg)
903                    if (defined($GZERR));
904                $goodargs = 0;
905            }
906        } # end for
907        unless ($goodargs)
908        {
909            my $msg = "valid args are:\n";
910            while (my ($kk, $vv) = each (%legitdefs))
911            {
912                $msg .= $kk . ":\t" . $vv ."\n";
913            }
914            $msg .= "type: \"addfile help\" for more information\n"
915                unless ($gothelp);
916
917            my %earg = (self => $self, msg => $msg,
918                        severity => 'warn');
919
920            &$GZERR(%earg)
921                if (defined($GZERR));
922
923            return 0;
924        }
925
926        return ($dictobj->DictAddFile (%nargs));
927    }
928
929    return 0;
930
931}
932
933sub Kgnz_Describe
934{
935    my $self = shift;
936    my $dictobj = $self->{dictobj};
937
938  L_ParseDescribe:
939    {
940	last if (@_ < 1);
941
942	my $tablename = shift @_ ;
943
944	my @params = @_ ;
945
946        my $allcols = $dictobj->DictTableGetCols (tname => $tablename);
947
948        return undef
949            unless (defined($allcols));
950
951        my @outi;
952        while (my ($kk, $vv) = each (%{$allcols}))
953        {
954            my ($colidx, $dtype) = @{$vv};
955
956            $outi[$colidx] = "$kk : $dtype\n";
957        }
958        my $bigMsg = "";
959        for my $ii (@outi)
960        {
961            $bigMsg .= $ii
962                if (defined($ii));
963        }
964        my %earg = (self => $self, msg => $bigMsg, severity => 'info');
965
966        &$GZERR(%earg)
967            if (defined($GZERR));
968
969        return 1;
970
971    }
972    return 0;
973
974} # end describe
975
976sub Feeble_CIdx
977{
978    my $self = shift @_;
979
980    my @outi;
981
982    if (scalar(@_) > 2)
983    {
984	my $indexname = shift @_ ;
985        $indexname = lc($indexname) if ($FEEBLE_DOWNCASE);
986
987        if ($FEEBLE_DOWNCASE)
988        {
989            unless (Feeble_tablename_check($indexname))
990            {
991                my $msg = "invalid indentifier $indexname\n";
992                my %earg = (self => $self, msg => $msg,
993                            severity => 'warn');
994
995                &$GZERR(%earg)
996                    if (defined($GZERR));
997                return 0;
998            }
999        }
1000
1001        push @outi, $indexname;
1002
1003	my @params = @_ ;
1004
1005        if (ref($params[0]) eq 'HASH')
1006        {
1007            my $p1 = shift @params;
1008
1009            push @outi, $p1;
1010        }
1011
1012        my $tablename = shift @params;
1013
1014        $tablename = lc($tablename) if ($FEEBLE_DOWNCASE);
1015
1016        if ($FEEBLE_DOWNCASE)
1017        {
1018            unless (Feeble_tablename_check($tablename))
1019            {
1020                my $msg = "invalid indentifier $tablename\n";
1021                my %earg = (self => $self, msg => $msg,
1022                            severity => 'warn');
1023
1024                &$GZERR(%earg)
1025                    if (defined($GZERR));
1026                return 0;
1027            }
1028        }
1029        push @outi, $tablename;
1030
1031        my @pr2 = ($FEEBLE_DOWNCASE) ? map(lc, @params) : @params;
1032
1033        push @outi, @pr2;
1034
1035    }
1036
1037    return $self->Kgnz_CIdx(@outi);
1038}
1039
1040
1041sub Kgnz_CIdx
1042{
1043    my $self = shift;
1044    my %optional = (
1045                    tablespace => "SYSTEM"
1046                    );
1047
1048  L_ParseCreate:
1049    {
1050	last if (@_ < 3);
1051
1052	my $indexname = shift @_ ;
1053
1054	my @params = @_ ;
1055
1056        my %args;
1057        if (ref($params[0]) eq 'HASH')
1058        {
1059            my $p1 = shift @params;
1060#            $msg .= "\n" . Dumper([$p1]) . "\n";
1061
1062            %args = (%optional,
1063                     %{$p1});
1064
1065        }
1066        else
1067        {
1068            %args = (%optional);
1069        }
1070
1071
1072	my $tablename = shift @params ;
1073
1074        my $msg = "Create Index : $indexname on $tablename \n";
1075
1076        my %earg = (self => $self, msg => $msg, severity => 'info');
1077
1078        &$GZERR(%earg)
1079            if (defined($GZERR));
1080
1081        unless (scalar(@params))
1082        {
1083            $msg = "invalid column list for table $tablename\n";
1084            %earg = (self => $self, msg => $msg, severity => 'warn');
1085
1086            &$GZERR(%earg)
1087                if (defined($GZERR));
1088
1089            return 0;
1090        }
1091        my $dictobj = $self->{dictobj};
1092        return ($dictobj->DictIndexCreate (tname      => $tablename,
1093                                           index_name => $indexname,
1094                                           cols       => \@params,
1095                                           tablespace => $args{tablespace},
1096                                           itype      => "nonunique",
1097                                           dbh_ctx    => $self->{dbh_ctx}
1098                                           ));
1099
1100    }
1101    return 0;
1102} # end Kgnz_CIdx
1103
1104sub Kgnz_CreateTS
1105{
1106    my $self = shift;
1107
1108  L_ParseCreate:
1109    {
1110#	last if (@_ < 3);
1111
1112	my $tsname = shift @_ ;
1113
1114        my $msg = "Create Tablespace $tsname \n";
1115
1116        my %earg = (self => $self, msg => $msg, severity => 'info');
1117
1118        &$GZERR(%earg)
1119            if (defined($GZERR));
1120
1121	my @params = @_ ;
1122
1123        if (0) #       unless (scalar(@params))
1124        {
1125            $msg = "" ; #"invalid column list for table $tablename\n";
1126            %earg = (self => $self, msg => $msg, severity => 'warn');
1127
1128            &$GZERR(%earg)
1129                if (defined($GZERR));
1130
1131            return 0;
1132        }
1133        my $dictobj = $self->{dictobj};
1134        return ($dictobj->DictTSpaceCreate (
1135                                           tablespace => $tsname,
1136                                           dbh_ctx    => $self->{dbh_ctx}
1137                                           ));
1138
1139    }
1140    return 0;
1141}
1142
1143sub Feeble_tablename_check
1144{
1145    my $tablename = shift;
1146
1147    return ($tablename =~ m/^([a-zA-Z0-9]|_)*$/);
1148}
1149
1150sub Feeble_CT
1151{
1152    my $self = shift;
1153
1154    my @outi = ($FEEBLE_DOWNCASE) ? map(lc, @_) : @_;
1155
1156    if ($FEEBLE_DOWNCASE && scalar(@outi))
1157    {
1158        my $tablename = $outi[0];
1159
1160        unless (Feeble_tablename_check($tablename))
1161        {
1162            my $msg = "invalid indentifier $tablename\n";
1163            my %earg = (self => $self, msg => $msg,
1164                        severity => 'warn');
1165
1166            &$GZERR(%earg)
1167                if (defined($GZERR));
1168            return 0;
1169        }
1170    }
1171
1172    return $self->Kgnz_CT(@outi);
1173}
1174
1175sub Kgnz_CT
1176{
1177    my $self = shift;
1178    my %optional = (
1179                    tablespace => "SYSTEM",
1180                    tabtype    => "TABLE"
1181                    );
1182  L_ParseCreate:
1183    {
1184	last if (@_ < 1);
1185
1186	my $tablename = shift @_ ;
1187
1188	my @params = @_ ;
1189
1190        unless (scalar(@params))
1191        {
1192            my $msg = "invalid column list for table $tablename\n";
1193            my %earg = (self => $self, msg => $msg,
1194                        severity => 'warn');
1195
1196            &$GZERR(%earg)
1197                if (defined($GZERR));
1198            return 0;
1199        }
1200
1201        my @coldefarr = ();
1202
1203        my $colidx = 0;
1204
1205        my $tabtype = $optional{tabtype};
1206
1207        my $msg = "Create Table : $tablename \n";
1208
1209        # XXX XXX: quick hack for index-organized table support
1210        if ($params[0] =~ m/^index/i)
1211        {
1212            $msg .= "with unique index option\n";
1213            $tabtype = "IDXTAB";
1214            shift @params
1215        }
1216
1217        my %args;
1218        if (ref($params[0]) eq 'HASH')
1219        {
1220            my $p1 = shift @params;
1221#            $msg .= "\n" . Dumper([$p1]) . "\n";
1222
1223            %args = (%optional,
1224                     %{$p1});
1225
1226            if (exists($p1->{tabtype}))
1227            {
1228                $tabtype = $p1->{tabtype};
1229            }
1230        }
1231        else
1232        {
1233            %args = (%optional);
1234        }
1235
1236        my %earg = (self => $self, msg => $msg,
1237                    severity => 'info');
1238
1239        &$GZERR(%earg)
1240            if (defined($GZERR));
1241
1242
1243      L_coldataloop:
1244        foreach my $token (@params)
1245        {
1246            unless ($token =~ m/=/)
1247            {
1248                $msg = "invalid column specifier ($token) for table $tablename\n";
1249                %earg = (self => $self, msg => $msg,
1250                         severity => 'warn');
1251
1252                &$GZERR(%earg)
1253                    if (defined($GZERR));
1254
1255                return 0;
1256            }
1257
1258            my ($colname, $dtype) = split('=',$token) ;
1259
1260            $coldefarr[$colidx++] = {colname => $colname,
1261                                     datatype => $dtype};
1262        }
1263
1264#            greet %coldatatype;
1265
1266        my %nargs =
1267            (op1 => "create",
1268             op2 => "table",
1269             createtabargs =>
1270             {
1271                 tabname => $tablename,
1272                 tabdef  =>
1273                 {
1274                     coldefarr => \@coldefarr
1275                 },
1276                 dbstore     => "flat1",
1277                 tablespace  => $args{tablespace},
1278                 object_type => $tabtype
1279              }
1280             );
1281        return $self->Kgnz_Create(%nargs);
1282
1283    }
1284    return 0;
1285
1286} # end CT
1287
1288sub Kgnz_Create
1289{
1290    my $self = shift;
1291    my $dictobj = $self->{dictobj};
1292    my %args = (
1293		@_);
1294#		op1, op2
1295
1296    my $bVerbose = 1;
1297
1298    my %createdispatch =
1299	qw(
1300	   table  tablething
1301	   tabdef tadefthing
1302	   );
1303
1304#    greet @_ ;
1305
1306  L_ParseCreate:
1307    {
1308	my $createkeyword = $args{op2};
1309
1310        my ($msg,%earg);
1311
1312	unless (exists($createdispatch{lc($createkeyword)}))
1313	{
1314	    $msg = "could not parse: \n" ;
1315            my $b = \%args;
1316	    $msg .= Data::Dumper->Dump([$b], [qw(*b )]);
1317            %earg = (self => $self, msg => $msg,
1318                     severity => 'warn');
1319
1320            &$GZERR(%earg)
1321                if (defined($GZERR));
1322
1323	    last   L_ParseCreate;
1324	}
1325
1326        unless (exists($args{createtabargs}))
1327        {
1328            $msg = "no table name \n" ;
1329            %earg = (self => $self, msg => $msg,
1330                     severity => 'warn');
1331
1332            &$GZERR(%earg)
1333                if (defined($GZERR));
1334
1335            last L_ParseCreate;
1336        }
1337
1338        my $tabargs = $args{createtabargs};
1339
1340        unless (exists($tabargs->{tabname}))
1341        {
1342            $msg = "no table name \n" ;
1343            %earg = (self => $self, msg => $msg,
1344                     severity => 'warn');
1345
1346            &$GZERR(%earg)
1347                if (defined($GZERR));
1348
1349            last L_ParseCreate;
1350        }
1351
1352	my $tablename = $tabargs->{tabname} ;
1353	my $tabdefn   = $tabargs->{tabdef} ;
1354        my $tabtype   = $tabargs->{object_type} || "TABLE";
1355        my $tspace    = $tabargs->{tablespace};
1356
1357        unless ($dictobj->DictTableExists (tname => $tablename,
1358                                           silent_exists => 0,
1359                                           silent_notexists => 1 ))
1360        {
1361
1362            my %legaldtypes =
1363                qw(
1364                   c      charthing
1365                   char   charthing
1366                   n       numthing
1367                   num     numthing
1368                   );
1369
1370            # NB: get keys in insertion order
1371#            use Tie::IxHash ;
1372
1373            my %coldatatype = ();
1374
1375#            tie %coldatatype, "Tie::IxHash";
1376
1377            my $colidx = 1;
1378
1379            if ($bVerbose )
1380            {
1381
1382                $msg = "tablename : $tablename\n" ;
1383                %earg = (self => $self, msg => $msg,
1384                         severity => 'info');
1385
1386                &$GZERR(%earg)
1387                    if (defined($GZERR));
1388            }
1389
1390          L_coldataloop:
1391            foreach my $token (@{ $tabdefn->{coldefarr} })
1392            {
1393                my $colname = $token->{colname};
1394                my $dtype   = $token->{datatype};
1395
1396                unless (exists($legaldtypes{lc($dtype)}))
1397                {
1398                    $msg = "illegal datatype: $dtype \n" ;
1399                    $msg .= "$tablename : " . Dumper($token) . "\n";
1400                    %earg = (self => $self, msg => $msg,
1401                             severity => 'warn');
1402
1403                    &$GZERR(%earg)
1404                        if (defined($GZERR));
1405
1406                    last   L_ParseCreate;
1407                }
1408                if ($bVerbose)
1409                {
1410                    my $extra = "";
1411                    $extra = '(primary key)' # XXX XXX
1412                        if (($tabtype eq "IDXTAB") && (1 == $colidx));
1413
1414                    $msg = "\tcolumn $colname : $dtype $extra\n" ;
1415                    %earg = (self => $self, msg => $msg,
1416                             severity => 'info');
1417
1418                    &$GZERR(%earg)
1419                        if (defined($GZERR));
1420                }
1421
1422                $coldatatype{$colname} = [$colidx, $dtype];
1423                $colidx++;
1424
1425            }
1426
1427#            greet %coldatatype;
1428
1429            # create hash ref
1430
1431            return ($dictobj->DictTableCreate (tname       => $tablename,
1432                                               tabdef      => \%coldatatype,
1433                                               tablespace  => $tspace,
1434                                               object_type => $tabtype,
1435                                               dbh_ctx     => $self->{dbh_ctx}
1436                                               ));
1437
1438
1439        }
1440    }
1441    return 0;
1442
1443}
1444
1445sub Feeble_Drop
1446{
1447    my $self = shift;
1448
1449    my @outi = ($FEEBLE_DOWNCASE) ? map(lc, @_) : @_;
1450
1451    return $self->Kgnz_Drop(@outi);
1452
1453}
1454
1455sub Kgnz_Drop
1456{
1457#    greet @_ ;
1458    my $self = shift;
1459    my $dictobj = $self->{dictobj};
1460    {
1461        last if (@_ < 1);
1462        my $stat;
1463
1464        for my $tablename ( @_ )
1465        {
1466            next # optional "table" keyword... [not SQL standard]
1467                if ($tablename =~ m/^table$/i);
1468
1469            # may need to distinguish between bareword and
1470            # quoted strings
1471            if ($tablename =~ m/^\"(.*)\"$/)
1472            {
1473                # strip leading/trailing quotes
1474                my @p2 = $tablename =~ m/^\"(.*)\"$/;
1475                $tablename = shift @p2;
1476            }
1477            else
1478            {
1479                # case-insensitive
1480                $tablename = lc($tablename);
1481            }
1482
1483            $stat = $dictobj->DictTableDrop (tname   => $tablename,
1484                                             dbh_ctx => $self->{dbh_ctx}
1485                                             );
1486
1487            last
1488                unless ($stat);
1489        }
1490
1491        return $stat;
1492    }
1493
1494    return undef;
1495
1496}
1497
1498sub Kgnz_Spool
1499{
1500#   greet @_;
1501    my $self = shift;
1502    {
1503        last if (@_ < 1);
1504
1505        my $outfile = shift @_ ;
1506        my @params = @_ ;
1507
1508        if (uc($outfile) eq "OFF")
1509        {
1510            while (my ($kk, $vv) = each (%{$self->{outfile_list}}))
1511            {
1512                drop_gzerr_outfile(GZERR=>$GZERR,
1513                                   filename => $kk,
1514                                   self => $self);
1515                close ($vv);
1516            }
1517            $self->{outfile_list} = {};
1518
1519            last;
1520        }
1521
1522        if (exists($self->{outfile_list}->{$outfile}))
1523        {
1524            my $msg = "Output file $outfile is already open";
1525
1526            my %earg = (self => $self, msg => $msg,
1527                        severity => 'warn');
1528
1529            &$GZERR(%earg)
1530                if (defined($GZERR));
1531
1532            return 0;
1533        }
1534
1535        my $fh;
1536
1537        unless(open ($fh, "> $outfile "))
1538        {
1539            my $msg = "Could not open $outfile for writing : $! \n";
1540
1541            my %earg = (self => $self, msg => $msg,
1542                        severity => 'warn');
1543
1544            &$GZERR(%earg)
1545                if (defined($GZERR));
1546
1547            return 0;
1548        }
1549
1550        $self->{outfile_list}->{$outfile} = $fh;
1551        add_gzerr_outfile(GZERR=>$GZERR,
1552                          filename => $outfile,
1553                          fh => $fh,
1554                          self => $self);
1555    }
1556
1557    return 1;
1558
1559}
1560
1561sub Kgnz_Commit
1562{
1563    my $self = shift;
1564
1565    return $self->Kgnz_Sync(@_);
1566
1567# Note: develop separate path for Commit versus Sync for transactional
1568# support, e.g. something like "DictCommit"
1569#    my $dictobj = $self->{dictobj};
1570#    my %args = (
1571#		@_);
1572#
1573##    greet @_ ;
1574#
1575#    return ($dictobj->DictSave(dbh_ctx => $self->{dbh_ctx}));
1576}
1577
1578sub Kgnz_Sync
1579{
1580    my $self = shift;
1581    my $dictobj = $self->{dictobj};
1582    my %args = (
1583		@_);
1584
1585#    greet @_ ;
1586
1587    return ($dictobj->DictSave(dbh_ctx => $self->{dbh_ctx}));
1588
1589}
1590
1591sub Kgnz_Rollback
1592{
1593    my $self = shift;
1594    my $dictobj = $self->{dictobj};
1595    my %args = (
1596		@_);
1597
1598#    greet @_ ;
1599
1600    return ($dictobj->DictRollback(dbh_ctx => $self->{dbh_ctx}));
1601
1602}
1603
1604# XXX: note - not a class or instance method
1605sub getversionstring
1606{
1607    return undef
1608        unless (scalar(@_) > 2);
1609    my ($verzion, $relstat, $reldate, $getlicense) = @_;
1610
1611    my $bigstr = "Genezzo Version " . $verzion . " - " . $relstat . " " ;
1612    $bigstr .=  $reldate . "  (www.genezzo.com)\n";
1613    $bigstr .= "Copyright (c) 2003-2007 Jeffrey I Cohen.  All rights reserved.\n";
1614
1615    if (defined($getlicense))
1616    {
1617        my $llstr;
1618        $llstr = <<'EOF_littlelicense';
1619
1620    This program is free software; you can redistribute it and/or modify
1621    it under the terms of the GNU General Public License as published by
1622    the Free Software Foundation; either version 2 of the License, or
1623    any later version.
1624
1625    This program is distributed in the hope that it will be useful,
1626    but WITHOUT ANY WARRANTY; without even the implied warranty of
1627    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
1628    GNU General Public License for more details.
1629
1630    You should have received a copy of the GNU General Public License
1631    along with this program; if not, write to the Free Software
1632    Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301  US
1633
1634Address bug reports and comments to: jcohen@genezzo.com
1635
1636For more information, please visit the Genezzo homepage
1637at http://www.genezzo.com
1638EOF_littlelicense
1639    $bigstr .= $llstr;
1640    }
1641
1642    return $bigstr;
1643}
1644
1645sub PrintVersionString
1646{
1647    my $self = shift;
1648    my $msg = "\n\nGenezzo Version $VERSION - $RELSTATUS $RELDATE  (www.genezzo.com)\n";
1649    $msg .= "Copyright (c) 2003-2007 Jeffrey I Cohen.  All rights reserved.\n";
1650    $msg .= "\nType \"SHOW\" to obtain license information, ";
1651    $msg .= "type \"HELP\" for help.\n\n";
1652    my %earg = (self => $self, msg => $msg,
1653             severity => 'info');
1654
1655    &$GZERR(%earg)
1656        if (defined($GZERR));
1657
1658}
1659
1660sub Kgnz_Show
1661{
1662    my $self = shift;
1663    my $dictobj = $self->{dictobj};
1664
1665    my $msg = "";
1666    my $severity = 'info';
1667
1668    my %legitdefs =
1669        (version => "Genezzo version information",
1670         license => "Genezzo license and warranty",
1671         help    =>  "this message"
1672         );
1673
1674    my $showhelp = !(scalar(@_));
1675    for my $argval (@_)
1676    {
1677        if ($argval =~ m/license/i)
1678        {
1679            $self->PrintLicense();
1680        }
1681        elsif ($argval =~ m/version/i)
1682        {
1683            $self->PrintVersionString();
1684        }
1685        elsif ($argval =~ m/help/i)
1686        {
1687            $showhelp = 1;
1688        }
1689        else
1690        {
1691            $showhelp = 1;
1692            $msg = "invalid SHOW argument ($argval)\n";
1693            $severity = 'warn';
1694        }
1695    }
1696    if ($showhelp)
1697    {
1698        $msg .= "\nlegal values are:\n";
1699        while ( my ($kk, $vv) = each (%legitdefs))
1700        {
1701            $msg .= "  show $kk - $vv\n";
1702        }
1703        my %earg = (self => $self, msg => $msg,
1704                    severity => $severity);
1705
1706        &$GZERR(%earg)
1707            if (defined($GZERR));
1708    }
1709
1710    return 1;
1711}
1712
1713sub Kgnz_Startup
1714{
1715    my $self = shift;
1716    my $dictobj = $self->{dictobj};
1717    my %args = (
1718		@_);
1719
1720    greet @_ ;
1721    $args{dbh_ctx} = $self->{dbh_ctx};
1722    return $dictobj->DictStartup(@_);
1723}
1724
1725sub Kgnz_Shutdown
1726{
1727    my $self = shift;
1728    my $dictobj = $self->{dictobj};
1729    my %args = (
1730		@_);
1731
1732    greet @_ ;
1733    $args{dbh_ctx} = $self->{dbh_ctx};
1734    return $dictobj->DictShutdown(@_);
1735}
1736
1737sub Kgnz_Password
1738{
1739    my $self = shift;
1740    my $dictobj = $self->{dictobj};
1741    my %args = (
1742		@_);
1743
1744    greet @_ ;
1745
1746    my ($uname, $cryptpwd) = (getpwuid($<))[0,1];
1747    my $plainword;
1748
1749    # XXX XXX : looks like this getpwuid returns the crypt from the
1750    # shadow file - an 'x'
1751
1752# XXX XXX : need term::readkey
1753
1754    system "stty -echo";
1755    print "Password: ";
1756    chomp($plainword = <STDIN>);
1757    print "\n";
1758    system "stty echo";
1759
1760    if (crypt($plainword, $cryptpwd) ne $cryptpwd) {
1761        print "sorry!\n";
1762    } else {
1763        print "ok\n";
1764    }
1765
1766
1767    return 1;
1768}
1769
1770sub Feeble_Delete
1771{
1772    my $self = shift;
1773
1774    my @outi = ($FEEBLE_DOWNCASE) ? map(lc, @_) : @_;
1775
1776    if ($FEEBLE_DOWNCASE && scalar(@outi))
1777    {
1778        my $tablename = $outi[0];
1779
1780        unless (Feeble_tablename_check($tablename))
1781        {
1782            my $msg = "invalid indentifier $tablename\n";
1783            my %earg = (self => $self, msg => $msg,
1784                        severity => 'warn');
1785
1786            &$GZERR(%earg)
1787                if (defined($GZERR));
1788            return 0;
1789        }
1790    }
1791
1792    return $self->Kgnz_Delete(@outi);
1793
1794}
1795
1796sub Kgnz_Delete
1797{
1798#    greet @_ ;
1799    my $self = shift;
1800    my $dictobj = $self->{dictobj};
1801  L_ParseDelete:
1802    {
1803	last if (@_ < 2);
1804
1805	my $tablename = shift @_ ;
1806	my @params = @_ ;
1807#        greet @params;
1808
1809        my ($msg, %earg);
1810        my $severity = 'info';
1811
1812	last unless $dictobj->DictTableExists(tname => $tablename);
1813
1814        my $rowcount = 0;
1815
1816        $msg = "";
1817        foreach my $rid (@params)
1818        {
1819            unless
1820                ($dictobj->RowDelete (tname   => $tablename,
1821                                      rid     => $rid,
1822                                      dbh_ctx => $self->{dbh_ctx}
1823                                      )
1824                 )
1825                {
1826                    $msg = "failed to delete row $rid : \n";
1827                    $severity = 'warn';
1828
1829                    last;
1830                }
1831
1832            $rowcount++;
1833        }
1834        my $rowthing = ((1 == $rowcount) ? "row" : "rows");
1835        $msg .= "deleted $rowcount $rowthing from table $tablename.\n";
1836        %earg = (self => $self, msg => $msg,
1837                 severity => $severity);
1838
1839        &$GZERR(%earg)
1840            if (defined($GZERR));
1841
1842        return $rowcount;
1843    }
1844
1845    return undef;
1846
1847} # end kgnz_delete
1848
1849sub Feeble_Insert
1850{
1851    my $self = shift @_;
1852
1853    my $tablename = shift @_;
1854
1855    $tablename = lc($tablename) if ($FEEBLE_DOWNCASE);
1856
1857    if ($FEEBLE_DOWNCASE)
1858    {
1859        unless (Feeble_tablename_check($tablename))
1860        {
1861            my $msg = "invalid indentifier $tablename\n";
1862            my %earg = (self => $self, msg => $msg,
1863                        severity => 'warn');
1864
1865            &$GZERR(%earg)
1866                if (defined($GZERR));
1867            return 0;
1868        }
1869    }
1870
1871    my @outi;
1872
1873    push @outi, $tablename, @_;
1874
1875    return $self->Kgnz_Insert(@outi);
1876}
1877
1878sub Kgnz_Insert
1879{
1880#    greet @_ ;
1881    my $self = shift;
1882    my $dictobj = $self->{dictobj};
1883
1884    return undef
1885        if (@_ < 2);
1886
1887    my $tablename = shift @_ ;
1888
1889    my $collist = [];
1890
1891    return $self->Kgnz_Insert2($tablename, $collist, @_);
1892}
1893
1894sub Kgnz_Insert2
1895{
1896#    greet @_ ;
1897    my $self = shift;
1898    my $dictobj = $self->{dictobj};
1899  L_ParseInsert:
1900    {
1901	last if (@_ < 3);
1902
1903	my $tablename = shift @_ ;
1904        my $collist   = shift @_ ;
1905	my @params = @_ ;
1906
1907        my ($msg, %earg);
1908        my $severity = 'info';
1909
1910	last unless $dictobj->DictTableExists(tname => $tablename);
1911
1912        my $rowcount = 0;
1913        my @rowarr = ();
1914
1915        # take the scalar of keys for number of items in hash
1916        my $numitems
1917            = scalar(keys(%{$dictobj->DictTableGetCols (tname =>
1918                                                        $tablename)}));
1919
1920        if (scalar(@{$collist}) > $numitems)
1921        {
1922            $msg = "too many columns";
1923            %earg = (self => $self, msg => $msg,
1924                     severity => 'warn');
1925
1926            &$GZERR(%earg)
1927                if (defined($GZERR));
1928
1929            return undef;
1930        }
1931
1932        $msg = "";
1933        unless (scalar(@{$collist}))
1934        {
1935            while (@rowarr = splice (@params, 0, $numitems))
1936            {
1937
1938                unless ($dictobj->RowInsert (tname   => $tablename,
1939                                             rowval  => \@rowarr,
1940                                             dbh_ctx => $self->{dbh_ctx}
1941                                             )
1942                        )
1943                {
1944                    my $rr = $rowcount + 1;
1945                    $msg = "Failed to insert row $rr in table $tablename\n";
1946                    $severity = 'warn';
1947
1948                    last;
1949                }
1950
1951                $rowcount++;
1952                @rowarr = ();
1953            }
1954            my $rowthing = ((1 == $rowcount) ? "row" : "rows");
1955            $msg .= "inserted $rowcount $rowthing into table $tablename.\n";
1956            %earg = (self => $self, msg => $msg,
1957                     severity => $severity);
1958
1959            &$GZERR(%earg)
1960                if (defined($GZERR));
1961
1962            return $rowcount
1963        } # end unless
1964
1965        my @match;
1966        my %colh; # check for dups
1967
1968        for my $colname (@{$collist})
1969        {
1970            my $colnum;
1971
1972            unless ($colnum
1973                    = $dictobj->DictTableColExists (tname => $tablename,
1974                                                    colname => $colname))
1975            {
1976                if ($colname =~ m/(?i)^(rid|rownum)$/)
1977                {
1978                    $colname = uc $colname;
1979                    $msg = "cannot update ($colname) pseudo column";
1980                }
1981                else
1982                {
1983                    $msg = "no such column ($colname) in $tablename";
1984                }
1985                %earg = (self => $self, msg => $msg,
1986                         severity => 'warn');
1987
1988                &$GZERR(%earg)
1989                    if (defined($GZERR));
1990
1991                return undef;
1992            }
1993
1994            if (exists($colh{$colnum}))
1995            {
1996               $msg = "column ($colname) specified more than once";
1997               %earg = (self => $self, msg => $msg,
1998                        severity => 'warn');
1999
2000               &$GZERR(%earg)
2001                   if (defined($GZERR));
2002
2003                return undef;
2004            }
2005            $colh{$colnum} = 1;
2006            push @match, ($colnum - 1);
2007        } # end for all columns
2008
2009        $msg = "";
2010        while (scalar(@params))
2011        {
2012          L_mfor:
2013            for my $mm (@match)
2014            {
2015                $rowarr[$mm] = shift @params;
2016                last L_mfor
2017                    unless scalar(@params);
2018            }
2019            unless ($dictobj->RowInsert (tname   => $tablename,
2020                                         rowval  => \@rowarr,
2021                                         dbh_ctx => $self->{dbh_ctx}
2022                                         )
2023                    )
2024            {
2025                my $rr = $rowcount + 1;
2026                $msg = "Failed to insert row $rr in table $tablename\n";
2027                $severity = 'warn';
2028
2029                &$GZERR(%earg)
2030                    if (defined($GZERR));
2031
2032                last;
2033            }
2034
2035            $rowcount++;
2036            @rowarr = ();
2037
2038            # NOTE: don't bother generating null trailing columns --
2039            # unpack will create an array of existing columns, and
2040            # trailing columns will instantiate as null if
2041            # referenced...
2042#            $#rowarr = $numitems; # map for all columns
2043
2044        } # end while param
2045        my $rowthing = ((1 == $rowcount) ? "row" : "rows");
2046        $msg = "inserted $rowcount $rowthing into table $tablename.\n";
2047        %earg = (self => $self, msg => $msg,
2048                 severity => $severity);
2049
2050        &$GZERR(%earg)
2051            if (defined($GZERR));
2052
2053        return $rowcount;
2054
2055    }
2056
2057    return undef;
2058
2059} # end parseinsert
2060
2061sub Feeble_Update
2062{
2063    my $self = shift @_;
2064
2065    my $tablename = shift @_;
2066
2067    $tablename = lc($tablename) if ($FEEBLE_DOWNCASE);
2068
2069    if ($FEEBLE_DOWNCASE)
2070    {
2071        unless (Feeble_tablename_check($tablename))
2072        {
2073            my $msg = "invalid indentifier $tablename\n";
2074            my %earg = (self => $self, msg => $msg,
2075                        severity => 'warn');
2076
2077            &$GZERR(%earg)
2078                if (defined($GZERR));
2079            return 0;
2080        }
2081    }
2082
2083    my @outi;
2084
2085    push @outi, $tablename, @_;
2086
2087    return $self->Kgnz_Update(@outi);
2088
2089}
2090
2091sub Kgnz_Update
2092{
2093#    greet @_ ;
2094    my $self = shift;
2095    my $dictobj = $self->{dictobj};
2096  L_ParseUpdate:
2097    {
2098	last if (@_ < 2);
2099
2100	my $tablename = shift @_ ;
2101        my $rid = shift @_ ;
2102	my @params = @_ ;
2103
2104        my ($msg, %earg);
2105        my $severity = 'info';
2106
2107	last unless $dictobj->DictTableExists(tname => $tablename);
2108
2109	# take the scalar of keys for number of items in hash
2110	my $numitems
2111            = scalar(keys(%{$dictobj->DictTableGetCols (tname => $tablename)}));
2112
2113        my $rowcount = 0;
2114
2115        # Note: ignore extra columns -- don't loop like an insert
2116        my @rowarr = splice (@params, 0, $numitems);
2117
2118        $msg = "";
2119        {
2120            unless
2121                ($dictobj->RowUpdate (tname   => $tablename,
2122                                      rid     => $rid,
2123                                      rowval  => \@rowarr,
2124                                      dbh_ctx => $self->{dbh_ctx}
2125                                      )
2126                 )
2127                {
2128                    $msg = "failed to update row $rid : \n";
2129                    $severity = 'warn';
2130                    goto L_up1; # last
2131                }
2132
2133            $rowcount++;
2134            @rowarr = ();
2135          L_up1:
2136
2137        }
2138        my $rowthing = ((1 == $rowcount) ? "row" : "rows");
2139        $msg = "updated $rowcount $rowthing in table $tablename.\n";
2140        %earg = (self => $self, msg => $msg,
2141                 severity => $severity);
2142
2143        &$GZERR(%earg)
2144            if (defined($GZERR));
2145
2146        return $rowcount;
2147    }
2148
2149    return undef;
2150
2151} # end kgnz_update
2152
2153
2154sub SQLSelect
2155{
2156    my $self = shift;
2157    my @ggg = $self->SQLSelectPrepare(@_);
2158
2159    return undef
2160        unless (scalar(@ggg));
2161
2162    my @hhh = $self->SelectExecute(@ggg);
2163
2164    return undef
2165        unless (scalar(@hhh));
2166
2167    return $self->SelectPrint(@hhh);
2168}
2169
2170sub SQLSelectPrepare
2171{
2172    my $self = shift;
2173
2174    my $sqltxt = $self->{current_line};
2175
2176    return $self->SQLSelectPrepare2($sqltxt);
2177}
2178sub SQLSelectPrepare2
2179{
2180    my ($self, $sqltxt, $parse_tree) = @_;
2181
2182    greet $sqltxt;
2183
2184    my %plan_args = (statement => $sqltxt);
2185    if (defined($parse_tree))
2186    {
2187        $plan_args{parse_tree} = $parse_tree;
2188    }
2189
2190    my $plan_status = $self->{plan}->Plan(%plan_args);
2191
2192    if (exists($plan_status->{parse_tree}))
2193    {
2194        greet $plan_status->{parse_tree};
2195    }
2196    else
2197    {
2198        my $msg  = "Input: " . $sqltxt;
2199        my %earg = (self => $self, msg => $msg, severity => 'warn');
2200
2201        &$GZERR(%earg)
2202            if (defined($GZERR));
2203
2204        return undef;
2205    }
2206
2207    return undef
2208        unless (exists($plan_status->{algebra}));
2209
2210    my ($tc, $err_status);
2211    $tc = $plan_status->{algebra};
2212    $err_status = $plan_status->{error_status};
2213
2214    greet $tc, $err_status;
2215
2216    return undef
2217        if ($err_status);
2218
2219    ($tc, $err_status)  = $self->{xeval}->Prepare(plan => $tc);
2220
2221    return undef
2222        if ($err_status);
2223
2224    return $self->_SQLselprep_Algebra($tc);
2225}
2226
2227sub _SQLselprep_Algebra
2228{
2229    my ($self, $sql_cmd, $top_cmd) = @_;
2230    my @colpairs;
2231
2232# XXX XXX  XXX XXX  XXX XXX  XXX XXX  XXX XXX  XXX XXX
2233# XXX XXX  XXX XXX  XXX XXX  XXX XXX  XXX XXX  XXX XXX
2234# XXX XXX  XXX XXX  XXX XXX  XXX XXX  XXX XXX  XXX XXX
2235# move to XEval
2236# XXX XXX  XXX XXX  XXX XXX  XXX XXX  XXX XXX  XXX XXX
2237# XXX XXX  XXX XXX  XXX XXX  XXX XXX  XXX XXX  XXX XXX
2238# XXX XXX  XXX XXX  XXX XXX  XXX XXX  XXX XXX  XXX XXX
2239# XXX XXX  XXX XXX  XXX XXX  XXX XXX  XXX XXX  XXX XXX
2240
2241    my %nargs = (algebra   => $sql_cmd);
2242
2243    if (defined($top_cmd) &&
2244        $top_cmd =~ m/INSERT/i)
2245    {
2246        # NOTE: treat INSERT...SELECT a little different
2247        $nargs{top_cmd} = $top_cmd;
2248        greet $top_cmd, $nargs{top_cmd};
2249    }
2250
2251    my ($tc, $from, $sel_list, $where) =
2252        $self->{plan}->GetFromWhereEtc(%nargs);
2253
2254    whoami;
2255    greet $from, $sel_list, $where;
2256
2257    unless (
2258            exists($sql_cmd->{sql_query}) &&
2259            exists($sql_cmd->{sql_query}->{operands}) &&
2260            exists($sql_cmd->{sql_query}) &&
2261            exists($sql_cmd->{sql_query}->{operands}->[0]->{sql_select}) &&
2262            exists($sql_cmd->{sql_query}->{operands}->[0]->{sql_select}->{alg_oper_child})
2263            )
2264    {
2265        greet $sql_cmd->{sql_query};
2266        my $msg = "query too complex";
2267        my %earg = (self => $self, msg => $msg,
2268                    severity => 'warn');
2269
2270        &$GZERR(%earg)
2271            if (defined($GZERR));
2272
2273        return undef;
2274    }
2275
2276    my $tablename = $from->[0]->[0]->{tc_table_fullname};
2277    greet "table:",$tablename;
2278    my $tablealias = $from->[0]->[0]->{tc_table_fullalias};
2279
2280    foreach my $i (@{$sel_list})
2281    {
2282        my $v1 = $i->{value_expression};
2283        my $val;
2284        if (ref($v1) eq 'HASH')
2285        {
2286            if (exists($i->{value_expression}->{tc_column_name}))
2287            {
2288                $val = $i->{value_expression}->{tc_column_name};
2289            }
2290            elsif (exists($i->{value_expression}->{function_name}))
2291            {
2292                $val = $i->{value_expression}->{function_name};
2293            }
2294        }
2295
2296        my $nam = $i->{tc_col_header};
2297
2298        if (!defined($val))
2299        {
2300            # XXX XXX XXX XXX XXX XXX XXX XXX XXX XXX
2301            # XXX XXX XXX XXX XXX XXX XXX XXX XXX XXX
2302            # placeholder - not necessary anymore
2303            # XXX XXX XXX XXX XXX XXX XXX XXX XXX XXX
2304            # XXX XXX XXX XXX XXX XXX XXX XXX XXX XXX
2305#            $val = '$tc_rid';
2306            $val = '$rid';
2307            if (0)
2308            {
2309
2310                my $msg = "cannot process column for $nam";
2311                my %earg = (self => $self, msg => $msg,
2312                            severity => 'warn');
2313
2314                &$GZERR(%earg)
2315                    if (defined($GZERR));
2316
2317                return undef;
2318            }
2319        }
2320
2321        push @colpairs, [$val, $nam];
2322    }
2323
2324    if (defined($where))
2325    {
2326        greet $where;
2327    }
2328
2329    return ($self->CommonSelectPrepare(tablename   => $tablename,
2330                                       tablealias  => $tablealias,
2331                                       colpairs    => \@colpairs,
2332                                       where2      => $where,
2333                                       select_list => $sel_list,
2334                                       alg_plan    => $sql_cmd,
2335                                       alg_from    => $from
2336                                       )
2337            );
2338}
2339
2340
2341sub SQLCreate
2342{
2343    my $self = shift;
2344    my $dictobj = $self->{dictobj};
2345    my $sqltxt = $self->{current_line};
2346
2347    my $plan_status = $self->{plan}->Plan(statement => $sqltxt);
2348
2349    if (exists($plan_status->{parse_tree}))
2350    {
2351        greet $plan_status->{parse_tree};
2352    }
2353    else
2354    {
2355        my $msg  = "Input: " . $sqltxt;
2356        my %earg = (self => $self, msg => $msg, severity => 'warn');
2357
2358        &$GZERR(%earg)
2359            if (defined($GZERR));
2360
2361        return undef;
2362    }
2363
2364    return undef
2365        unless (exists($plan_status->{algebra}));
2366
2367    my ($tc, $err_status);
2368    $tc = $plan_status->{algebra};
2369    $err_status = $plan_status->{error_status};
2370
2371    greet "SQLCREATE:", $tc, $err_status;
2372
2373    return undef
2374        if ($err_status);
2375
2376    ($tc, $err_status)  = $self->{xeval}->Prepare(plan => $tc);
2377
2378    return undef
2379        if ($err_status);
2380
2381    unless (exists($tc->{sql_create})
2382        && exists($tc->{sql_create}->{create_op}))
2383    {
2384        my $msg  = "Unknown CREATE operation: " . $sqltxt;
2385        my %earg = (self => $self, msg => $msg, severity => 'warn');
2386
2387        &$GZERR(%earg)
2388            if (defined($GZERR));
2389
2390        return undef;
2391    }
2392
2393    if ($tc->{sql_create}->{create_op} eq 'TABLE')
2394    {
2395        my $tablename = $tc->{sql_create}->{tc_newtable_fullname};
2396
2397        greet $tablename;
2398
2399        if (exists($tc->{sql_create}->{table_def})
2400            && exists($tc->{sql_create}->{table_def}->{tab_column_list}))
2401        {
2402            my @outi;
2403
2404            push @outi, $tablename;
2405
2406            my $nargs = {};     # pass arguments in a sneaky way...
2407            push @outi, $nargs;
2408
2409            if (exists($tc->{sql_create}->{table_def}->{storage_clause}))
2410            {
2411                my $st_clause =
2412                    $tc->{sql_create}->{table_def}->{storage_clause};
2413
2414                for my $item (@{$st_clause})
2415                {
2416                    if (exists($item->{store_op}) &&
2417                        ($item->{store_op} =~ m/tablespace/i))
2418                    {
2419                        $nargs->{tablespace} =
2420                            $item->{tc_tablespace_fullname};
2421                    }
2422                }
2423            }
2424
2425            my $clist = $tc->{sql_create}->{table_def}->{tab_column_list};
2426            for my $coldef (@{$clist->[0]})
2427            {
2428                my $colname = $coldef->{tc_newcolumn_name};
2429
2430                unless (scalar(@{$coldef->{column_type}}))
2431                {
2432                    my $msg  = "Cannot CREATE TABLE ($tablename) -- " .
2433                        "No type information for column ($colname)";
2434                    my %earg = (self => $self, msg => $msg,
2435                                severity => 'warn');
2436
2437                    &$GZERR(%earg)
2438                        if (defined($GZERR));
2439
2440                    return undef;
2441                }
2442
2443                my $coltype = $coldef->{column_type}->[0]->{base};
2444                push @outi, "$colname=$coltype";
2445            }
2446            return $self->Kgnz_CT(@outi);
2447        }
2448    } # end create table
2449
2450    if ($tc->{sql_create}->{create_op} eq 'INDEX')
2451    {
2452        my $iname     = $tc->{sql_create}->{tc_newindex_fullname};
2453        my $tablename = $tc->{sql_create}->{tc_table_fullname};
2454
2455        my @outi;
2456        my $nargs = {};     # pass arguments in a sneaky way...
2457
2458        push @outi, $iname, $nargs, $tablename;
2459
2460        if (exists($tc->{sql_create}->{storage_clause}))
2461        {
2462            my $st_clause =
2463                $tc->{sql_create}->{storage_clause};
2464
2465            for my $item (@{$st_clause})
2466            {
2467                if (exists($item->{store_op}) &&
2468                    ($item->{store_op} =~ m/tablespace/i))
2469                {
2470                    $nargs->{tablespace} =
2471                        $item->{tc_tablespace_fullname};
2472                }
2473            }
2474        } # end if storage clause
2475
2476        greet $iname, $tablename;
2477
2478        if (exists($tc->{sql_create}->{tc_column_list}))
2479        {
2480            push @outi, @{$tc->{sql_create}->{tc_column_list}};
2481
2482            return $self->Kgnz_CIdx(@outi);
2483        }
2484    } # end create index
2485
2486    if ($tc->{sql_create}->{create_op} eq 'TABLESPACE')
2487    {
2488        my $tsname = $tc->{sql_create}->{tc_newtablespace_fullname};
2489
2490        greet $tsname;
2491
2492        if (1)
2493        {
2494            my @outi;
2495
2496            push @outi,  $tsname;
2497
2498            return $self->Kgnz_CreateTS(@outi);
2499        }
2500    } # end create index
2501
2502    {
2503        my $msg  = "Unknown CREATE operation: " . $sqltxt;
2504        my %earg = (self => $self, msg => $msg, severity => 'warn');
2505
2506        &$GZERR(%earg)
2507            if (defined($GZERR));
2508
2509        return undef;
2510    }
2511
2512} # end SQLCreate
2513
2514sub SQLAlter
2515{
2516    my $self = shift;
2517    my $dictobj = $self->{dictobj};
2518    my $sqltxt = $self->{current_line};
2519
2520    my $plan_status = $self->{plan}->Plan(statement => $sqltxt);
2521
2522    if (exists($plan_status->{parse_tree}))
2523    {
2524        greet $plan_status->{parse_tree};
2525    }
2526    else
2527    {
2528        my $msg  = "Input: " . $sqltxt;
2529        my %earg = (self => $self, msg => $msg, severity => 'warn');
2530
2531        &$GZERR(%earg)
2532            if (defined($GZERR));
2533
2534        return undef;
2535    }
2536
2537    return undef
2538        unless (exists($plan_status->{algebra}));
2539
2540    my ($tc, $err_status);
2541    $tc = $plan_status->{algebra};
2542    $err_status = $plan_status->{error_status};
2543
2544    greet $tc, $err_status;
2545
2546    return undef
2547        if ($err_status);
2548
2549    ($tc, $err_status)  = $self->{xeval}->Prepare(plan => $tc);
2550
2551    return undef
2552        if ($err_status);
2553
2554    # XXX XXX: need AndPurity in typecheck
2555
2556    return  ($self->{xeval}->SQLAlter(plan    => $tc,
2557                                      dbh_ctx => $self->{dbh_ctx}
2558                                      ));
2559
2560} # end SQLAlter
2561
2562sub SQLUpdate
2563{
2564    my $self = shift;
2565    my $dictobj = $self->{dictobj};
2566    my $sqltxt = $self->{current_line};
2567
2568    my ($msg, %earg);
2569    my $severity = 'info';
2570
2571    my $tablename;
2572    my @sel_prep;
2573
2574    my ($rownum, $rowcount) = (0, 0);
2575
2576    my $plan_status = $self->{plan}->Plan(statement => $sqltxt);
2577
2578    if (exists($plan_status->{parse_tree}))
2579    {
2580        greet $plan_status->{parse_tree};
2581    }
2582    else
2583    {
2584        my $msg  = "Input: " . $sqltxt;
2585        my %earg = (self => $self, msg => $msg, severity => 'warn');
2586
2587        &$GZERR(%earg)
2588            if (defined($GZERR));
2589
2590        return undef;
2591    }
2592
2593    return undef
2594        unless (exists($plan_status->{algebra}));
2595
2596    my ($tc, $err_status);
2597    $tc = $plan_status->{algebra};
2598    $err_status = $plan_status->{error_status};
2599
2600    greet $tc, $err_status;
2601
2602    return undef
2603        if ($err_status);
2604
2605    ($tc, $err_status)  = $self->{xeval}->Prepare(plan => $tc);
2606
2607    return undef
2608        if ($err_status);
2609
2610    my %update_col;
2611
2612    $tablename = $tc->{sql_update}->{tc_table_fullname};
2613    my $where  = $tc->{sql_update}->{where_clause};
2614
2615    # walk the list of update expressions -- check for duplicates
2616    for my $update_expr (@{$tc->{sql_update}->{update_set_exprlist}})
2617    {
2618        my $col1  = $update_expr->{update_columns}->{tc_column_name};
2619        my $expr1 = $update_expr->{update_sources}->{vx_txt};
2620
2621        if (exists($update_col{$col1}))
2622        {
2623            $msg  = "Duplicate update column ($col1), table ($tablename)";
2624            %earg = (self => $self, msg => $msg, severity => 'warn');
2625
2626            &$GZERR(%earg)
2627                if (defined($GZERR));
2628
2629            return undef;
2630            # goto L_update_fini;
2631        }
2632        $update_col{$col1} = $expr1;
2633    }
2634    greet %update_col;
2635
2636    my $allcols = $dictobj->DictTableGetCols (tname => $tablename);
2637
2638    # build a vector of all table columns, starting with rid.
2639    # If the column had an update expression, replace it with that
2640    # expression.
2641    my @colvec;
2642    $colvec[0] = "rid";
2643
2644    while (my ($kk, $vv) = each (%{$allcols}))
2645    {
2646        my ($colidx, $dtype) = @{$vv};
2647
2648        if (exists($update_col{$kk}))
2649        {
2650            # use the update expression
2651            $colvec[$colidx] = $update_col{$kk};
2652        }
2653        else
2654        {
2655            # use the current column value
2656            $colvec[$colidx] = $kk;
2657        }
2658    }
2659
2660
2661    # NOTE: would be nice to avoid parsing a SELECT statement after we
2662    # parsed the UPDATE.  Should optimize this code.
2663
2664    my $sel_query = "select " . join(', ', @colvec) . " from \"$tablename\" ";
2665
2666    if (defined($where) && scalar(@{$where}))
2667    {
2668        # add the WHERE clause if it exists
2669        $sel_query .= " where " . $where->[0]->{sc_txt} ;
2670    }
2671
2672    greet $sel_query;
2673
2674    # prepare the new SELECT
2675    @sel_prep = $self->SQLSelectPrepare2($sel_query);
2676
2677    return undef
2678        # goto L_update_fini;
2679        unless (scalar(@sel_prep));
2680
2681    my @selex_state = $self->SelectExecute(@sel_prep);
2682
2683    return undef
2684        # goto L_update_fini;
2685        unless (scalar(@selex_state));
2686
2687    my ($key, @vals, @outi);
2688
2689    # select out all the rows first (consistent read)
2690
2691    $msg = "";
2692    while (1)
2693    {
2694        ($key, $rownum, @vals) =
2695            $self->SelectFetch($key, $rownum, @selex_state);
2696        last
2697            unless (defined($rownum));
2698
2699        my $newref = [@vals];
2700        push @outi, $newref;
2701    } # end while 1
2702
2703    for my $ii (@outi)
2704    {
2705        my @rowarr = @{$ii};
2706        my $rid = shift @rowarr;
2707
2708        unless
2709            ($dictobj->RowUpdate (tname   => $tablename,
2710                                  rid     => $rid,
2711                                  rowval  => \@rowarr,
2712                                  dbh_ctx => $self->{dbh_ctx}
2713                                  )
2714             )
2715        {
2716            $msg = "failed to update row $rid : \n";
2717            $severity = 'warn';
2718            last;
2719        }
2720
2721        $rowcount++;
2722
2723    } # end for
2724
2725  L_update_fini:
2726
2727    my $rowthing = ((1 == $rowcount) ? "row" : "rows");
2728    $msg = "updated $rowcount $rowthing in table $tablename.\n";
2729    %earg = (self => $self, msg => $msg,
2730             severity => $severity);
2731
2732    &$GZERR(%earg)
2733        if (defined($GZERR));
2734
2735    return $rowcount;
2736
2737} # end sqlupdate
2738
2739sub SQLInsert
2740{
2741    my $self = shift;
2742
2743    my $sqltxt = $self->{current_line};
2744
2745    my (@got_vals, @sel_prep_info);
2746
2747    my $plan_status = $self->{plan}->Plan(statement => $sqltxt);
2748
2749    if (exists($plan_status->{parse_tree}))
2750    {
2751        greet $plan_status->{parse_tree};
2752    }
2753    else
2754    {
2755        my $msg  = "Input: " . $sqltxt;
2756        my %earg = (self => $self, msg => $msg, severity => 'warn');
2757
2758        &$GZERR(%earg)
2759            if (defined($GZERR));
2760
2761        return undef;
2762    }
2763
2764    return undef
2765        unless (exists($plan_status->{algebra}));
2766
2767    my ($tc, $err_status);
2768    $tc = $plan_status->{algebra};
2769    $err_status = $plan_status->{error_status};
2770
2771    greet $tc, $err_status;
2772
2773    return undef
2774        if ($err_status);
2775
2776    ($tc, $err_status)  = $self->{xeval}->Prepare(plan => $tc);
2777
2778    return undef
2779        if ($err_status);
2780
2781
2782    my @iii =  ($self->{xeval}->SQLInsert(plan    => $tc,
2783                                          dbh_ctx => $self->{dbh_ctx},
2784                                          dict    => $self->{dictobj},
2785                                          magic_dbh => $self
2786                                          ));
2787
2788    return undef
2789        unless (scalar(@iii) > 1);
2790
2791    if (scalar(@iii) > 1)
2792    {
2793        if ($iii[0] =~ m/vanilla/)
2794        {
2795            my $sth = $iii[1];
2796            greet $sth->SQLExecute();
2797            my @foo = $sth->SQLFetch();
2798
2799            while (scalar(@foo) > 1)
2800            {
2801                push @got_vals, @{$foo[1]};
2802                greet @foo, @got_vals;
2803                # join(" ", @foo), "\n";
2804                @foo = $sth->SQLFetch();
2805            }
2806        }
2807        else
2808        {
2809#            my @ggg = $self->SQLSelectPrepare($iii[1]);
2810            @sel_prep_info = $self->_SQLselprep_Algebra($iii[1], "INSERT");
2811
2812        }
2813    }
2814
2815    my @outi;
2816    my $tabinfo = $tc->{sql_insert}->[0]->{insert_tabinfo};
2817
2818#    push @outi, $sql_cmd->{tablename};
2819#    push @outi, $sql_cmd->{colnames};
2820    my $tablename   = $tabinfo->{tc_table_fullname};
2821    my $column_list = # create an empty column list if none exists
2822        (exists($tabinfo->{tc_column_list})) ?
2823        $tabinfo->{tc_column_list} : [];
2824
2825    push @outi, $tablename, $column_list;
2826
2827
2828    my ($key, $rownum, @vals, @selex_state);
2829    my @padnulls;
2830
2831    if (scalar(@got_vals))
2832    {
2833        # INSERT ... VALUES - done!
2834        push @outi, @got_vals;
2835        greet @outi;
2836    }
2837    # if INSERT SELECT
2838    elsif (scalar(@sel_prep_info))
2839    {
2840        my $colcnt = scalar(@{$column_list});
2841
2842        unless ($colcnt)
2843        {
2844            my $dictobj = $self->{dictobj};
2845
2846            return undef
2847                unless ($dictobj->DictTableExists (tname =>
2848                                                   $tablename));
2849            $colcnt
2850                = scalar(keys(%{$dictobj->
2851                                    DictTableGetCols (tname =>
2852                                                      $tablename
2853                                                      )}));
2854        }
2855
2856#        greet $sql_cmd->{selclause};
2857
2858#        greet @sel_prep_info;
2859        # compare insert column list to select list
2860        # XXX XXX : need to fix here too
2861        # XXX XXX : if too few cols  pad remainder with nulls
2862        my $comp = ($colcnt <=> scalar(@{$sel_prep_info[2]}));
2863
2864        if (1 == $comp)
2865        {
2866            # extend an array of nulls
2867            $padnulls[($colcnt - scalar(@{$sel_prep_info[2]})) - 1] = undef;
2868        }
2869
2870        if (-1 == $comp) # should be zero if match
2871#        unless (0 == $comp) # should be zero if match
2872        {
2873            my $msg = "Cannot insert: too " . (($comp == -1) ? "many": "few") .
2874            " columns in SELECT list\n";
2875            my %earg = (self => $self, msg => $msg,
2876                        severity => 'warn');
2877
2878            &$GZERR(%earg)
2879                if (defined($GZERR));
2880
2881            return undef;
2882        }
2883
2884        my @selex_state = $self->SelectExecute(@sel_prep_info);
2885
2886        return undef
2887            unless (scalar(@selex_state));
2888
2889        $rownum = 0;
2890
2891        # fetch all rows if self-modifying table -- kind of expensive...
2892        my $fetchall = ($tablename eq $sel_prep_info[0]);
2893#        greet @sel_prep_info;
2894
2895        # XXX XXX XXX: could do multiple inserts if not self-modifying table
2896        while (1)
2897        {
2898            ($key, $rownum, @vals) =
2899                $self->SelectFetch($key, $rownum, @selex_state);
2900            last
2901                unless (defined($rownum));
2902
2903#            greet $key, $rownum,  @vals;
2904
2905            push @outi, @vals;
2906            push @outi, @padnulls
2907                if (scalar(@padnulls));
2908#            last
2909#                unless ($fetchall); XXX XXX : doesn't work right...
2910        }
2911    }
2912    else
2913    {
2914        # XXX XXX XXX : ???
2915    }
2916
2917    my $colcnt = 0;
2918
2919    my $ins_stat = $self->Kgnz_Insert2(@outi);
2920
2921    return $colcnt # check for insertion failure
2922        unless (defined($ins_stat));
2923
2924    $colcnt += $ins_stat;
2925
2926  L_fetchins:
2927    while (defined($key))
2928    {
2929        @outi = ();
2930
2931        push @outi, $tablename;
2932        push @outi, $column_list;
2933
2934        for my $ii (1..10) # do a multirow insert
2935        {
2936            ($key, $rownum, @vals) =
2937                $self->SelectFetch($key, $rownum, @selex_state);
2938            last  L_fetchins
2939                unless (defined($key));
2940
2941            push @outi, @vals;
2942            push @outi, @padnulls
2943                if (scalar(@padnulls));
2944
2945        }
2946
2947        my $istat2 = $self->Kgnz_Insert2(@outi);
2948
2949        return $colcnt
2950            unless (defined($istat2));
2951
2952        $colcnt += $istat2;
2953
2954    }
2955
2956    return ($colcnt);
2957
2958}
2959
2960sub SQLDelete
2961{
2962    my $self = shift;
2963
2964    my $sqltxt = $self->{current_line};
2965
2966    my $plan_status = $self->{plan}->Plan(statement => $sqltxt);
2967
2968    if (exists($plan_status->{parse_tree}))
2969    {
2970        greet $plan_status->{parse_tree};
2971    }
2972    else
2973    {
2974        my $msg  = "Input: " . $sqltxt;
2975        my %earg = (self => $self, msg => $msg, severity => 'warn');
2976
2977        &$GZERR(%earg)
2978            if (defined($GZERR));
2979
2980        return undef;
2981    }
2982
2983    return undef
2984        unless (exists($plan_status->{algebra}));
2985
2986    my ($tc, $err_status);
2987    $tc = $plan_status->{algebra};
2988    $err_status = $plan_status->{error_status};
2989
2990    greet $tc, $err_status;
2991
2992    return undef
2993        if ($err_status);
2994
2995    ($tc, $err_status)  = $self->{xeval}->Prepare(plan => $tc);
2996
2997    return undef
2998        if ($err_status);
2999
3000    my ($tablename, $where, $where_clause);
3001
3002    {
3003        $tablename = $tc->{sql_delete}->{tc_table_fullname};
3004        if (scalar(@{$tc->{sql_delete}->{where_clause}}))
3005        {
3006            $where_clause = $tc->{sql_delete}->{where_clause}->[0]->{sc_txt};
3007        }
3008    }
3009
3010    my $sel = "select rid from \"$tablename\" ";
3011    $sel .= "where " . $where_clause
3012        if (defined($where_clause));
3013
3014#    greet $sel;
3015
3016    my $ftch_aryref = $self->selectall_arrayref($sel);
3017
3018#    greet @ftchary;
3019
3020    return undef
3021        unless (defined($ftch_aryref));
3022
3023    unless (scalar(@{$ftch_aryref}))
3024    {
3025        my $msg = "deleted 0 rows from table $tablename.\n";
3026        my %earg = (self => $self, msg => $msg,
3027                    severity => 'warn');
3028
3029        &$GZERR(%earg)
3030            if (defined($GZERR));
3031
3032        return 0;
3033    }
3034
3035    my @ridlist;
3036
3037    for my $ii (@{$ftch_aryref})
3038    {
3039        push @ridlist, $ii->[0];
3040    }
3041#    greet @ridlist;
3042
3043    return $self->Kgnz_Delete($tablename, @ridlist);
3044}
3045
3046
3047sub SQLDrop
3048{
3049    my $self = shift;
3050
3051    my $sqltxt = $self->{current_line};
3052
3053    my $plan_status = $self->{plan}->Plan(statement => $sqltxt);
3054
3055    if (exists($plan_status->{parse_tree}))
3056    {
3057        greet $plan_status->{parse_tree};
3058    }
3059    else
3060    {
3061        my $msg  = "Input: " . $sqltxt;
3062        my %earg = (self => $self, msg => $msg, severity => 'warn');
3063
3064        &$GZERR(%earg)
3065            if (defined($GZERR));
3066
3067        return undef;
3068    }
3069
3070    return undef
3071        unless (exists($plan_status->{algebra}));
3072
3073    my ($tc, $err_status);
3074    $tc = $plan_status->{algebra};
3075    $err_status = $plan_status->{error_status};
3076
3077    greet $tc, $err_status;
3078
3079    return undef
3080        if ($err_status);
3081
3082    ($tc, $err_status)  = $self->{xeval}->Prepare(plan => $tc);
3083
3084    return undef
3085        if ($err_status);
3086
3087    if (exists($tc->{sql_drop}))
3088    {
3089        if (exists($tc->{sql_drop}->{tc_table_fullname}))
3090        {
3091
3092            my ($tablename, $stat);
3093
3094            $tablename = $tc->{sql_drop}->{tc_table_fullname};
3095
3096            my $dictobj = $self->{dictobj};
3097
3098            $stat = $dictobj->DictTableDrop (tname   => $tablename,
3099                                             dbh_ctx => $self->{dbh_ctx}
3100                                             );
3101
3102            return $stat;
3103        }
3104
3105
3106    }
3107    my $msg  = "Input: " . $sqltxt;
3108    my %earg = (self => $self, msg => $msg, severity => 'warn');
3109
3110    &$GZERR(%earg)
3111        if (defined($GZERR));
3112
3113    return undef;
3114
3115
3116}
3117
3118sub HCountPrepare
3119{
3120    my $self = shift;
3121    my $dictobj = $self->{dictobj};
3122    my @outi;
3123    my $filter;
3124
3125  L_sel:
3126    {
3127	last if (@_ < 1);
3128
3129	my $tablename = shift @_ ;
3130
3131	last unless $dictobj->DictTableExists (tname => $tablename);
3132
3133        my $prep_th = {tablename => $tablename};
3134        push @outi, $prep_th;
3135        push @outi, "HCOUNT";
3136        push @outi, ["COUNT(*)"];
3137        push @outi, [
3138                     {name  => "COUNT(*)",
3139                      alias => "COUNT(*)",
3140                      type  => "n"}
3141                     ]; # no colnums
3142        push @outi, $filter; # filter
3143    }
3144    return @outi;
3145} # hcountprepare
3146
3147sub HCountFetch
3148{
3149    my $self = shift;
3150    my ($kk, $rownum, $hashi, $sth, $seltype, $colnames, $collist) = @_;
3151    my $dictobj = $self->{dictobj};
3152    my @outi;
3153
3154  L_sel:
3155    {
3156	last if (@_ < 1);
3157
3158        last if ($rownum);
3159
3160        my $tv = tied(%{$hashi});
3161
3162        push @outi, $tv->HCount();
3163    }
3164
3165    return @outi;
3166} # hcountfetch
3167
3168sub HCountPrint
3169{
3170    my $self = shift;
3171    my ($hashi, $sth, $seltype, $colnames, $collist) = @_;
3172    my $rownum = 0;
3173    my $dictobj = $self->{dictobj};
3174    my $stat;
3175
3176  L_sel:
3177    {
3178	last if (@_ < 1);
3179
3180        my $msg = "COUNT(*)\n";
3181        $msg .= "--------\n";
3182
3183        my $tv = tied(%{$hashi});
3184
3185        $msg .= $tv->HCount() . "\n\n";
3186
3187        my %earg = (self => $self, msg => $msg,
3188                    severity => 'info');
3189
3190        &$GZERR(%earg)
3191            if (defined($GZERR));
3192
3193
3194        $rownum++;
3195
3196        $msg = ($rownum ? $rownum : "no") ;
3197        $msg .= ((1 == $rownum) ? " row " : " rows ") .
3198            "selected.\n";
3199        %earg = (self => $self, msg => $msg,
3200                 severity => 'info');
3201
3202        &$GZERR(%earg)
3203            if (defined($GZERR));
3204
3205        $stat = $rownum;
3206    }
3207
3208    return $stat;
3209} # hcount
3210
3211sub ECountPrepare
3212{
3213    my $self = shift;
3214    my $dictobj = $self->{dictobj};
3215    my @outi;
3216    my $filter;
3217
3218  L_sel:
3219    {
3220	last if (@_ < 1);
3221
3222	my $tablename = shift @_ ;
3223
3224	last unless $dictobj->DictTableExists (tname => $tablename);
3225
3226        my $prep_th = {tablename => $tablename};
3227        push @outi, $prep_th;
3228        push @outi, "ECOUNT";
3229        my @colaliaslist = ("ESTIMATE", "CURRENT", "STDDEV", "PCT_COMPLETE");
3230        push @outi, \@colaliaslist;
3231        my @collist;
3232        for my $val (@colaliaslist)
3233        {
3234            push @collist , { # no colnums
3235                name  => $val,
3236                alias => $val,
3237                type  => "n" };
3238
3239        }
3240        push @outi, \@collist;
3241        push @outi, $filter; # filter
3242
3243    }
3244    return @outi;
3245} # ecountprepare
3246
3247sub ECountFetch
3248{
3249    my $self = shift;
3250    my ($kk, $rownum, $hashi, $sth, $seltype, $colnames, $collist) = @_;
3251    my $dictobj = $self->{dictobj};
3252    my @outi;
3253    my @ggg;
3254
3255  L_sel:
3256    {
3257	last if (@_ < 1);
3258
3259        my $tv = tied(%{$hashi});
3260
3261        if ($rownum)
3262        {
3263            push @ggg, @{$kk};
3264        }
3265        else
3266        {
3267            @ggg = $tv->FirstCount();
3268        }
3269
3270        while (scalar(@ggg) > 4)
3271        {
3272            @ggg = $tv->NextCount(@ggg);
3273
3274            last
3275                unless (scalar(@ggg) > 4);
3276
3277            my @g2 = @ggg;
3278               $kk = shift @g2;
3279            my $est    = shift @g2;
3280            my $sum    = shift @g2;
3281            my $sumsq  = 0;
3282            $sumsq  = shift @g2;
3283            my $ccnt   = shift @g2;
3284            my $tot    = shift @g2;
3285            my $pct    = ($ccnt/$tot) *100;
3286
3287            my $var = 0;
3288            $var = ($sumsq - (($sum**2)/$ccnt))/($ccnt - 1)
3289                unless ($ccnt < 2); # var = 0 when numelts = 1
3290
3291#        my $stddev = sqrt($sumsq);
3292            my $stddev = sqrt($var);
3293
3294            # confidence interval : 1-alpha ~= 2 for 90% conf,
3295            # 60+ samples, student-t, GAUSSIAN DATA ONLY
3296            #
3297            # mean +/-  2*stddev/sqrt(samplesize)
3298
3299            my $alpha = 100; # 2
3300
3301            my $conf = $alpha*$stddev/sqrt($ccnt);
3302
3303            push @outi, $est,$sum,$stddev,$pct;
3304
3305            last
3306#                unless (defined($kk));
3307
3308        } # end while
3309    }
3310
3311    if (scalar(@outi))
3312    {
3313#        unshift @outi, $rownum; # XXX : rownum set by selectfetch
3314        unshift @outi, \@ggg;
3315    }
3316
3317
3318    return @outi;
3319} # end ecountfetch
3320
3321sub ECountPrint
3322{
3323    my $self = shift;
3324    my ($hashi, $sth, $seltype, $colnames, $colnums) = @_;
3325    my $rownum = 0;
3326    my $dictobj = $self->{dictobj};
3327    my $stat;
3328
3329  L_sel:
3330    {
3331	last if (@_ < 1);
3332
3333        my $msg = "ESTIMATE\tCURRENT\tSTDDEV\tPCT_COMPLETE\n";
3334        $msg .=  "--------\t-------\t------\t------------\n";
3335
3336        my %earg = (self => $self, msg => $msg,
3337                    severity => 'info');
3338
3339        &$GZERR(%earg)
3340            if (defined($GZERR));
3341
3342        my $tv = tied(%{$hashi});
3343
3344        my @ggg = $tv->FirstCount();
3345
3346        while (scalar(@ggg) > 4)
3347        {
3348            @ggg = $tv->NextCount(@ggg);
3349
3350            my @g2 = @ggg;
3351            my $kk = shift @g2;
3352            my $est    = shift @g2;
3353            my $sum    = shift @g2;
3354            my $sumsq  = 0;
3355            $sumsq  = shift @g2;
3356            my $ccnt   = shift @g2;
3357            my $tot    = shift @g2;
3358            my $pct    = ($ccnt/$tot) *100;
3359
3360            my $var = 0;
3361            $var = ($sumsq - (($sum**2)/$ccnt))/($ccnt - 1)
3362                unless ($ccnt < 2); # var = 0 when numelts = 1
3363
3364#        my $stddev = sqrt($sumsq);
3365            my $stddev = sqrt($var);
3366
3367            # confidence interval : 1-alpha ~= 2 for 90% conf,
3368            # 60+ samples, student-t, GAUSSIAN DATA ONLY
3369            #
3370            # mean +/-  2*stddev/sqrt(samplesize)
3371
3372            my $alpha = 100; # 2
3373
3374            my $conf = $alpha*$stddev/sqrt($ccnt);
3375
3376            $msg = sprintf "%.2f\t%d\t%.2f\t%.2f\n",
3377            $est,$sum,$stddev,$pct;
3378
3379            %earg = (self => $self, msg => $msg,
3380                     severity => 'info');
3381
3382            &$GZERR(%earg)
3383                if (defined($GZERR));
3384
3385            $rownum++;
3386
3387            last
3388                unless (defined($kk));
3389
3390        } # end while
3391        $msg = "\n";
3392
3393        $msg .= ($rownum ? $rownum : "no") ;
3394        $msg .= ((1 == $rownum) ? " row " : " rows ") .
3395            "selected.\n";
3396        %earg = (self => $self, msg => $msg,
3397                    severity => 'info');
3398
3399        &$GZERR(%earg)
3400            if (defined($GZERR));
3401
3402        $stat = $rownum;
3403    } # end l_sel
3404
3405    return $stat;
3406} # ecountprint
3407
3408sub Feeble_Select
3409{
3410    my $self = shift;
3411
3412    my @outi = ($FEEBLE_DOWNCASE) ? map(lc, @_) : @_;
3413
3414    if ($FEEBLE_DOWNCASE && scalar(@outi))
3415    {
3416        my $tablename = $outi[0];
3417
3418        unless (Feeble_tablename_check($tablename))
3419        {
3420            my $msg = "invalid indentifier $tablename\n";
3421            my %earg = (self => $self, msg => $msg,
3422                        severity => 'warn');
3423
3424            &$GZERR(%earg)
3425                if (defined($GZERR));
3426            return 0;
3427        }
3428    }
3429
3430    return $self->Kgnz_Select(@outi);
3431
3432}
3433
3434sub Kgnz_Select
3435{
3436    my $self = shift;
3437    my @ggg = $self->CommonSelectPrepare(basic => \@_);
3438
3439    return undef
3440        unless (scalar(@ggg));
3441
3442    my @hhh = $self->SelectExecute(@ggg);
3443
3444    return undef
3445        unless (scalar(@hhh));
3446
3447    return $self->SelectPrint(@hhh);
3448}
3449
3450sub CommonSelectPrepare
3451{
3452    my $self = shift;
3453    my $dictobj = $self->{dictobj};
3454    my %args = (
3455		@_);
3456
3457    my $rxrid     = '(^rid$)';
3458    my $rxrownum  = '(^rownum$)';
3459    my $rxcols    = '(^rid$)|(^rownum$)';
3460    my $rxhcount  = '(^count$)';
3461    my $rxecount  = '(^ecount$)';
3462    my @outi;
3463
3464    my ($tablename, $colpairs, $filter);
3465
3466    if (defined($args{basic}))
3467    {
3468        $tablename = shift @{$args{basic}};
3469
3470        $colpairs = [];
3471        for my $val (@{$args{basic}})
3472        {
3473            push @{$colpairs}, [$val, $val];
3474        }
3475    }
3476    else
3477    {
3478        # XXX XXX: should check these!
3479        unless (defined($args{tablename}))
3480        {
3481            whisper "no tablename!";
3482            my $msg = "no tablename";
3483            my %earg = (self => $self, msg => $msg,
3484                        severity => 'warn');
3485
3486            &$GZERR(%earg)
3487                if (defined($GZERR));
3488
3489            return @outi;
3490        }
3491        $tablename = $args{tablename};
3492        $colpairs  = $args{colpairs};
3493
3494        if (defined($args{where2}))
3495        {
3496            return @outi # make sure have a table
3497                unless $dictobj->DictTableExists (tname => $tablename);
3498
3499            $filter =
3500                $self->{plan}->SQLWhere2(tablename => $tablename,
3501                                         where => $args{where2});
3502
3503            unless (defined($filter))
3504            {
3505                whisper "invalid where clause";
3506
3507                my $msg = "invalid where clause";
3508                my %earg = (self => $self, msg => $msg,
3509                            severity => 'warn');
3510
3511                &$GZERR(%earg)
3512                    if (defined($GZERR));
3513
3514                return @outi;
3515            }
3516        }
3517
3518
3519    }
3520
3521  L_sel:
3522    {
3523	last if (@_ < 1);
3524
3525	last unless $dictobj->DictTableExists (tname => $tablename);
3526
3527        last unless (scalar(@{$colpairs}));
3528
3529        my (@colaliaslist, @collist);
3530
3531        my $pindx = 0;
3532
3533      L_PPL:
3534        foreach my $pair (@{$colpairs})
3535        {
3536            $pindx++;
3537
3538            my ($colname, $colalias) =  @{$pair};
3539
3540            return $self->HCountPrepare($tablename)
3541                if ($colname =~ m/$rxhcount/i );
3542
3543            return $self->ECountPrepare($tablename)
3544                if ($colname =~ m/$rxecount/i );
3545
3546            if ($colname =~ m/$rxcols/i )
3547            {
3548                push @colaliaslist, $colalias ;
3549                push @collist, {colnum => lc($colname),
3550                                name   => lc($colname),
3551                                alias  => $colalias,
3552                                type   => # c for rid, n for rownum
3553                                    (($colname =~ m/$rxrid/i) ? "c" : "n")
3554                                };
3555
3556                next L_PPL;
3557            }
3558
3559            if ($colname eq '*' )
3560            {
3561                my %allcols
3562                    = % { $dictobj->DictTableGetCols (tname => $tablename) };
3563
3564                # $$$ $$$ need Tie::IxHash to avoid this nonsense
3565
3566                # build an array of colname, colidx, coltype
3567                # ordered by colidx
3568                while (my ($kk, $vv) = each (%allcols))
3569                {
3570                    my @rarr = @{ $vv };
3571
3572                                          # colname, colidx, coltype
3573                    $outi[ $rarr[0]-1 ] = [$kk, @rarr] ;
3574                }
3575
3576                my $ccount = 1;
3577
3578                foreach my $vv (@outi)
3579                {
3580                    my $val     = $vv->[0];
3581                    my $coltype = $vv->[2];
3582
3583                    push @colaliaslist, $val ; # no alias
3584                    push @collist, {colnum => $ccount,
3585                                    name   => $val,
3586                                    alias  => $val,
3587                                    type   => $coltype
3588                                };
3589
3590                    $ccount++;
3591                }
3592                next L_PPL;
3593            }
3594
3595            my ($colnum, $coltype);
3596
3597            if (defined($args{select_list}))
3598            {
3599                # XXX XXX XXX XXX XXX XXX XXX XXX XXX XXX
3600                # XXX XXX XXX XXX XXX XXX XXX XXX XXX XXX
3601                # XXX XXX XXX XXX XXX XXX XXX XXX XXX XXX
3602                # code now in typecheck
3603                # XXX XXX XXX XXX XXX XXX XXX XXX XXX XXX
3604                # XXX XXX XXX XXX XXX XXX XXX XXX XXX XXX
3605                # XXX XXX XXX XXX XXX XXX XXX XXX XXX XXX
3606
3607                $colnum = 1;
3608                $coltype = 'c';
3609            }
3610            else
3611            {
3612                ($colnum, $coltype)
3613                    = $dictobj->DictTableColExists (tname => $tablename,
3614                                                    colname => $colname);
3615            }
3616            if ($colnum)
3617            {
3618                push @colaliaslist, $colalias ;
3619                push @collist, {colnum => $colnum,
3620                                name   => $colname,
3621                                alias  => $colalias,
3622                                type   => $coltype
3623                                };
3624
3625                next L_PPL;
3626            }
3627
3628            last L_sel; # failed
3629        }
3630
3631        @outi = (); # clear colnames
3632
3633        my $prep_th = {tablename => $tablename};
3634        if (defined($args{select_list}))
3635        {
3636            $prep_th->{select_list} = $args{select_list};
3637        }
3638        if (defined($args{alg_plan}))
3639        {
3640            $prep_th->{alg_plan} = $args{alg_plan};
3641        }
3642        if (defined($args{tablealias}))
3643        {
3644            $prep_th->{tablealias} = $args{tablealias};
3645        }
3646        if (defined($args{alg_from}))
3647        {
3648            $prep_th->{alg_from} = $args{alg_from};
3649        }
3650
3651        push @outi, $prep_th;
3652        push @outi, "SELECT";
3653        # Note: save the column alias list for GStatement::execute
3654        push @outi, \@colaliaslist;
3655        push @outi, \@collist;
3656        push @outi, $filter;
3657
3658    }
3659
3660    return @outi;
3661} # end CommonSelectPrepare
3662
3663sub SelectExecute
3664{
3665    my $self      = shift @_;
3666    my $prep_th   = shift @_;
3667    my $tablename = $prep_th->{tablename};
3668    my $filter    = pop @_;
3669    my $dictobj   = $self->{dictobj};
3670    my @outi;
3671
3672#    greet $filter;
3673
3674    return @outi
3675        unless (defined($tablename));
3676
3677    my $hashi = $dictobj->DictTableGetTable (tname   => $tablename,
3678                                             dbh_ctx => $self->{dbh_ctx}) ;
3679
3680    return @outi
3681        unless (defined($hashi));
3682
3683    my $sth;
3684
3685    # XXX XXX: ok to sqlexecute even for hcount, ecount
3686    {
3687        use Genezzo::Row::RSExpr;
3688        use Genezzo::Row::RSJoinA;
3689
3690        my $use_joina = 0;
3691
3692        my $tv = tied(%{$hashi});
3693        my $tv_list = [];
3694        my $alias_list = [];
3695
3696        if (exists($prep_th->{alg_plan}))
3697        {
3698#            my %nargs = (algebra => $prep_th->{alg_plan});
3699#            my ($tc, $from, $sel_list, $where) =
3700#                $self->{plan}->GetFromWhereEtc(%nargs);
3701            my $from = $prep_th->{alg_from};
3702
3703            # for join, build list of all tables
3704            if (defined($from) && (scalar(@{$from}) > 1))
3705            {
3706                $use_joina = 1;
3707
3708                for my $f_elt (@{$from})
3709                {
3710                    my $too_complex = (scalar(@{$f_elt}) > 1);
3711
3712                    unless ($too_complex)
3713                    {
3714                        $too_complex =
3715                            (!(exists($f_elt->[0]->{tc_table_fullname})))
3716                    }
3717
3718                    if ($too_complex)
3719                    {
3720                        my $msg = "FROM clause too complex - could not prepare";
3721                        my %earg = (self => $self, msg => $msg,
3722                                    severity => 'warn');
3723
3724                        &$GZERR(%earg)
3725                            if (defined($GZERR));
3726
3727                        return @outi;
3728                    }
3729
3730                    $tablename = $f_elt->[0]->{tc_table_fullname};
3731                    $hashi =
3732                        $dictobj->DictTableGetTable (tname   => $tablename,
3733                                                     dbh_ctx => $self->{dbh_ctx}) ;
3734
3735                    unless (defined($hashi))
3736                    {
3737                        my $msg = "table lookup failed: $tablename";
3738                        my %earg = (self => $self, msg => $msg,
3739                                    severity => 'warn');
3740
3741                        &$GZERR(%earg)
3742                            if (defined($GZERR));
3743
3744                        return @outi;
3745                    }
3746
3747                    $tv = tied(%{$hashi});
3748
3749                    push @{$tv_list}, $tv;
3750                    push @{$alias_list}, $f_elt->[0]->{tc_table_fullalias};
3751                } # end for f_elt
3752            } # from > 1
3753        } # if alg_plan
3754
3755
3756
3757        my %nargs = (
3758                     GZERR     => $self->{GZERR},
3759                     dict      => $dictobj,
3760                     magic_dbh => $self
3761                     );
3762
3763        if (!$use_joina)
3764        {
3765            $nargs{rs} = $tv;
3766            if (exists($prep_th->{tablealias}))
3767            {
3768                $nargs{alias} = $prep_th->{tablealias};
3769            }
3770        }
3771        else
3772        {
3773            $nargs{rs_list}    = $tv_list;
3774            $nargs{alias_list} = $alias_list;
3775        }
3776
3777        if (exists($prep_th->{select_list}))
3778        {
3779            $nargs{select_list} = $prep_th->{select_list};
3780        }
3781
3782        my ($rsx_tv, %rsx_h);
3783
3784        if (!$use_joina)
3785        {
3786            $rsx_tv = tie %rsx_h, 'Genezzo::Row::RSExpr', %nargs;
3787        }
3788        else
3789        {
3790            $rsx_tv = tie %rsx_h, 'Genezzo::Row::RSJoinA', %nargs;
3791        }
3792
3793        my %prep;
3794        $prep{filter} = $filter    # fix for hcount/ecount
3795            if (defined($filter)); # where filter is undef
3796
3797        if (1)
3798        {
3799            $sth = $rsx_tv->SQLPrepare(%prep);
3800            $hashi = \%rsx_h;
3801        }
3802        else
3803        {
3804            # XXX: obsolete?
3805            $sth = $tv->SQLPrepare(%prep);
3806        }
3807
3808        unless (defined($sth))
3809        {
3810            my $msg = "invalid statement handle - could not prepare";
3811            my %earg = (self => $self, msg => $msg,
3812                        severity => 'warn');
3813
3814            &$GZERR(%earg)
3815                if (defined($GZERR));
3816
3817            return @outi;
3818        }
3819
3820        return @outi
3821            unless ($sth->SQLExecute());
3822    }
3823
3824    push @outi, $hashi, $sth;
3825    push @outi, @_;
3826    return @outi;
3827}
3828
3829sub SelectFetch
3830{
3831    my $self = shift;
3832    my ($kk, $rownum, $hashi, $sth, $seltype, $colnames, $collist) = @_;
3833    my $dictobj = $self->{dictobj};
3834    my $rxrid     = '(^rid$)';
3835    my $rxrownum  = '(^rownum$)';
3836    my $rxcols    = '(^rid$)|(^rownum$)';
3837    my $rxhcount  = '(^count$)';
3838    my $rxecount  = '(^ecount$)';
3839    my @outi;
3840
3841    if ($seltype =~ m/^HCOUNT$/)
3842    {
3843        @outi = $self->HCountFetch(@_);
3844#        greet @outi;
3845    }
3846    elsif ($seltype =~ m/^ECOUNT$/)
3847    {
3848        ($kk, @outi) = $self->ECountFetch(@_);
3849    }
3850    else
3851    {
3852        my $tv = tied(%{$hashi});
3853
3854        my $got_select_list = $tv->SelectList();
3855
3856      L_w1:
3857        while (1)
3858        {
3859            my $vv;
3860
3861            ($kk, $vv) = $sth->SQLFetch($kk);
3862            greet $kk, $vv;
3863
3864            last L_w1
3865                unless (defined($kk));
3866
3867            unless (defined($vv))
3868            {
3869                greet "bad row for key $kk";
3870                next L_w1; # XXX XXX: skip bad rows
3871            }
3872            my @rarr = @{ $vv };
3873
3874            if (defined($got_select_list))
3875            {
3876                # XXX XXX XXX XXX XXX XXX XXX XXX XXX XXX
3877                # XXX XXX XXX XXX XXX XXX XXX XXX XXX XXX
3878                # XXX XXX XXX XXX XXX XXX XXX XXX XXX XXX
3879                # after cleanup, should always have the select list
3880                # XXX XXX XXX XXX XXX XXX XXX XXX XXX XXX
3881                # XXX XXX XXX XXX XXX XXX XXX XXX XXX XXX
3882                # XXX XXX XXX XXX XXX XXX XXX XXX XXX XXX
3883
3884                @outi = ();
3885                push @outi, @rarr;
3886                last L_w1;
3887            }
3888
3889	    foreach my $coldef (@{$collist})
3890	    {
3891                my $colnum = $coldef->{colnum};
3892
3893                if ($colnum =~ m/$rxrid/i )
3894                {
3895#                print $kk ;
3896                    push @outi, $kk;
3897                }
3898                elsif ($colnum =~ m/$rxrownum/i )
3899                {
3900#                print $rownum ;
3901                    # NOTE: rownum only incremented after
3902                    # column list processed correctly
3903                    push @outi, ($rownum + 1);
3904                }
3905                else
3906                {
3907                    my $rval = $rarr[$colnum-1];
3908#                    $rval = '<undef>' # NOTE: deal with undefs
3909#                        unless (defined($rval));
3910
3911#                print $rval ;
3912                    push @outi, $rval;
3913                }
3914            }
3915            last L_w1;
3916        } # end while
3917    }
3918
3919    if (scalar(@outi))
3920    {
3921        $rownum++;
3922        unshift @outi, $rownum;
3923        unshift @outi, $kk;
3924    }
3925
3926    greet @outi;
3927
3928    return @outi;
3929
3930} # end selectfetch
3931
3932sub SelectPrint
3933{
3934    my $self = shift;
3935    my ($hashi, $sth, $seltype, $colnames, $collist) = @_;
3936    my $dictobj = $self->{dictobj};
3937    my $rxrid     = '(^rid$)';
3938    my $rxrownum  = '(^rownum$)';
3939    my $rxcols    = '(^rid$)|(^rownum$)';
3940    my $rxhcount  = '(^count$)';
3941    my $rxecount  = '(^ecount$)';
3942    my $stat;
3943
3944    if ($seltype =~ m/^HCOUNT$/)
3945    {
3946        return $self->HCountPrint(@_);
3947    }
3948    elsif ($seltype =~ m/^ECOUNT$/)
3949    {
3950        return $self->ECountPrint(@_);
3951    }
3952
3953    {
3954        my $tv = tied(%{$hashi});
3955
3956        my $got_select_list = $tv->SelectList();
3957
3958        my $rownum = 0;
3959        if (defined($GZERR) &&
3960            !(Genezzo::Util::get_gzerr_status(GZERR => $GZERR,
3961                                              self  => $self)))
3962        {
3963            # be quiet if necessary
3964            while (1)
3965            {
3966###                print "shh!!\n";
3967                my ($kk, $vv) = $sth->SQLFetch();
3968
3969                last
3970                    unless (defined($kk));
3971                $rownum++;
3972            }
3973            return $rownum;
3974        }
3975
3976        my $msg;
3977
3978        $msg = "";
3979
3980        # print column name headers
3981        foreach my $coldef (@{$collist})
3982        {
3983            $msg .=  $coldef->{alias} . "\t";
3984        }
3985        $msg .= "\n";
3986        foreach  my $coldef2 (@{$collist})
3987        {
3988            $msg .=  '_' x length($coldef2->{alias});
3989            $msg .= "\t";
3990        }
3991        $msg .=  "\n\n";
3992        my %earg = (self => $self, msg => $msg,
3993                    severity => 'info');
3994
3995        &$GZERR(%earg)
3996            if (defined($GZERR));
3997
3998        # print the columns
3999
4000	# use "each" to get pairs versus "keys", which prefetches
4001	# entire hash
4002
4003        while (1)
4004        {
4005            my ($kk, $vv) = $sth->SQLFetch();
4006
4007            last
4008                unless (defined($kk));
4009
4010            next # XXX XXX: skip bad rows
4011                unless (defined($vv));
4012            my @rarr = @{ $vv };
4013
4014            $rownum++;
4015
4016
4017            if (defined($got_select_list))
4018            {
4019                # XXX XXX XXX XXX XXX XXX XXX XXX XXX XXX
4020                # XXX XXX XXX XXX XXX XXX XXX XXX XXX XXX
4021                # XXX XXX XXX XXX XXX XXX XXX XXX XXX XXX
4022                # after cleanup, should always have select list
4023                # XXX XXX XXX XXX XXX XXX XXX XXX XXX XXX
4024                # XXX XXX XXX XXX XXX XXX XXX XXX XXX XXX
4025                # XXX XXX XXX XXX XXX XXX XXX XXX XXX XXX
4026
4027                $msg = "";
4028
4029                for my $colval (@rarr)
4030                {
4031                    $colval = '<undef>' # NOTE: deal with undefs
4032                        unless (defined($colval));
4033
4034                    $msg .= $colval ;
4035                    $msg .= "\t";
4036                }
4037                $msg .= "\n";
4038
4039                %earg = (self => $self, msg => $msg,
4040                         severity => 'info');
4041
4042                &$GZERR(%earg)
4043                    if (defined($GZERR));
4044
4045                next;
4046            }
4047
4048            $msg = "";
4049	    foreach my $coldef (@{$collist})
4050	    {
4051                my $colnum = $coldef->{colnum};
4052
4053                if ($colnum =~ m/$rxrid/i )
4054                {
4055                    $msg .=  $kk ;
4056                }
4057                elsif ($colnum =~ m/$rxrownum/i )
4058                {
4059                    $msg .= $rownum ;
4060                }
4061                else
4062                {
4063                    my $rval = $rarr[$colnum-1];
4064                    $rval = '<undef>' # NOTE: deal with undefs
4065                        unless (defined($rval));
4066
4067                    $msg .= $rval ;
4068                }
4069                $msg .= "\t";
4070	    }
4071            $msg .= "\n";
4072            %earg = (self => $self, msg => $msg,
4073                     severity => 'info');
4074
4075            &$GZERR(%earg)
4076                if (defined($GZERR));
4077	}
4078        $msg = "\n";
4079        $msg .= ($rownum ? $rownum : "no") ;
4080        $msg .= ((1 == $rownum) ? " row " : " rows ") .
4081            "selected.\n";
4082        %earg = (self => $self, msg => $msg,
4083                    severity => 'info');
4084
4085        &$GZERR(%earg)
4086            if (defined($GZERR));
4087
4088        $stat = $rownum;
4089    }
4090
4091    return $stat;
4092
4093} # end selectprint
4094
4095
4096my %parsedispatch =
4097qw(
4098   help   Kgnz_Help
4099   quit   Kgnz_Quit
4100   reload Kgnz_Reload
4101   dump   Kgnz_Dump
4102   explain Kgnz_Explain
4103   spool  Kgnz_Spool
4104
4105   h       Kgnz_History
4106   history Kgnz_History
4107
4108   rem    Kgnz_Rem
4109
4110   commit   Kgnz_Commit
4111   sync     Kgnz_Sync
4112   rollback Kgnz_Rollback
4113
4114   desc     Kgnz_Describe
4115   describe Kgnz_Describe
4116
4117   ci     Feeble_CIdx
4118
4119   ct     Feeble_CT
4120   dt     Kgnz_Drop
4121   drop   SQLDrop
4122
4123   alter  SQLAlter
4124   create SQLCreate
4125
4126   i      Feeble_Insert
4127   insert SQLInsert
4128
4129   update SQLUpdate
4130   delete SQLDelete
4131   u      Feeble_Update
4132   d      Feeble_Delete
4133
4134   s      Feeble_Select
4135   select SQLSelect
4136
4137   addfile  Kgnz_AddFile
4138   af       Kgnz_AddFile
4139
4140   end    Kgnz_BigStatement
4141
4142   show     Kgnz_Show
4143
4144   startup  Kgnz_Startup
4145   shutdown Kgnz_Shutdown
4146   password Kgnz_Password
4147
4148   );
4149
4150my %opdispatch =
4151qw(
4152   create Kgnz_Create
4153   );
4154
4155
4156sub histpush
4157{
4158    my $self = shift;
4159    my ($hcnt, $val) = @_;
4160    my $histlist = $self->{histlist};
4161    push @{$histlist}, [$hcnt, $val];
4162
4163    while (scalar(@{$histlist}) > $self->{maxhist})
4164    {
4165        shift @{$histlist} ;
4166    }
4167
4168}
4169
4170sub histfetch
4171{
4172#    greet @_;
4173    my $self = shift;
4174    my ($getcnt) = shift @_;
4175    my $histlist = $self->{histlist};
4176    my $aval = $histlist->[0];
4177    my ($hcnt, $val) = @{$aval};
4178
4179    {
4180        last if ($getcnt < $hcnt);
4181        last if ($getcnt > ($hcnt + scalar(@{$histlist})));
4182
4183        my $hidx = $getcnt - $hcnt;
4184
4185        return $histlist->[$hidx];
4186    }
4187
4188    my $msg = "!" . $getcnt . ": event not found\n";
4189    my %earg = (self => $self, msg => $msg,
4190                severity => 'warn');
4191
4192    &$GZERR(%earg)
4193        if (defined($GZERR));
4194
4195    return undef;
4196}
4197
4198sub Kgnz_History
4199{
4200    my $self = shift;
4201    my $harg = shift @_;
4202    my $histlist = $self->{histlist};
4203
4204    my ($msg, %earg);
4205
4206    if (defined($harg) && ($harg =~ m/clear/i))
4207    {
4208        $msg = "Cleared history...\n";
4209        %earg = (self => $self, msg => $msg,
4210                 severity => 'info');
4211
4212        &$GZERR(%earg)
4213            if (defined($GZERR));
4214
4215        $self->{histlist} = [];
4216        return 1;
4217    }
4218
4219    $msg = "\n";
4220    foreach my $aval (@{$histlist})
4221    {
4222        my ($hcnt, $val) = @{$aval};
4223
4224        # remove extra trailing newlines for neatness
4225        $val =~ s/(\n)*$//;
4226
4227        my $addspace = length($hcnt) + 1;
4228        my $spacer = ' ' x $addspace;
4229
4230        # make multiline statements a little prettier in the history
4231        # list - offset them from the history number.
4232        $val =~ s/\n/\n$spacer/gm;
4233
4234        $msg .= $hcnt . " " . $val . "\n";
4235    }
4236        %earg = (self => $self, msg => $msg,
4237                 severity => 'info');
4238
4239        &$GZERR(%earg)
4240            if (defined($GZERR));
4241
4242}
4243
4244sub Kgnz_Help
4245{
4246    my $self = shift;
4247#    print Dumper(%parsedispatch) ;
4248    my $dictobj = $self->{dictobj};
4249
4250    my @args = @_;
4251    my %nargs;
4252
4253    if (scalar(@args))
4254    {
4255        my $format_option;
4256
4257        for my $pattern (@args)
4258        {
4259            # cmd pattern
4260            if ($pattern =~ m/^(area|tag|list|short|verbose|full|long)\=.*/i)
4261            {
4262                my @foo = split('=', $pattern, 2);
4263
4264                unless (scalar(@foo) == 2)
4265                {
4266                    my $msg = 'invalid option for help: $pattern';
4267
4268                    my %earg = (self => $self, msg => $msg,
4269                                severity => 'warn');
4270
4271                    &$GZERR(%earg)
4272                        if (defined($GZERR));
4273                    return 0;
4274                }
4275                my $cmd = shift @foo;
4276
4277                # special case for area or tags
4278                if ($cmd =~ m/(area|tag)/i)
4279                {
4280                    if ($cmd =~ m/(area)/i)
4281                    {
4282                        $nargs{topic_group} = shift @foo;
4283                    }
4284                    next;
4285                }
4286
4287                # special format option for pattern
4288                if ($cmd =~ m/(list|short|verbose|full|long)/i)
4289                {
4290                    $pattern = shift @foo;
4291
4292                    $format_option = 'list' if ($cmd =~ m/list/i);
4293                    $format_option = 'short' if ($cmd =~ m/short/i);
4294                    $format_option = 'long' if ($cmd =~ m/long|full|verbose/i);
4295                }
4296
4297            } # end cmd pattern
4298
4299            # special case "!" and "@"
4300            if ($pattern =~ m/^(\@|\!)$/)
4301            {
4302                $pattern = quotemeta($pattern);
4303            }
4304
4305            # do a prefix match unless specified
4306            my $match1 = '(^\^)|(\$$)';
4307            if ($pattern !~ m/$match1/)
4308            {
4309                $pattern =~ s/^\*/\.\*/
4310                    if ($pattern =~ m/^\*/);
4311
4312                $pattern = '^' . $pattern;
4313            }
4314            if (exists($nargs{topic_pattern}))
4315            {
4316                # build a list of patterns
4317                $nargs{topic_pattern} .= "|" . $pattern;
4318            }
4319            else
4320            {
4321                $nargs{topic_pattern} = $pattern;
4322            }
4323            $nargs{option}='short';
4324        } # end for
4325        if (defined($format_option))
4326        {
4327            $nargs{option}=$format_option;
4328        }
4329    }
4330
4331    my $bigHelp = $dictobj->DictHelpSearch(%nargs);
4332
4333    my $msg = $bigHelp;
4334
4335    # additional help on helping
4336    unless (scalar(keys(%nargs)))
4337    {
4338        $msg .= "\n\n  Type \"help help\" for more help.\n";
4339    }
4340
4341    my $sev = 'info';
4342
4343    # warn if no msg
4344    unless (defined($msg))
4345    {
4346        $sev = 'warn';
4347        $msg = "No help for \"help " . join(" ", @_) . '"';
4348    }
4349
4350
4351    my %earg = (self => $self, msg => $msg,
4352                severity => $sev);
4353
4354    &$GZERR(%earg)
4355        if (defined($GZERR));
4356
4357    return 1;
4358}
4359
4360sub Kgnz_Prepare
4361{
4362    my ($self, $currline) = @_;
4363
4364    return undef
4365        unless (defined($currline));
4366
4367    $self->{current_line} = $currline;
4368    my @pwords = shellwords($currline);
4369
4370    return undef
4371        unless (@pwords);
4372
4373    my ($msg, %earg);
4374    my $severity = 'info';
4375
4376    my $operation;
4377
4378    while (1)
4379    {
4380        $operation = shift @pwords ;
4381        last # pop off empties to find keyword
4382            if ($operation =~ /\S/);
4383
4384    }
4385
4386  L_beginend:
4387    {
4388        if ($self->{endwait})
4389        {
4390            if (uc($operation) eq 'END')
4391            {
4392                $self->{endwait} = 0;
4393#                whisper $self->{bigstatement}, "\n";
4394
4395                $pwords[0] = $self->{bigstatement};
4396                last L_beginend;
4397            }
4398
4399            $self->{bigstatement} .= $operation;
4400            $self->{bigstatement} .= ' ';
4401
4402            while (my $thing = shift @pwords)
4403            {
4404                $self->{bigstatement} .= $thing;
4405                $self->{bigstatement} .= ' ';
4406            }
4407            return undef;
4408
4409        }
4410        if (uc($operation) eq 'BEGIN')
4411        {
4412            $self->{bigstatement} = ();
4413            $self->{endwait} = 1;
4414            return undef;
4415        }
4416    } # end L_beginend;
4417
4418    # @file to execute commands
4419    unless (@pwords)
4420    {
4421        if ($operation =~ m/^\!/)
4422        {
4423            my $hhnum = ();
4424
4425            if ($operation eq "!!")
4426            {
4427                $hhnum = $self->{histcounter} - 1;
4428            }
4429            else
4430            {
4431
4432                my @hnum = ($operation =~ m/^\!(\d.*)/);
4433
4434#        whisper @hnum;
4435                $hhnum = $hnum[0];
4436            }
4437
4438            if (defined($hhnum))
4439            {
4440                pop @{$self->{histlist}};
4441                my $aval = $self->histfetch($hhnum);
4442                return undef
4443                    unless (defined($aval));
4444
4445                my ($hcnt, $val) = @{$aval};
4446                $self->histpush ($self->{histcounter}, $val);
4447
4448                $self->_print_to_all("$val\n");
4449
4450                $val =~ s/;(\s*)$//  # Note: remove the semicolon
4451                    ;
4452
4453                return $self->Kgnz_Prepare($val);
4454            }
4455        }
4456
4457	my @pfiles = split(/(@)/, $operation) ;
4458
4459        $msg = "";
4460	{
4461	    last if (@pfiles < 2 );
4462
4463	  L_inifile:
4464	    foreach my $inifile (@pfiles)
4465	    {
4466		next if ($inifile eq '');
4467		next if ($inifile eq '@');
4468
4469		unless (-e $inifile)
4470		{
4471		    $msg .= "file $inifile does not exist \n";
4472                    $severity = 'warn';
4473		    last L_inifile;
4474		}
4475
4476                my $fh; # lexical scope filehandle for nesting includes
4477		unless (open ($fh, "< $inifile" ) )
4478                {
4479		    $msg .="Could not open $inifile for reading : $! \n";
4480                    $severity = 'warn';
4481		    last  L_inifile;
4482                }
4483
4484                # Note: need loop like Interactive() to
4485                # continue SQL command until get semicolon
4486
4487                my $prev_line = undef;  # accumulated input of
4488                                        # multi-line statement
4489
4490                my $multiline = 0;      # =1 if require a semicolon to
4491                                        # terminate statement
4492
4493                my $prompt = "\n$inifile> ";
4494                my $prompt_2 = (" " x length($inifile)) . "> ";
4495
4496              L_w1:
4497		while (<$fh>) {
4498                    my $m1 = $prompt . $_;
4499                    # input is already newline terminated
4500                    $self->_print_to_all($m1);
4501
4502                    my $in_line = $_;
4503                    if (defined($prev_line))
4504                    {
4505#                        $prev_line .= "\n" ;
4506                        # input is already newline terminated
4507                    }
4508                    else
4509                    {
4510                        next L_w1 unless ($in_line =~ m/\S/);
4511
4512                        $prev_line = "" ;
4513                        $multiline = 1     # check if need terminator
4514                            if ($in_line =~ m/$need_semi/);
4515                    }
4516                    $prev_line .= $in_line;
4517
4518                    # NOTE: not all commands are multiline and require
4519                    # semicolon...
4520                    if ($multiline && ($in_line !~ m/;(\s*)$/))
4521                    {
4522                        $prompt = $prompt_2;
4523                        next L_w1;
4524                    }
4525                    else
4526                    {
4527                        $prev_line =~ s/;(\s*)$//  # Note: remove the semicolon
4528                            ;
4529#                if ($multiline);
4530                    }
4531
4532                    $self->Parseall ($prev_line);
4533                    $prompt = "\n$inifile> ";
4534                    $prev_line = undef;
4535                    $multiline = 0;
4536		} # end big while
4537		close ($fh);
4538	    } # end foreach
4539
4540            if ($severity !~ m/info/i)
4541            {
4542                %earg = (self => $self, msg => $msg,
4543                         severity => $severity);
4544
4545                &$GZERR(%earg)
4546                    if (defined($GZERR));
4547            }
4548
4549	    return undef;
4550	}
4551    }
4552
4553    unless (exists($parsedispatch{lc($operation)}))
4554    {
4555	$msg = "could not parse: " .
4556            Dumper ($operation) . Dumper (@pwords) . "\n" ;
4557
4558        %earg = (self => $self, msg => $msg,
4559                 severity => 'warn');
4560
4561        &$GZERR(%earg)
4562            if (defined($GZERR));
4563
4564	return undef;
4565    }
4566
4567    my $dispatch = $parsedispatch{lc($operation)};
4568
4569    unshift @pwords, $dispatch;
4570
4571    return @pwords;
4572
4573} # end Kgnz_Prepare
4574
4575sub Kgnz_Execute
4576{
4577    my $self = shift;
4578
4579#    print join(" ", @_), "\n";
4580
4581    my ($dispatch, @pwords) = @_;
4582
4583    return undef # no dispatch function if parse failed...
4584        unless (defined($dispatch));
4585
4586    no strict 'refs' ;
4587    my $stat = &$dispatch ($self, @pwords) ;
4588    return $stat;
4589}
4590
4591sub Parseall
4592{
4593    my ($self, $currline) = @_;
4594    $self->_clearerror();
4595    my @param = $self->Kgnz_Prepare($currline);
4596    return undef
4597        unless (scalar(@param));
4598
4599    return $self->Kgnz_Execute(@param);
4600}
4601
4602sub do # DBI
4603{
4604    my $self = shift;
4605    return $self->Parseall(@_);
4606}
4607
4608sub parse_tree_prepare # XXX: DBI "extension"
4609{
4610    my $self = shift;
4611    my %required = (
4612                    statement_type => "no statement type !",
4613                    parse_tree => "no parse tree !"
4614                    );
4615    my %optional = ();
4616    my %args = (
4617#                %optional,
4618		@_);
4619
4620    return undef
4621        unless (Validate(\%args, \%required));
4622
4623    # XXX XXX: only support select for now...
4624    return undef
4625        unless ($args{statement_type} =~ m/select/i);
4626
4627    # call sql prepare directly, need to gimmick Plan to take parse tree
4628
4629    $self->_clearerror();
4630#    my @param = ("SQLSelectPrepare2", undef, $args{parse_tree});
4631    my @param = ("SQLSelectPrepare2", "", $args{parse_tree});
4632    return undef
4633        unless (scalar(@param));
4634
4635    my $sth = Genezzo::GStatement->new(gnz_h     => $self,
4636                                       dbh_ctx   => $self->{dbh_ctx},
4637                                       GZERR     => $self->{GZERR},
4638                                       statement => \@param);
4639    return $sth;
4640}
4641
4642sub prepare # DBI
4643{
4644    my ($self, $currline) = @_;
4645    $self->_clearerror();
4646    my @param = $self->Kgnz_Prepare($currline);
4647    return undef
4648        unless (scalar(@param));
4649
4650    my $sth = Genezzo::GStatement->new(gnz_h     => $self,
4651                                       dbh_ctx   => $self->{dbh_ctx},
4652                                       GZERR     => $self->{GZERR},
4653                                       statement => \@param);
4654    return $sth;
4655}
4656
4657sub selectrow_array # DBI
4658{
4659    my $self = shift;
4660
4661    my $sth = $self->prepare(@_);
4662    return undef
4663        unless (defined($sth));
4664
4665    return $sth->_selectrow_internal("ARRAY");
4666}
4667sub selectrow_arrayref # DBI
4668{
4669    my $self = shift;
4670
4671    my $sth = $self->prepare(@_);
4672    return undef
4673        unless (defined($sth));
4674
4675    return $sth->_selectrow_internal("ARRAYREF");
4676}
4677sub selectall_arrayref # DBI
4678{
4679    my $self = shift;
4680
4681    my $sth = $self->prepare(@_);
4682    return undef
4683        unless (defined($sth));
4684
4685    return $sth->_selectrow_internal("ALL_ARRAYREF");
4686}
4687sub selectrow_hashref # DBI
4688{
4689    my $self = shift;
4690
4691    my $sth = $self->prepare(@_);
4692    return undef
4693        unless (defined($sth));
4694
4695    return $sth->_selectrow_internal("HASHREF");
4696}
4697
4698sub Kgnz_BigStatement
4699{
4700    my $self = shift;
4701    {
4702	last if (@_ < 1);
4703
4704	my $bigstatement = shift @_;
4705
4706        my %args = ();
4707        {
4708            no strict;
4709
4710            eval "$bigstatement";
4711
4712            use strict;
4713        }
4714
4715        unless (   (exists ($args{op1}))
4716                && (exists ($opdispatch{lc($args{op1})})))
4717        {
4718            my $msg = "Could not find valid operation in: \n" .
4719                "$bigstatement \n";
4720            my %earg = (self => $self, msg => $msg,
4721                        severity => 'warn');
4722
4723            &$GZERR(%earg)
4724                if (defined($GZERR));
4725
4726            return 0;
4727        }
4728        my $dispatch = $opdispatch{lc($args{op1})};
4729
4730        no strict 'refs' ;
4731        return &$dispatch (%args) ;
4732    }
4733    return 0;
4734}
4735
4736#########################
4737# SQL FUNCTIONS - start #
4738#########################
4739sub sql_func_now
4740{
4741    return Genezzo::Dict::time_iso8601();
4742}
4743
4744sub sql_func_sysdate
4745{
4746    return Genezzo::Dict::time_iso8601();
4747}
4748
4749sub sql_func_HavokUse
4750{
4751    return Genezzo::Dict::HavokUse(@_);
4752}
4753#########################
4754# SQL FUNCTIONS - end   #
4755#########################
4756
4757# check preferences for automatic mount
4758sub automountcheck
4759{
4760    my $self = shift;
4761    my $dictobj = $self->{dictobj};
4762
4763    my $hashi = $dictobj->DictTableGetTable (tname   => '_pref1',
4764                                             dbh_ctx => $self->{dbh_ctx}
4765                                             ) ;
4766
4767    while ( my ($kk, $vv) = each ( %{$hashi}))
4768    {
4769        my @rarr = @{ $vv };
4770
4771        if ($rarr[0] =~ m/automount/)
4772        {
4773            my $amval = $rarr[1] ;
4774            my $msg = "automount = $amval\n";
4775            if ($rarr[1] =~ m/TRUE/)
4776            {
4777                $msg .= "automounting...\n";
4778            }
4779            my %earg = (self => $self, msg => $msg,
4780                        severity => 'info');
4781
4782            &$GZERR(%earg)
4783                if (defined($GZERR));
4784
4785            if ($rarr[1] =~ m/TRUE/)
4786            {
4787                return $self->Kgnz_Startup();
4788            }
4789            last;
4790        }
4791    }
4792    return 0;
4793}
4794
4795sub Interactive
4796{
4797    my $self = shift;
4798
4799    unless (defined($self->{dictobj}))
4800    {
4801        return undef; # no dictionary
4802    }
4803
4804    $self->automountcheck();
4805
4806    $self->PrintVersionString();
4807
4808    my $term = new Term::ReadLine 'gendba';
4809
4810    # Load History
4811    $self->LoadHistory($term);
4812
4813#    greet $term->Features ;
4814
4815    my $prompt = "\ngendba $self->{histcounter}> ";
4816    my $prompt_2 = "> ";
4817
4818    my $in_line;        # current input line
4819    my $prev_line;      # accumulated input of multi-line statement
4820    my $multiline = 0;  # =1 if require a semicolon to terminate statement
4821
4822    while ( defined ($in_line = $term->readline($prompt)))
4823    {
4824        if (defined($prev_line))
4825        {
4826            $prev_line .= "\n" ;
4827        }
4828        else
4829        {
4830            next unless ($in_line =~ m/\S/);
4831
4832            $prev_line = "" ;
4833            $multiline = 1     # check if need terminator
4834                if ($in_line =~ m/$need_semi/);
4835        }
4836        $prev_line .= $in_line;
4837
4838        # NOTE: not all commands are multiline and require semicolon...
4839        if ($multiline && ($in_line !~ m/;$/))
4840        {
4841            $prompt = $prompt_2;
4842            next;
4843        }
4844
4845        $term->addhistory($prev_line);
4846        $self->histpush($self->{histcounter}, $prev_line);
4847
4848        # make spool output better...
4849        $self->_print_to_outfiles("\ngendba $self->{histcounter}>  ");
4850        $self->_print_to_outfiles($prev_line);
4851        $self->_print_to_outfiles("\n");
4852
4853        $prev_line =~ s/;(\s*)$//  # Note: remove the semicolon
4854            ;
4855
4856        $self->Parseall ($prev_line);
4857        ($self->{histcounter}) += 1;
4858        $prompt = "\ngendba $self->{histcounter}> ";
4859        $prev_line = undef;
4860        $multiline = 0;
4861    } # end big while
4862
4863    if ($self->{histsave})
4864    {
4865        $self->SaveHistory();
4866    }
4867
4868    return 1;
4869}
4870
4871sub PrintLicense
4872{
4873    my $self = shift;
4874    my $bigGPL;
4875    ($bigGPL = <<EOF_GPL) =~ s/^\#//gm;
4876#
4877#		    GNU GENERAL PUBLIC LICENSE
4878#		       Version 2, June 1991
4879#
4880# Copyright (C) 1989, 1991 Free Software Foundation, Inc.
4881#                       51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA
4882# Everyone is permitted to copy and distribute verbatim copies
4883# of this license document, but changing it is not allowed.
4884#
4885#			    Preamble
4886#
4887#  The licenses for most software are designed to take away your
4888#freedom to share and change it.  By contrast, the GNU General Public
4889#License is intended to guarantee your freedom to share and change free
4890#software--to make sure the software is free for all its users.  This
4891#General Public License applies to most of the Free Software
4892#Foundation's software and to any other program whose authors commit to
4893#using it.  (Some other Free Software Foundation software is covered by
4894#the GNU Library General Public License instead.)  You can apply it to
4895#your programs, too.
4896#
4897#  When we speak of free software, we are referring to freedom, not
4898#price.  Our General Public Licenses are designed to make sure that you
4899#have the freedom to distribute copies of free software (and charge for
4900#this service if you wish), that you receive source code or can get it
4901#if you want it, that you can change the software or use pieces of it
4902#in new free programs; and that you know you can do these things.
4903#
4904#  To protect your rights, we need to make restrictions that forbid
4905#anyone to deny you these rights or to ask you to surrender the rights.
4906#These restrictions translate to certain responsibilities for you if you
4907#distribute copies of the software, or if you modify it.
4908#
4909#  For example, if you distribute copies of such a program, whether
4910#gratis or for a fee, you must give the recipients all the rights that
4911#you have.  You must make sure that they, too, receive or can get the
4912#source code.  And you must show them these terms so they know their
4913#rights.
4914#
4915#  We protect your rights with two steps: (1) copyright the software, and
4916#(2) offer you this license which gives you legal permission to copy,
4917#distribute and/or modify the software.
4918#
4919#  Also, for each author's protection and ours, we want to make certain
4920#that everyone understands that there is no warranty for this free
4921#software.  If the software is modified by someone else and passed on, we
4922#want its recipients to know that what they have is not the original, so
4923#that any problems introduced by others will not reflect on the original
4924#authors' reputations.
4925#
4926#  Finally, any free program is threatened constantly by software
4927#patents.  We wish to avoid the danger that redistributors of a free
4928#program will individually obtain patent licenses, in effect making the
4929#program proprietary.  To prevent this, we have made it clear that any
4930#patent must be licensed for everyone's free use or not licensed at all.
4931#
4932#  The precise terms and conditions for copying, distribution and
4933#modification follow.
4934#
4935#		    GNU GENERAL PUBLIC LICENSE
4936#   TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION
4937#
4938#  0. This License applies to any program or other work which contains
4939#a notice placed by the copyright holder saying it may be distributed
4940#under the terms of this General Public License.  The "Program", below,
4941#refers to any such program or work, and a "work based on the Program"
4942#means either the Program or any derivative work under copyright law:
4943#that is to say, a work containing the Program or a portion of it,
4944#either verbatim or with modifications and/or translated into another
4945#language.  (Hereinafter, translation is included without limitation in
4946#the term "modification".)  Each licensee is addressed as "you".
4947#
4948#Activities other than copying, distribution and modification are not
4949#covered by this License; they are outside its scope.  The act of
4950#running the Program is not restricted, and the output from the Program
4951#is covered only if its contents constitute a work based on the
4952#Program (independent of having been made by running the Program).
4953#Whether that is true depends on what the Program does.
4954#
4955#  1. You may copy and distribute verbatim copies of the Program's
4956#source code as you receive it, in any medium, provided that you
4957#conspicuously and appropriately publish on each copy an appropriate
4958#copyright notice and disclaimer of warranty; keep intact all the
4959#notices that refer to this License and to the absence of any warranty;
4960#and give any other recipients of the Program a copy of this License
4961#along with the Program.
4962#
4963#You may charge a fee for the physical act of transferring a copy, and
4964#you may at your option offer warranty protection in exchange for a fee.
4965#
4966#  2. You may modify your copy or copies of the Program or any portion
4967#of it, thus forming a work based on the Program, and copy and
4968#distribute such modifications or work under the terms of Section 1
4969#above, provided that you also meet all of these conditions:
4970#
4971#    a) You must cause the modified files to carry prominent notices
4972#    stating that you changed the files and the date of any change.
4973#
4974#    b) You must cause any work that you distribute or publish, that in
4975#    whole or in part contains or is derived from the Program or any
4976#    part thereof, to be licensed as a whole at no charge to all third
4977#    parties under the terms of this License.
4978#
4979#    c) If the modified program normally reads commands interactively
4980#    when run, you must cause it, when started running for such
4981#    interactive use in the most ordinary way, to print or display an
4982#    announcement including an appropriate copyright notice and a
4983#    notice that there is no warranty (or else, saying that you provide
4984#    a warranty) and that users may redistribute the program under
4985#    these conditions, and telling the user how to view a copy of this
4986#    License.  (Exception: if the Program itself is interactive but
4987#    does not normally print such an announcement, your work based on
4988#    the Program is not required to print an announcement.)
4989#
4990#These requirements apply to the modified work as a whole.  If
4991#identifiable sections of that work are not derived from the Program,
4992#and can be reasonably considered independent and separate works in
4993#themselves, then this License, and its terms, do not apply to those
4994#sections when you distribute them as separate works.  But when you
4995#distribute the same sections as part of a whole which is a work based
4996#on the Program, the distribution of the whole must be on the terms of
4997#this License, whose permissions for other licensees extend to the
4998#entire whole, and thus to each and every part regardless of who wrote it.
4999#
5000#Thus, it is not the intent of this section to claim rights or contest
5001#your rights to work written entirely by you; rather, the intent is to
5002#exercise the right to control the distribution of derivative or
5003#collective works based on the Program.
5004#
5005#In addition, mere aggregation of another work not based on the Program
5006#with the Program (or with a work based on the Program) on a volume of
5007#a storage or distribution medium does not bring the other work under
5008#the scope of this License.
5009#
5010#  3. You may copy and distribute the Program (or a work based on it,
5011#under Section 2) in object code or executable form under the terms of
5012#Sections 1 and 2 above provided that you also do one of the following:
5013#
5014#    a) Accompany it with the complete corresponding machine-readable
5015#    source code, which must be distributed under the terms of Sections
5016#    1 and 2 above on a medium customarily used for software interchange; or,
5017#
5018#    b) Accompany it with a written offer, valid for at least three
5019#    years, to give any third party, for a charge no more than your
5020#    cost of physically performing source distribution, a complete
5021#    machine-readable copy of the corresponding source code, to be
5022#    distributed under the terms of Sections 1 and 2 above on a medium
5023#    customarily used for software interchange; or,
5024#
5025#    c) Accompany it with the information you received as to the offer
5026#    to distribute corresponding source code.  (This alternative is
5027#    allowed only for noncommercial distribution and only if you
5028#    received the program in object code or executable form with such
5029#    an offer, in accord with Subsection b above.)
5030#
5031#The source code for a work means the preferred form of the work for
5032#making modifications to it.  For an executable work, complete source
5033#code means all the source code for all modules it contains, plus any
5034#associated interface definition files, plus the scripts used to
5035#control compilation and installation of the executable.  However, as a
5036#special exception, the source code distributed need not include
5037#anything that is normally distributed (in either source or binary
5038#form) with the major components (compiler, kernel, and so on) of the
5039#operating system on which the executable runs, unless that component
5040#itself accompanies the executable.
5041#
5042#If distribution of executable or object code is made by offering
5043#access to copy from a designated place, then offering equivalent
5044#access to copy the source code from the same place counts as
5045#distribution of the source code, even though third parties are not
5046#compelled to copy the source along with the object code.
5047#
5048#  4. You may not copy, modify, sublicense, or distribute the Program
5049#except as expressly provided under this License.  Any attempt
5050#otherwise to copy, modify, sublicense or distribute the Program is
5051#void, and will automatically terminate your rights under this License.
5052#However, parties who have received copies, or rights, from you under
5053#this License will not have their licenses terminated so long as such
5054#parties remain in full compliance.
5055#
5056#  5. You are not required to accept this License, since you have not
5057#signed it.  However, nothing else grants you permission to modify or
5058#distribute the Program or its derivative works.  These actions are
5059#prohibited by law if you do not accept this License.  Therefore, by
5060#modifying or distributing the Program (or any work based on the
5061#Program), you indicate your acceptance of this License to do so, and
5062#all its terms and conditions for copying, distributing or modifying
5063#the Program or works based on it.
5064#
5065#  6. Each time you redistribute the Program (or any work based on the
5066#Program), the recipient automatically receives a license from the
5067#original licensor to copy, distribute or modify the Program subject to
5068#these terms and conditions.  You may not impose any further
5069#restrictions on the recipients' exercise of the rights granted herein.
5070#You are not responsible for enforcing compliance by third parties to
5071#this License.
5072#
5073#  7. If, as a consequence of a court judgment or allegation of patent
5074#infringement or for any other reason (not limited to patent issues),
5075#conditions are imposed on you (whether by court order, agreement or
5076#otherwise) that contradict the conditions of this License, they do not
5077#excuse you from the conditions of this License.  If you cannot
5078#distribute so as to satisfy simultaneously your obligations under this
5079#License and any other pertinent obligations, then as a consequence you
5080#may not distribute the Program at all.  For example, if a patent
5081#license would not permit royalty-free redistribution of the Program by
5082#all those who receive copies directly or indirectly through you, then
5083#the only way you could satisfy both it and this License would be to
5084#refrain entirely from distribution of the Program.
5085#
5086#If any portion of this section is held invalid or unenforceable under
5087#any particular circumstance, the balance of the section is intended to
5088#apply and the section as a whole is intended to apply in other
5089#circumstances.
5090#
5091#It is not the purpose of this section to induce you to infringe any
5092#patents or other property right claims or to contest validity of any
5093#such claims; this section has the sole purpose of protecting the
5094#integrity of the free software distribution system, which is
5095#implemented by public license practices.  Many people have made
5096#generous contributions to the wide range of software distributed
5097#through that system in reliance on consistent application of that
5098#system; it is up to the author/donor to decide if he or she is willing
5099#to distribute software through any other system and a licensee cannot
5100#impose that choice.
5101#
5102#This section is intended to make thoroughly clear what is believed to
5103#be a consequence of the rest of this License.
5104#
5105#  8. If the distribution and/or use of the Program is restricted in
5106#certain countries either by patents or by copyrighted interfaces, the
5107#original copyright holder who places the Program under this License
5108#may add an explicit geographical distribution limitation excluding
5109#those countries, so that distribution is permitted only in or among
5110#countries not thus excluded.  In such case, this License incorporates
5111#the limitation as if written in the body of this License.
5112#
5113#  9. The Free Software Foundation may publish revised and/or new versions
5114#of the General Public License from time to time.  Such new versions will
5115#be similar in spirit to the present version, but may differ in detail to
5116#address new problems or concerns.
5117#
5118#Each version is given a distinguishing version number.  If the Program
5119#specifies a version number of this License which applies to it and "any
5120#later version", you have the option of following the terms and conditions
5121#either of that version or of any later version published by the Free
5122#Software Foundation.  If the Program does not specify a version number of
5123#this License, you may choose any version ever published by the Free Software
5124#Foundation.
5125#
5126#  10. If you wish to incorporate parts of the Program into other free
5127#programs whose distribution conditions are different, write to the author
5128#to ask for permission.  For software which is copyrighted by the Free
5129#Software Foundation, write to the Free Software Foundation; we sometimes
5130#make exceptions for this.  Our decision will be guided by the two goals
5131#of preserving the free status of all derivatives of our free software and
5132#of promoting the sharing and reuse of software generally.
5133#
5134#			    NO WARRANTY
5135#
5136#  11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY
5137#FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW.  EXCEPT WHEN
5138#OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES
5139#PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED
5140#OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
5141#MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE.  THE ENTIRE RISK AS
5142#TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU.  SHOULD THE
5143#PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING,
5144#REPAIR OR CORRECTION.
5145#
5146#  12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
5147#WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR
5148#REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES,
5149#INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING
5150#OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED
5151#TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY
5152#YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER
5153#PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE
5154#POSSIBILITY OF SUCH DAMAGES.
5155#
5156#		     END OF TERMS AND CONDITIONS
5157#
5158EOF_GPL
5159
5160    my $msg = "\nThe Genezzo program may be redistributed under terms of\n" .
5161    "the GNU General Public License.\n" . $bigGPL;
5162    my %earg = (self => $self, msg => $msg,
5163                severity => 'info');
5164
5165    &$GZERR(%earg)
5166        if (defined($GZERR));
5167
5168} # end printlicense
5169
5170package Genezzo::GStatement;
5171use strict;
5172use warnings;
5173use Genezzo::Util;
5174
5175sub _init
5176{
5177    my $self = shift;
5178    my %args = (@_);
5179
5180    return 0
5181        unless (exists($args{gnz_h}));
5182
5183    $self->{gnz_h}      = $args{gnz_h};
5184    $self->{PrintError} = $self->{gnz_h}->{PrintError};
5185    $self->{RaiseError} = $self->{gnz_h}->{RaiseError};
5186
5187    if (exists($args{statement}))
5188    {
5189#        greet $args{statement};
5190        $self->{param} = $args{statement};
5191        my $match1 = '(^Feeble_Select$)';
5192        my $match2 = '(^SQLSelect$)';
5193        my $match3 = '(^SQLSelectPrepare2$)';
5194
5195        if (scalar(@{$self->{param}}))
5196        {
5197            if ($self->{param}->[0] =~ m/$match1/ )
5198            {
5199                shift @{$self->{param}};
5200                $self->{select} = [];
5201                push @{$self->{select}},
5202                    $self->{gnz_h}->CommonSelectPrepare(basic =>
5203                                                        \@{$self->{param}});
5204
5205                # check if prepare failed
5206                return 0
5207                    unless scalar(@{$self->{select}});
5208            }
5209            elsif ($self->{param}->[0] =~ m/$match2/ )
5210            {
5211                shift @{$self->{param}};
5212                $self->{select} = [];
5213                push @{$self->{select}},
5214                    $self->{gnz_h}->SQLSelectPrepare(@{$self->{param}});
5215
5216                # check if prepare failed
5217                return 0
5218                    unless scalar(@{$self->{select}});
5219            }
5220            elsif ($self->{param}->[0] =~ m/$match3/ )
5221            {
5222                shift @{$self->{param}};
5223                $self->{select} = [];
5224                push @{$self->{select}},
5225                    $self->{gnz_h}->SQLSelectPrepare2(@{$self->{param}});
5226
5227                # check if prepare failed
5228                return 0
5229                    unless scalar(@{$self->{select}});
5230            }
5231        }
5232
5233    }
5234
5235    $self->{rownum} = -1;
5236    $self->{state} = "PREPARE";
5237    return 1;
5238}
5239
5240sub _clearerror
5241{
5242    my $self = shift;
5243    $self->{errstr} = undef;
5244    $self->{err}    = undef;
5245}
5246
5247sub new
5248{
5249 #   whoami;
5250    my $invocant = shift;
5251    my $class = ref($invocant) || $invocant ;
5252    my $self = { };
5253
5254
5255    my %args = (@_);
5256
5257    $self->{GZERR} = $args{GZERR};
5258
5259    return undef
5260        unless (_init($self,%args));
5261
5262    return bless $self, $class;
5263
5264} # end new
5265
5266sub execute
5267{
5268#    whoami;
5269    my $self = shift;
5270    $self->_clearerror();
5271
5272    unless (exists($self->{select}))
5273    {
5274        my $stat = $self->{gnz_h}->Kgnz_Execute(@{$self->{param}});
5275
5276        # get the number of rows affected by insert/update/delete
5277        if ($self->{param}->[0] =~
5278            m/(?i)^(Kgnz_Insert2|SQLInsert|SQLUpdate|Feeble_Update|Feeble_Delete|SQLDelete)$/)
5279        {
5280#            greet $self->{param}->[0];
5281            $self->{rownum} = $stat;
5282        }
5283
5284        $self->{state} = "EXECUTE"
5285            if (defined($stat));
5286
5287        return $stat;
5288    }
5289
5290#    greet $self->{select};
5291
5292    $self->{sel_ex} = [];
5293    push @{$self->{sel_ex}},
5294        $self->{gnz_h}->SelectExecute(@{$self->{select}});
5295
5296    if (scalar(@{$self->{sel_ex}}))
5297    {
5298        $self->{state} = "EXECUTE";
5299
5300        $self->{rownum} = 0;
5301
5302        # see DBI Statement Handle Attributes
5303
5304        # XXX XXX: too fragile - make a hash
5305        $self->{NUM_OF_FIELDS} =
5306            scalar(@{$self->{sel_ex}->[3]}); # colnames
5307
5308        $self->{NAME} =
5309           $self->{sel_ex}->[3]; # colnames
5310
5311        return 1;
5312    }
5313    $self->{rownum} = -1;
5314    return undef;
5315}
5316
5317sub rows
5318{
5319    return $_[0]->{rownum};
5320}
5321
5322sub fetch
5323{
5324    my $self = shift;
5325    $self->_clearerror();
5326
5327    return $self->fetchrow_arrayref();
5328}
5329
5330sub _fetchrow_internal
5331{
5332    my ($self, $fetchtype) = @_;
5333    $self->_clearerror();
5334
5335    if (!defined($fetchtype) ||
5336        ($fetchtype =~ m/^ARRAY$/))
5337    {
5338        return $self->fetchrow_array();
5339    }
5340
5341    return $self->fetchall_arrayref()
5342        if ($fetchtype =~ m/^ALL_ARRAYREF$/);
5343
5344    my @val = $self->fetchrow_array();
5345
5346    return undef
5347        unless (scalar(@val));
5348
5349    return \@val # ARRAYREF
5350        if ($fetchtype =~ m/^ARRAYREF$/);
5351
5352    # else hashref
5353    return undef
5354        unless ($fetchtype =~ m/^HASHREF$/);
5355
5356    # XXX XXX: fix here too
5357#    print Data::Dumper->Dump([$self->{sel_ex}->[3]]), "\n";
5358    my $colnames = $self->{sel_ex}->[3];
5359
5360    my $outi2 = {};
5361
5362    for my $i (0..scalar(@{$colnames}))
5363    {
5364        my $v1 = $colnames->[$i];
5365        $outi2->{$v1} = shift @val;
5366        last
5367            unless (scalar(@val));
5368    }
5369#    print Data::Dumper->Dump([$outi2]), "\n";
5370
5371    return $outi2;
5372} # end _fetchrow_internal
5373
5374sub fetchall_arrayref
5375{
5376    my $self = shift;
5377
5378    my @outi;
5379    while (1)
5380    {
5381        my $ary_ref = $self->fetchrow_arrayref();
5382
5383        last
5384            unless (defined($ary_ref));
5385        push @outi, $ary_ref;
5386    }
5387
5388    return \@outi;
5389}
5390
5391sub fetchrow_arrayref
5392{
5393    my $self = shift;
5394    return $self->_fetchrow_internal("ARRAYREF");
5395}
5396sub fetchrow_hashref
5397{
5398#    whoami;
5399    my $self = shift;
5400    return $self->_fetchrow_internal("HASHREF");
5401}
5402
5403sub _selectrow_internal
5404{
5405#    whoami;
5406    my $self = shift;
5407
5408    return undef
5409        unless (defined($self->execute()));
5410    return $self->_fetchrow_internal(@_);
5411}
5412
5413sub fetchrow_array
5414{
5415    my $self = shift;
5416    $self->_clearerror();
5417
5418    return undef
5419        unless (
5420                ($self->{state} eq "EXECUTE")
5421                && exists($self->{sel_ex}));
5422
5423    # XXX : should we change state to "fetch"?  Should we be able to
5424    # re-execute in the middle of a fetch?
5425
5426#    greet $self->{prevkey}, $self->{rownum};
5427#    print Data::Dumper->Dump([$self->{prevkey}, $self->{rownum}]), "\n";
5428
5429    my ($key, $rownum, @vals) =
5430        $self->{gnz_h}->SelectFetch(
5431                                    $self->{prevkey},
5432                                    $self->{rownum},
5433                                    @{$self->{sel_ex}});
5434#    greet $k2, $rownum;
5435#    print Data::Dumper->Dump([$key, $rownum]), "\n";
5436    $self->{prevkey} = $key;
5437    $self->{rownum} = $rownum
5438        if (defined($rownum));
5439
5440    # XXX : should we change state to EOF (end of fetch) when key is null?
5441
5442#    greet @vals;
5443    return @vals;
5444}
5445
5446
5447# Autoload methods go after =cut, and are processed by the autosplit program.
5448
54491;
5450__END__
5451# Below is stub documentation for your module. You better edit it!
5452
5453=head1 NAME
5454
5455Genezzo::GenDBI.pm - an extensible database with SQL and DBI
5456
5457=head1 SYNOPSIS
5458
5459  # Basic line-mode usage
5460  use Genezzo::GenDBI; # see gendba.pl
5461
5462  my $fb = Genezzo::GenDBI->new(exe => $0,
5463                                gnz_home => $mygnz_home,
5464                                dbinit => $do_init);
5465
5466  $fb->Parseall($myquery); # process a statement
5467
5468  $fb->Interactive();      # invoke line mode
5469
5470  # DBI-style usage - see perldoc DBI, <http://dbi.perl.org/>
5471  my $dbh = Genezzo::GenDBI->connect($mygnz_home);
5472  my $rv  = Genezzo::GenDBI->do("startup");
5473
5474  my @row_ary  = $dbh->selectrow_array($statement);
5475  my $ary_ref  = $dbh->selectrow_arrayref($statement);
5476  my $hash_ref = $dbh->selectrow_hashref($statement);
5477
5478  my $sth = $dbh->prepare($statement);
5479  $rv     = $sth->execute;
5480
5481  @row_ary  = $sth->fetchrow_array;
5482  $ary_ref  = $sth->fetchrow_arrayref;
5483  $hash_ref = $sth->fetchrow_hashref;
5484
5485  $rv  = $sth->rows;
5486  $rv  = Genezzo::GenDBI->do("commit");
5487  $rv  = Genezzo::GenDBI->do("shutdown");
5488
5489=head1 DESCRIPTION
5490
5491  The Genezzo modules implement a hierarchy of persistent hashes using
5492  a fixed amount of memory and disk.  This system is designed to be
5493  easily configured and extended with custom functions, persistent
5494  storage representations, and novel data access methods.  In its
5495  current incarnation it supports a subset of SQL and a partial
5496  DBI interface.
5497
5498=head2 EXPORT
5499
5500 VERSION, RELSTATUS, RELDATE: version, release status, and release date
5501
5502=head1 TODO
5503
5504=over 4
5505
5506=item SPOOL: options to remove "prompt> " from output files
5507
5508=item Feeble/SQL: fix DESCribe to handle quoted identifiers.
5509
5510=item TABLESPACE: alter, drop, online, offline, more testing...
5511
5512=item This module is a bit of a catch-all, since it contains a
5513DBI-style interface, an interactive loop with an interpreter and some
5514presentation code, plus some expression evaluation and query planning
5515logic.  It needs to get split up.
5516
5517=item SQLselprep_Algebra: move to XEval
5518
5519=item SQLAlter: need And purity check
5520
5521=item SQLUpdate: cleanup - avoid generating new SELECT.  Allow regexp update.
5522
5523=item SQLCreate: need to handle CREATE TABLE AS SELECT, table/column
5524      constraints, etc.
5525
5526=back
5527
5528=head1 AUTHOR
5529
5530Jeffrey I. Cohen, jcohen@genezzo.com
5531
5532=head1 SEE ALSO
5533
5534L<perl(1)>, C<gendba.pl -man>,
5535C<perldoc DBI>, L<http://dbi.perl.org/>
5536
5537Copyright (c) 2003-2007 Jeffrey I Cohen.  All rights reserved.
5538
5539    This program is free software; you can redistribute it and/or modify
5540    it under the terms of the GNU General Public License as published by
5541    the Free Software Foundation; either version 2 of the License, or
5542    any later version.
5543
5544    This program is distributed in the hope that it will be useful,
5545    but WITHOUT ANY WARRANTY; without even the implied warranty of
5546    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
5547    GNU General Public License for more details.
5548
5549    You should have received a copy of the GNU General Public License
5550    along with this program; if not, write to the Free Software
5551    Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA
5552
5553Address bug reports and comments to: jcohen@genezzo.com
5554
5555For more information, please visit the Genezzo homepage
5556at L<http://www.genezzo.com>
5557
5558=cut
5559