1package SQL::Parser;
2
3######################################################################
4#
5# This module is copyright (c), 2001,2005 by Jeff Zucker.
6# This module is copyright (c), 2007-2020 by Jens Rehsack.
7# All rights reserved.
8#
9# It may be freely distributed under the same terms as Perl itself.
10# See below for help and copyright information (search for SYNOPSIS).
11#
12######################################################################
13
14use strict;
15use warnings FATAL => "all";
16use vars qw($VERSION);
17use constant FUNCTION_NAMES => join( '|', qw(TRIM SUBSTRING) );
18use constant BAREWORD_FUNCTIONS =>
19  join( '|', qw(TRIM SUBSTRING CURRENT_DATE CURDATE CURRENT_TIME CURTIME CURRENT_TIMESTAMP NOW UNIX_TIMESTAMP PI DBNAME) );
20use Carp qw(carp croak);
21use Params::Util qw(_ARRAY0 _ARRAY _HASH);
22use Scalar::Util qw(looks_like_number);
23use Text::Balanced qw(extract_bracketed extract_multiple);
24
25$VERSION = '1.414';
26
27BEGIN
28{
29    if ( $ENV{SQL_USER_DEFS} ) { require SQL::UserDefs; }
30}
31
32#############################
33# PUBLIC METHODS
34#############################
35
36sub new
37{
38    my $class = shift;
39    my $dialect = shift || 'ANSI';
40    $dialect = 'ANSI'    if ( uc $dialect eq 'ANSI' );
41    $dialect = 'AnyData' if ( ( uc $dialect eq 'ANYDATA' ) or ( uc $dialect eq 'CSV' ) );
42    $dialect = 'AnyData' if ( $dialect eq 'SQL::Eval' );
43
44    my $flags = shift || {};
45    $flags->{dialect} = $dialect;
46    $flags->{PrintError} = 1 unless ( defined( $flags->{PrintError} ) );
47
48    my $self = bless( $flags, $class );
49    $self->dialect( $self->{dialect} );
50    $self->set_feature_flags( $self->{select}, $self->{create} );
51
52    $self->LOAD('LOAD SQL::Statement::Functions');
53
54    return $self;
55}
56
57sub parse
58{
59    my ( $self, $sql ) = @_;
60    $self->dialect( $self->{dialect} ) unless ( $self->{dialect_set} );
61    $sql =~ s/^\s+//;
62    $sql =~ s/\s+$//;
63    $sql =~ s/\s*;$//;
64    $self->{struct}                    = { dialect => $self->{dialect} };
65    $self->{tmp}                       = {};
66    $self->{original_string}           = $sql;
67    $self->{struct}->{original_string} = $sql;
68
69    ################################################################
70    #
71    # COMMENTS
72
73    # C-STYLE
74    #
75    my $comment_re = $self->{comment_re} || '(\/\*.*?\*\/)';
76    $self->{comment_re} = $comment_re;
77    my $starts_with_comment;
78    if ( $sql =~ /^\s*$comment_re(.*)$/s )
79    {
80        $self->{comment}     = $1;
81        $sql                 = $2;
82        $starts_with_comment = 1;
83    }
84
85    # SQL STYLE
86    #
87    # SQL-style comment can not begin inside quotes.
88    if ( $sql =~ s/^([^']*?(?:'[^']*'[^'])*?)(--.*)(\n|$)/$1$3/ )
89    {
90        $self->{comment} = $2;
91    }
92    ################################################################
93
94    $sql = $self->clean_sql($sql);
95    my ($com) = $sql =~ m/^\s*(\S+)\s+/s;
96    if ( !$com )
97    {
98        return 1 if ($starts_with_comment);
99        return $self->do_err("Incomplete statement!");
100    }
101    $com                                    = uc $com;
102    $self->{opts}->{valid_commands}->{CALL} = 1;
103    $self->{opts}->{valid_commands}->{LOAD} = 1;
104    if ( $self->{opts}->{valid_commands}->{$com} )
105    {
106        my $rv = $self->$com($sql);
107        delete $self->{struct}->{literals};
108
109        return $self->do_err("No command found!") unless ( $self->{struct}->{command} );
110
111        $self->replace_quoted_ids();
112
113        my @tables = @{ $self->{struct}->{table_names} }
114          if ( defined( _ARRAY0( $self->{struct}->{table_names} ) ) );
115        push( @{ $self->{struct}->{org_table_names} }, @tables );
116        # REMOVE schema.table info if present
117        @tables = map { s/^.*\.([^\.]+)$/$1/; ( -1 == index( $_, '"' ) ) ? lc $_ : $_ } @tables;
118
119        if ( exists( $self->{struct}->{join} ) && !defined( _HASH( $self->{struct}->{join} ) ) )
120        {
121            delete $self->{struct}->{join};
122        }
123        else
124        {
125            $self->{struct}->{join}->{table_order} = $self->{struct}->{table_names}
126              if ( defined( $self->{struct}->{join}->{table_order} )
127                && !defined( _ARRAY0( $self->{struct}->{join}->{table_order} ) ) );
128            @{ $self->{struct}->{join}->{keycols} } =
129              map { lc $_ } @{ $self->{struct}->{join}->{keycols} }
130              if ( $self->{struct}->{join}->{keycols} );
131            @{ $self->{struct}->{join}->{shared_cols} } =
132              map { lc $_ } @{ $self->{struct}->{join}->{shared_cols} }
133              if ( $self->{struct}->{join}->{shared_cols} );
134        }
135
136        if (   defined( $self->{struct}->{column_defs} )
137            && defined( _ARRAY( $self->{struct}->{column_defs} ) ) )
138        {
139            my $colname;
140            # FIXME SUBSTR('*')
141            my @fine_defs =
142              grep { defined( $_->{fullorg} ) && ( -1 == index( $_->{fullorg}, '*' ) ) } @{ $self->{struct}->{column_defs} };
143            foreach my $col (@fine_defs)
144            {
145                my $colname = $col->{fullorg};
146                #$cn = lc $cn unless ( $cn =~ m/^(?:\w+\.)?"/ );
147                push( @{ $self->{struct}->{org_col_names} }, $self->{struct}->{ORG_NAME}->{$colname} || $colname );
148            }
149
150            unless ( $com eq 'CREATE' )
151            {
152                $self->{struct}->{table_names} = \@tables;
153                #  For RR aliases, added quoted id protection from upper casing
154                foreach my $col (@fine_defs)
155                {
156                    # defined( $col->{fullorg} ) && ( -1 == index( $col->{fullorg}, '*' ) ) or next;
157                    my $orgname = $colname = $col->{fullorg};
158                    $colname =~ m/^(?:\p{Word}+\.)?"/ or $colname = lc $colname;
159                    defined( $self->{struct}->{ORG_NAME}->{$colname} ) and next;
160                    $self->{struct}->{ORG_NAME}->{$colname} =
161                      $self->{struct}->{ORG_NAME}->{$orgname};
162                }
163                #my @uCols = map { ( $_ =~ /^(\w+\.)?"/ ) ? $_ : lc $_ } @{ $self->{struct}->{column_names} };
164                #$self->{struct}->{column_names} = \@uCols;
165            }
166        }
167
168        return $rv;
169    }
170    else
171    {
172        $self->{struct} = {};
173        if ( $ENV{SQL_USER_DEFS} )
174        {
175            return SQL::UserDefs::user_parse( $self, $sql );
176        }
177        return $self->do_err("Command '$com' not recognized or not supported!");
178    }
179}
180
181sub replace_quoted_commas
182{
183    my ( $self, $id ) = @_;
184    $id =~ s/\?COMMA\?/,/gs;
185    return $id;
186}
187
188sub replace_quoted_ids
189{
190    my ( $self, $id ) = @_;
191    $self->{struct}->{quoted_ids} or $self->{struct}->{literals} or return;
192    if ($id)
193    {
194        if ( $id =~ /^\?QI(\d+)\?$/ )
195        {
196            return '"' . $self->{struct}->{quoted_ids}->[$1] . '"';
197        }
198        elsif ( $id =~ /^\?(\d+)\?$/ )
199        {
200            return $self->{struct}->{literals}->[$1];
201        }
202        else
203        {
204            return $id;
205        }
206    }
207    return unless defined $self->{struct}->{table_names};
208    my @tables = @{ $self->{struct}->{table_names} };
209    for my $t (@tables)
210    {
211        if ( $t =~ /^\?QI(.+)\?$/ )
212        {
213            $t = '"' . $self->{struct}->{quoted_ids}->[$1] . '"';
214        }
215	elsif( $t =~ /^\?(\d+)\?$/ )
216	{
217            $t = $self->{struct}->{literals}->[$1];
218	}
219    }
220    $self->{struct}->{table_names} = \@tables;
221    delete $self->{struct}->{quoted_ids};
222}
223
224sub structure { $_[0]->{struct} }
225sub command { my $x = $_[0]->{struct}->{command} || '' }
226
227sub feature
228{
229    my ( $self, $opt_class, $opt_name, $opt_value ) = @_;
230    if ( defined $opt_value )
231    {
232        if ( $opt_class eq 'select' )
233        {
234            $self->set_feature_flags( { "join" => $opt_value } );
235        }
236        elsif ( $opt_class eq 'create' )
237        {
238            $self->set_feature_flags( undef, { $opt_name => $opt_value } );
239        }
240        else
241        {
242
243            # patch from chromatic
244            $self->{opts}->{$opt_class}->{$opt_name} = $opt_value;
245
246            # $self->{$opt_class}->{$opt_name} = $opt_value;
247        }
248    }
249    else
250    {
251        return $self->{opts}->{$opt_class}->{$opt_name};
252    }
253}
254
255sub errstr { $_[0]->{struct}->{errstr} }
256
257sub list
258{
259    my $self = shift;
260    my $com  = uc shift;
261    return () if $com !~ /COMMANDS|RESERVED|TYPES|OPS|OPTIONS|DIALECTS/i;
262    $com = 'valid_commands'             if $com eq 'COMMANDS';
263    $com = 'valid_comparison_operators' if $com eq 'OPS';
264    $com = 'valid_data_types'           if $com eq 'TYPES';
265    $com = 'valid_options'              if $com eq 'OPTIONS';
266    $com = 'reserved_words'             if $com eq 'RESERVED';
267    $self->dialect( $self->{dialect} ) unless $self->{dialect_set};
268
269    return sort keys %{ $self->{opts}->{$com} } unless $com eq 'DIALECTS';
270    my $dDir = "SQL/Dialects";
271    my @dialects;
272    for my $dir (@INC)
273    {
274        local *D;
275
276        if ( opendir( D, "$dir/$dDir" ) )
277        {
278            @dialects = grep /.*\.pm$/, readdir(D);
279            last;
280        }
281    }
282    @dialects = map { s/\.pm$//; $_ } @dialects;
283    return @dialects;
284}
285
286sub dialect
287{
288    my ( $self, $dialect ) = @_;
289    return $self->{dialect} unless ($dialect);
290    return $self->{dialect} if ( $self->{dialect_set} );
291    $self->{opts} = {};
292    my $mod_class = "SQL::Dialects::$dialect";
293
294    $self->_load_class($mod_class) unless $mod_class->can("get_config");
295
296    # This is here for backwards compatibility with existing dialects
297    # before the had the role to add new methods.
298    $self->_inject_role( "SQL::Dialects::Role", $mod_class )
299      unless ( $mod_class->can("get_config_as_hash") );
300
301    $self->{opts} = $mod_class->get_config_as_hash();
302
303    $self->create_op_regexen();
304    $self->{dialect} = $dialect;
305    $self->{dialect_set}++;
306
307    return $self->{dialect};
308}
309
310sub _load_class
311{
312    my ( $self, $class ) = @_;
313
314    my $mod = $class;
315    $mod =~ s{::}{/}g;
316    $mod .= ".pm";
317
318    local ( $!, $@ );
319    eval { require "$mod"; } or return $self->do_err($@);
320
321    return 1;
322}
323
324sub _inject_role
325{
326    my ( $self, $role, $dest ) = @_;
327
328    eval qq{
329        package $dest;
330        use $role;
331        1;
332    } or croak "Can't inject $role into $dest: $@";
333}
334
335sub create_op_regexen
336{
337    my ($self) = @_;
338
339    #
340    #	DAA precompute the predicate operator regex's
341    #
342    #       JZ moved this into a sub so it can be called from both
343    #       dialect() and from CREATE_OPERATOR and DROP_OPERATOR
344    #       since those also modify the available operators
345    #
346    my @allops = keys %{ $self->{opts}->{valid_comparison_operators} };
347
348    #
349    #	complement operators
350    #
351    my @notops;
352    for (@allops)
353    {
354        push( @notops, $_ )
355          if /NOT/i;
356    }
357    $self->{opts}->{valid_comparison_NOT_ops_regex} = '^\s*(.+)\s+(' . join( '|', @notops ) . ')\s+(.*)\s*$'
358      if scalar @notops;
359
360    #
361    #	<>, <=, >= operators
362    #
363    my @compops;
364    for (@allops)
365    {
366        push( @compops, $_ )
367          if /<=|>=|<>/;
368    }
369    $self->{opts}->{valid_comparison_twochar_ops_regex} = '^\s*(.+)\s+(' . join( '|', @compops ) . ')\s+(.*)\s*$'
370      if scalar @compops;
371
372    #
373    #	everything
374    #
375    $self->{opts}->{valid_comparison_ops_regex} = '^\s*(.+)\s+(' . join( '|', @allops ) . ')\s+(.*)\s*$'
376      if scalar @allops;
377
378    #
379    #	end DAA
380    #
381}
382
383##################################################################
384# SQL COMMANDS
385##################################################################
386
387####################################################
388# DROP TABLE <table_name>
389####################################################
390sub DROP
391{
392    my ( $self, $stmt ) = @_;
393    my $features = 'TYPE|KEYWORD|FUNCTION|OPERATOR|PREDICATE';
394    if ( $stmt =~ /^\s*DROP\s+($features)\s+(.+)$/si )
395    {
396        my ( $sub, $arg ) = ( $1, $2 );
397        $sub = 'DROP_' . $sub;
398        return $self->$sub($arg);
399    }
400    my $table_name;
401    $self->{struct}->{command} = 'DROP';
402    if ( $stmt =~ /^\s*DROP\s+TABLE\s+IF\s+EXISTS\s+(.*)$/si )
403    {
404        $stmt = "DROP TABLE $1";
405        $self->{struct}->{ignore_missing_table} = 1;
406    }
407    if ( $stmt =~ /^\s*DROP\s+(\S+)\s+(.+)$/si )
408    {
409        my $com2 = $1 || '';
410        $table_name = $2;
411        if ( $com2 !~ /^TABLE$/i )
412        {
413            return $self->do_err("The command 'DROP $com2' is not recognized or not supported!");
414        }
415        $table_name =~ s/^\s+//;
416        $table_name =~ s/\s+$//;
417        if ( $table_name =~ /(\S+) (RESTRICT|CASCADE)/i )
418        {
419            $table_name = $1;
420            $self->{struct}->{drop_behavior} = uc $2;
421        }
422    }
423    else
424    {
425        return $self->do_err("Incomplete DROP statement!");
426
427    }
428    return undef unless $self->TABLE_NAME($table_name);
429    $table_name = $self->replace_quoted_ids($table_name);
430    $self->{tmp}->{is_table_name} = { $table_name => 1 };
431    $self->{struct}->{table_names} = [$table_name];
432    return 1;
433}
434
435####################################################
436# DELETE FROM <table_name> WHERE <search_condition>
437####################################################
438sub DELETE
439{
440    my ( $self, $str ) = @_;
441    $self->{struct}->{command} = 'DELETE';
442    $str =~ s/^DELETE\s+FROM\s+/DELETE /i;    # Make FROM optional
443    my ( $table_name, $where_clause ) = $str =~ /^DELETE (\S+)(.*)$/i;
444    return $self->do_err('Incomplete DELETE statement!') if !$table_name;
445    return undef unless $self->TABLE_NAME($table_name);
446    $self->{tmp}->{is_table_name}  = { $table_name => 1 };
447    $self->{struct}->{table_names} = [$table_name];
448    $self->{struct}->{column_defs} = [
449        {
450            type  => 'column',
451            value => '*'
452        }
453    ];
454    $where_clause =~ s/^\s+//;
455    $where_clause =~ s/\s+$//;
456
457    if ($where_clause)
458    {
459        $where_clause =~ s/^WHERE\s*(.*)$/$1/i;
460        return undef unless $self->SEARCH_CONDITION($where_clause);
461    }
462    return 1;
463}
464
465##############################################################
466# SELECT
467##############################################################
468#    SELECT [<set_quantifier>] <select_list>
469#           | <set_function_specification>
470#      FROM <from_clause>
471#    [WHERE <search_condition>]
472# [ORDER BY <order_by_clause>]
473#    [LIMIT <limit_clause>]
474##############################################################
475
476sub SELECT
477{
478    my ( $self, $str ) = @_;
479    $self->{struct}->{command} = 'SELECT';
480    my ( $from_clause, $where_clause, $order_clause, $groupby_clause, $limit_clause );
481    $str =~ s/^SELECT (.+)$/$1/i;
482    if ( $str =~ s/^(.+) LIMIT (.+)$/$1/i )    { $limit_clause   = $2; }
483    if ( $str =~ s/^(.+) ORDER BY (.+)$/$1/i ) { $order_clause   = $2; }
484    if ( $str =~ s/^(.+) GROUP BY (.+)$/$1/i ) { $groupby_clause = $2; }
485    if ( $str =~ s/^(.+?) WHERE (.+)$/$1/i )   { $where_clause   = $2; }
486    if ( $str =~ s/^(.+?) FROM (.+)$/$1/i )    { $from_clause    = $2; }
487
488    #    else {
489    #        return $self->do_err("Couldn't find FROM clause in SELECT!");
490    #    }
491    #    return undef unless $self->FROM_CLAUSE($from_clause);
492    my $has_from_clause = $self->FROM_CLAUSE($from_clause) if ($from_clause);
493
494    return undef unless ( $self->SELECT_CLAUSE($str) );
495
496    if ($where_clause)
497    {
498        return undef unless ( $self->SEARCH_CONDITION($where_clause) );
499    }
500    if ($groupby_clause)
501    {
502        return undef unless ( $self->GROUPBY_LIST($groupby_clause) );
503    }
504    if ($order_clause)
505    {
506        return undef unless ( $self->SORT_SPEC_LIST($order_clause) );
507    }
508    if ($limit_clause)
509    {
510        return undef unless ( $self->LIMIT_CLAUSE($limit_clause) );
511    }
512    if (
513        ( $self->{struct}->{join}->{clause} and $self->{struct}->{join}->{clause} eq 'ON' )
514        or ( $self->{struct}->{multiple_tables}
515            and !( scalar keys %{ $self->{struct}->{join} } ) )
516      )
517    {
518        return undef unless ( $self->IMPLICIT_JOIN() );
519    }
520
521    if (   $self->{struct}->{set_quantifier}
522        && ( 'DISTINCT' eq $self->{struct}->{set_quantifier} )
523        && $self->{struct}->{has_set_functions}
524        && !defined( _ARRAY( $self->{struct}->{group_by} ) ) )
525    {
526        delete $self->{struct}->{set_quantifier};
527        carp "Specifying DISTINCT when using aggregate functions isn't reasonable - ignored."
528          if ( $self->{PrintError} );
529    }
530
531    return 1;
532}
533
534sub GROUPBY_LIST
535{
536    my ( $self, $gclause ) = @_;
537    return 1 unless ($gclause);
538    my $cols = $self->ROW_VALUE_LIST($gclause);
539    return undef if ( $self->{struct}->{errstr} );
540    @{ $self->{struct}->{group_by} } = map { $_->{fullorg} } @{$cols};
541    return 1;
542}
543
544sub IMPLICIT_JOIN
545{
546    my $self = $_[0];
547    delete $self->{struct}->{multiple_tables};
548    if (  !$self->{struct}->{join}->{clause}
549        or $self->{struct}->{join}->{clause} ne 'ON' )
550    {
551        $self->{struct}->{join}->{type}   = 'INNER';
552        $self->{struct}->{join}->{clause} = 'IMPLICIT';
553    }
554    if ( defined $self->{struct}->{keycols} )
555    {
556        my @keys;
557        my @keys2 = @keys = @{ $self->{struct}->{keycols} };
558        $self->{struct}->{join}->{table_order} = $self->order_joins( \@keys2 );
559        @{ $self->{struct}->{join}->{keycols} } = @keys;
560        delete $self->{struct}->{keycols};
561    }
562    else
563    {
564        return $self->do_err("No equijoin condition in WHERE or ON clause");
565    }
566    return 1;
567}
568
569sub EXPLICIT_JOIN
570{
571    my ( $self, $remainder ) = @_;
572    return undef unless ($remainder);
573    my ( $tableA, $tableB, $keycols, $jtype, $natural );
574    if ( $remainder =~ m/^(.+?) (NATURAL|INNER|LEFT|RIGHT|FULL|CROSS|UNION|JOIN)(.+)$/is )
575    {
576        $tableA    = $1;
577        $remainder = $2 . $3;
578    }
579    else
580    {
581        ( $tableA, $remainder ) = $remainder =~ m/^(\S+) (.*)/i;
582    }
583    if ( $remainder =~ m/^NATURAL (.+)/ )
584    {
585        $self->{struct}->{join}->{clause} = 'NATURAL';
586        $natural++;
587        $remainder = $1;
588    }
589    if ( $remainder =~ m/^(INNER|LEFT|RIGHT|FULL|CROSS|UNION) JOIN (.+)/i )
590    {
591        $jtype = $self->{struct}->{join}->{clause} = uc($1);
592        $remainder = $2;
593        $jtype = "$jtype OUTER" if $jtype !~ /INNER|UNION/i;
594    }
595    if ( $remainder =~ m/^(LEFT|RIGHT|FULL|CROSS) OUTER JOIN (.+)/i )
596    {
597        $jtype = $self->{struct}->{join}->{clause} = uc($1) . " OUTER";
598        $remainder = $2;
599    }
600    if ( $remainder =~ m/^JOIN (.+)/i )
601    {
602        $jtype                            = 'INNER';
603        $self->{struct}->{join}->{clause} = 'DEFAULT INNER';
604        $remainder                        = $1;
605    }
606    if ( $self->{struct}->{join} )
607    {
608        if ( $remainder && $remainder =~ m/^(.+?) USING \(([^\)]+)\)(.*)/i )
609        {
610            $self->{struct}->{join}->{clause} = 'USING';
611            $tableB = $1;
612            my $keycolstr = $2;
613            $remainder = $3;
614            @$keycols = split( /,/, $keycolstr );
615        }
616        if ( $remainder && $remainder =~ m/^(.+?) ON (.+)/i )
617        {
618            $self->{struct}->{join}->{clause} = 'ON';
619            $tableB = $1;
620            my $keycolstr = $2;
621            $remainder = $3;
622            @$keycols = split(/ AND|OR /i, $keycolstr);
623
624            return undef
625              unless $self->TABLE_NAME_LIST( $tableA . ',' . $tableB );
626
627            #              $self->{tmp}->{is_table_name}->{"$tableA"} = 1;
628            #              $self->{tmp}->{is_table_name}->{"$tableB"} = 1;
629            for my $keycol (@$keycols)
630            {
631                my %is_done;
632		$keycol =~ s/\)|\(//g;
633                my ( $arg1, $arg2 ) = split( m/ [>=<] /, $keycol );
634                my ( $c1, $c2 ) = ( $arg1, $arg2 );
635                $c1 =~ s/^.*\.([^\.]+)$/$1/;
636                $c2 =~ s/^.*\.([^\.]+)$/$1/;
637                if ( $c1 eq $c2 )
638                {
639                    return undef unless ( $arg1 = $self->ROW_VALUE($c1) );
640                    if ( $arg1->{type} eq 'column' and !$is_done{$c1} )
641                    {
642                        push( @{ $self->{struct}->{keycols} }, $arg1->{value} );
643                        $is_done{$c1} = 1;
644                    }
645                }
646                else
647                {
648                    return undef unless ( $arg1 = $self->ROW_VALUE($arg1) );
649                    return undef unless ( $arg2 = $self->ROW_VALUE($arg2) );
650                    if (    $arg1->{type} eq 'column'
651                        and $arg2->{type} eq 'column' )
652                    {
653                        push( @{ $self->{struct}->{keycols} }, $arg1->{value} );
654                        push( @{ $self->{struct}->{keycols} }, $arg2->{value} );
655
656                        # delete $self->{struct}->{where_clause};
657                    }
658                }
659            }
660        }
661        elsif ( $remainder =~ /^(.+?)$/i )
662        {
663            $tableB    = $1;
664            $remainder = $2;
665        }
666        $remainder =~ s/^\s+// if ($remainder);
667    }
668
669    if ($jtype)
670    {
671        $jtype = "NATURAL $jtype" if ($natural);
672        if ( $natural and $keycols )
673        {
674            return $self->do_err(qq{Can't use NATURAL with a USING or ON clause!});
675        }
676        return undef unless ( $self->TABLE_NAME_LIST("$tableA,$tableB") );
677        $self->{struct}->{join}->{type} = $jtype;
678        $self->{struct}->{join}->{keycols} = $keycols if ($keycols);
679        return 1;
680    }
681    return $self->do_err("Couldn't parse explicit JOIN!");
682}
683
684sub SELECT_CLAUSE
685{
686    my ( $self, $str ) = @_;
687    return undef unless ($str);
688    if ( $str =~ s/^(DISTINCT|ALL) (.+)$/$2/i )
689    {
690        $self->{struct}->{set_quantifier} = uc($1);
691    }
692    return undef unless ( $self->SELECT_LIST($str) );
693}
694
695sub FROM_CLAUSE
696{
697    my ( $self, $str ) = @_;
698    return undef unless $str;
699    if ( $str =~ m/ JOIN /i )
700    {
701        return undef unless $self->EXPLICIT_JOIN($str);
702    }
703    else
704    {
705        return undef unless $self->TABLE_NAME_LIST($str);
706    }
707}
708
709sub INSERT
710{
711    my ( $self, $str ) = @_;
712    my $col_str;
713    $str =~ s/^INSERT\s+INTO\s+/INSERT /i;    # allow INTO to be optional
714    my ( $table_name, $val_str ) = $str =~ m/^INSERT\s+(.+?)\s+VALUES\s+(\(.+\))$/i;
715    if ( $table_name and $table_name =~ m/[()]/ )
716    {
717        ( $table_name, $col_str, $val_str ) = $str =~ m/^INSERT\s+(.+?)\s+\((.+?)\)\s+VALUES\s+(\(.+\))$/i;
718    }
719    return $self->do_err('No table name specified!') unless ($table_name);
720    return $self->do_err('Missing values list!')     unless ( defined $val_str );
721    return undef                                     unless ( $self->TABLE_NAME($table_name) );
722    $self->{struct}->{command}     = 'INSERT';
723    $self->{struct}->{table_names} = [$table_name];
724    if ($col_str)
725    {
726        return undef unless ( $self->{struct}->{column_defs} = $self->ROW_VALUE_LIST($col_str) );
727    }
728    else
729    {
730        $self->{struct}->{column_defs} = [
731            {
732                type  => 'column',
733                value => '*'
734            }
735        ];
736    }
737    $self->{struct}->{values} = [];
738    for (my ($v,$line_str) = $val_str;
739	 (($line_str,$v)=extract_bracketed($v,"('",'')) && defined $line_str;
740	) {
741      return undef unless ( $self->LITERAL_LIST(substr($line_str,1,-1)) );
742      last unless $v =~ s/\A\s*,\s*//;
743    }
744
745    return 1;
746}
747
748###################################################################
749# UPDATE ::=
750#
751# UPDATE <table> SET <set_clause_list> [ WHERE <search_condition>]
752#
753###################################################################
754sub UPDATE
755{
756    my ( $self, $str ) = @_;
757    $self->{struct}->{command} = 'UPDATE';
758    my ( $table_name, $remainder ) = $str =~ m/^UPDATE (.+?) SET (.+)$/i;
759    return $self->do_err('Incomplete UPDATE clause') unless ( $table_name && $remainder );
760    return undef unless ( $self->TABLE_NAME($table_name) );
761    $self->{tmp}->{is_table_name} = { $table_name => 1 };
762    $self->{struct}->{table_names} = [$table_name];
763    my ( $set_clause, $where_clause ) = $remainder =~ m/(.*?) WHERE (.*)$/i;
764    $set_clause = $remainder if ( !$set_clause );
765    return undef unless ( $self->SET_CLAUSE_LIST($set_clause) );
766
767    if ($where_clause)
768    {
769        return undef unless ( $self->SEARCH_CONDITION($where_clause) );
770    }
771
772    my @vals                 = @{ $self->{struct}->{values}->[0] };
773    my $num_val_placeholders = 0;
774    for my $v (@vals)
775    {
776        ++$num_val_placeholders if ( $v->{type} eq 'placeholder' );
777    }
778    $self->{struct}->{num_val_placeholders} = $num_val_placeholders;
779
780    return 1;
781}
782
783############
784# FUNCTIONS
785############
786sub LOAD
787{
788    my ( $self, $str ) = @_;
789    $self->{struct}->{command}    = 'LOAD';
790    $self->{struct}->{no_execute} = 1;
791    my ($package) = $str =~ /^LOAD\s+(.+)$/;
792    $str = $package;
793    $package =~ s/\?(\d+)\?/$self->{struct}->{literals}->[$1]/g;
794
795    $self->_load_class($package);
796
797    my %subs = eval '%' . $package . '::';
798
799    for my $sub ( keys %subs )
800    {
801        next unless ( $sub =~ m/^SQL_FUNCTION_([A-Z_0-9]+)$/ );
802        my $funcName = uc $1;
803        my $subname  = $package . '::' . 'SQL_FUNCTION_' . $funcName;
804        $self->{opts}->{function_names}->{$funcName} = $subname;
805        delete $self->{opts}->{_udf_function_names};
806    }
807    1;
808}
809
810sub CREATE_RAM_TABLE
811{
812    my ( $self, $stmt ) = @_;
813    $self->{struct}->{is_ram_table} = 1;
814    $self->{struct}->{command}      = 'CREATE_RAM_TABLE';
815    my ( $table_name, $table_element_def, %is_col_name );
816    if ( $stmt =~ /^(\S+)\s+LIKE\s*(.+)$/si )
817    {
818        $table_name        = $1;
819        $table_element_def = $2;
820        if ( $table_element_def =~ /^(.*)\s+KEEP CONNECTION\s*$/i )
821        {
822            $table_element_def = $1;
823            $self->{struct}->{ram_table_keep_connection} = 1;
824        }
825    }
826    else
827    {
828        return $self->CREATE("CREATE TABLE $stmt");
829    }
830    return undef unless $self->TABLE_NAME($table_name);
831    for my $col ( split ',', $table_element_def )
832    {
833        push( @{ $self->{struct}->{column_defs} }, $self->ROW_VALUE($col) );
834    }
835    $self->{struct}->{table_names} = [$table_name];
836    return 1;
837}
838
839sub CREATE_FUNCTION
840{
841    my ( $self, $stmt ) = @_;
842    $self->{struct}->{command}    = 'CREATE_FUNCTION';
843    $self->{struct}->{no_execute} = 1;
844    my ( $func, $subname );
845    $stmt =~ s/\s*EXTERNAL//i;
846    if ( $stmt =~ /^(\S+)\s+NAME\s+(.*)$/smi )
847    {
848        $func    = trim($1);
849        $subname = trim($2);
850    }
851    $func    ||= $stmt;
852    $subname ||= $func;
853    if ( $func =~ /^\?QI(\d+)\?$/ )
854    {
855        $func = $self->{struct}->{quoted_ids}->[$1];
856    }
857    if ( $subname =~ /^\?QI(\d+)\?$/ )
858    {
859        $subname = $self->{struct}->{quoted_ids}->[$1];
860    }
861    $self->{opts}->{function_names}->{ uc $func } = $subname;
862    delete $self->{opts}->{_udf_function_names};
863
864    return 1;
865}
866
867sub CALL
868{
869    my ( $self, $stmt ) = @_;
870    $stmt =~ s/^CALL\s+(.*)/$1/i;
871    $self->{struct}->{command}   = 'CALL';
872    $self->{struct}->{procedure} = $self->ROW_VALUE($stmt);
873    return 1;
874}
875
876sub CREATE_TYPE
877{
878    my ( $self, $type ) = @_;
879    $self->{struct}->{command}    = 'CREATE_TYPE';
880    $self->{struct}->{no_execute} = 1;
881    $self->feature( 'valid_data_types', uc $type, 1 );
882}
883
884sub DROP_TYPE
885{
886    my ( $self, $type ) = @_;
887    $self->{struct}->{command}    = 'DROP_TYPE';
888    $self->{struct}->{no_execute} = 1;
889    $self->feature( 'valid_data_types', uc $type, 0 );
890}
891
892sub CREATE_KEYWORD
893{
894    my ( $self, $type ) = @_;
895    $self->{struct}->{command}    = 'CREATE_KEYWORD';
896    $self->{struct}->{no_execute} = 1;
897    $self->feature( 'reserved_words', uc $type, 1 );
898}
899
900sub DROP_KEYWORD
901{
902    my ( $self, $type ) = @_;
903    $self->{struct}->{command}    = 'DROP_KEYWORD';
904    $self->{struct}->{no_execute} = 1;
905    $self->feature( 'reserved_words', uc $type, 0 );
906}
907
908sub CREATE_OPERATOR
909{
910    my ( $self, $stmt ) = @_;
911    $self->{struct}->{command}    = 'CREATE_OPERATOR';
912    $self->{struct}->{no_execute} = 1;
913
914    my ( $func, $subname );
915    $stmt =~ s/\s*EXTERNAL//i;
916    if ( $stmt =~ /^(\S+)\s+NAME\s+(.*)$/smi )
917    {
918        $func    = trim($1);
919        $subname = trim($2);
920    }
921    $func    ||= $stmt;
922    $subname ||= $func;
923    if ( $func =~ /^\?QI(\d+)\?$/ )
924    {
925        $func = $self->{struct}->{quoted_ids}->[$1];
926    }
927    if ( $subname =~ /^\?QI(\d+)\?$/ )
928    {
929        $subname = $self->{struct}->{quoted_ids}->[$1];
930    }
931    $self->{opts}->{function_names}->{ uc $func } = $subname;
932    delete $self->{opts}->{_udf_function_names};
933
934    $self->feature( 'valid_comparison_operators', uc $func, 1 );
935    return $self->create_op_regexen();
936}
937
938sub DROP_OPERATOR
939{
940    my ( $self, $type ) = @_;
941    $self->{struct}->{command}    = 'DROP_OPERATOR';
942    $self->{struct}->{no_execute} = 1;
943    $self->feature( 'valid_comparison_operators', uc $type, 0 );
944    return $self->create_op_regexen();
945}
946
947sub replace_quoted($)
948{
949    my ( $self, $str ) = @_;
950    my @l = map { $self->replace_quoted_ids($_) } split( ',', $self->replace_quoted_commas($str) );
951    return @l;
952}
953
954#########
955# CREATE
956#########
957sub CREATE
958{
959    my ( $self, $stmt ) = @_;
960    my $features = 'TYPE|KEYWORD|FUNCTION|OPERATOR|PREDICATE';
961    if ( $stmt =~ m/^\s*CREATE\s+($features)\s+(.+)$/si )
962    {
963        my ( $sub, $arg ) = ( $1, $2 );
964        $sub = 'CREATE_' . uc $sub;
965        return $self->$sub($arg);
966    }
967
968    $stmt =~ s/^CREATE (LOCAL|GLOBAL) /CREATE /si;
969    if ( $stmt =~ m/^\s*CREATE\s+(?:TEMP|TEMPORARY)\s+TABLE\s+(.+)$/si )
970    {
971        $stmt = "CREATE TABLE $1";
972        $self->{struct}->{is_ram_table} = 1;
973    }
974    $self->{struct}->{command} = 'CREATE';
975    my ( $table_name, $table_element_def, %is_col_name );
976
977    if ( $stmt =~ m/^(.*) ON COMMIT (DELETE|PRESERVE) ROWS\s*$/si )
978    {
979        $stmt = $1;
980        $self->{struct}->{commit_behaviour} = $2;
981
982        #        return $self->do_err(
983        #           "Can't specify commit behaviour for permanent tables."
984        #        )
985        #           if !defined $self->{struct}->{table_type}
986        #              or $self->{struct}->{table_type} !~ /TEMPORARY/;
987    }
988    if ( $stmt =~ m/^CREATE TABLE (\S+) \((.*)\)$/si )
989    {
990        $table_name        = $1;
991        $table_element_def = $2;
992    }
993    elsif ( $stmt =~ m/^CREATE TABLE (\S+) AS (.*)$/si )
994    {
995        $table_name = $1;
996        my $subquery = $2;
997        return undef unless $self->TABLE_NAME($table_name);
998        $self->{struct}->{table_names} = [$table_name];
999
1000        # undo subquery replaces
1001        $subquery =~ s/\?(\d+)\?/'$self->{struct}{literals}[$1]'/g;
1002        $subquery =~ s/\?QI(\d+)\?/"$self->{struct}->{quoted_ids}->[$1]"/g;
1003        $subquery =~ s/\?COMMA\?/,/gs;
1004        $self->{struct}->{subquery} = $subquery;
1005        if ( -1 != index( $subquery, '?' ) )
1006        {
1007            ++$self->{struct}->{num_placeholders};
1008        }
1009        return 1;
1010    }
1011    else
1012    {
1013        return $self->do_err("Can't find column definitions!");
1014    }
1015    return undef unless ( $self->TABLE_NAME($table_name) );
1016    $table_element_def =~ s/\s+\(/(/g;
1017    my $primary_defined;
1018    while (
1019        $table_element_def =~ s/( # start of grouping 1
1020			   \( # match a bracket; vi compatible bracket -> \)(
1021                        [^)]+ # everything up to but not including the comma, no nesting of brackets is required
1022                            ) # end of grouping 1
1023                            , # the comma to be removed to allow splitting on commas
1024                            ( # start of grouping 2; vi compatible bracket -> \(
1025                        .*?\) # everything up to and including the end bracket
1026                            )/$1?COMMA?$2/sgx
1027      )
1028    {
1029    }
1030
1031    for my $col ( split( ',', $table_element_def ) )
1032    {
1033        if (
1034            $col =~ m/^\s*(?:CONSTRAINT\s+(\S+)\s*)? # optional name of foreign key
1035                               FOREIGN\s+KEY\s*\(\s* # start of list of; vi compatibile bracket -> (
1036                                       (\s*[^)]+\s*) # field names in this table
1037                                            \s*\)\s* # end of field names in this table
1038                                          REFERENCES # key word
1039                                         \s*(\S+)\s* # table name being referenced in foreign key
1040                                               \(\s* # start of list of; vi compatible bracket -> (
1041                                       (\s*[^)]+\s*) # field names in foreign table
1042                                            \s*\)\s* # end of field names in foreign table
1043                    $/x
1044          )
1045        {
1046            my ( $name, $local_cols, $referenced_table, $referenced_cols ) = ( $1, $2, $3, $4 );
1047            my @local_cols = $self->replace_quoted($local_cols);
1048            $referenced_table = $self->replace_quoted_ids($referenced_table);
1049            my @referenced_cols = $self->replace_quoted($referenced_cols);
1050
1051            if ( defined $name )
1052            {
1053                $name = $self->replace_quoted_ids($name);
1054            }
1055            else
1056            {
1057                $name = $self->replace_quoted_ids($table_name);
1058                my ($quote_char) = '';
1059                if ( $name =~ s/(\W)$// )
1060                {
1061                    $quote_char = ($1);
1062                }
1063                foreach my $local_col (@local_cols)
1064                {
1065                    my $col_name = $local_col;
1066                    $col_name =~ s/^\W//;
1067                    $col_name =~ s/\W$//;
1068                    $name .= '_' . $col_name;
1069                }
1070                $name .= '_fkey' . $quote_char;
1071            }
1072
1073            $self->{struct}->{table_defs}->{$name}->{type}             = 'FOREIGN';
1074            $self->{struct}->{table_defs}->{$name}->{local_cols}       = \@local_cols;
1075            $self->{struct}->{table_defs}->{$name}->{referenced_table} = $referenced_table;
1076            $self->{struct}->{table_defs}->{$name}->{referenced_cols}  = \@referenced_cols;
1077            next;
1078        }
1079        elsif (
1080            $col =~ m/^\s*(?:CONSTRAINT\s+(\S+)\s*)? # optional name of foreign key
1081                               PRIMARY\s+KEY\s*\(\s* # start of list of; vi compatibile bracket -> (
1082                                       (\s*[^)]+\s*) # field names in this table
1083                                            \s*\)\s* # end of field names in this table
1084                        $/x
1085          )
1086        {
1087            my ( $name, $local_cols ) = ( $1, $2 );
1088            my @local_cols = $self->replace_quoted($local_cols);
1089            if ( defined $name )
1090            {
1091                $name = $self->replace_quoted_ids($name);
1092            }
1093            else
1094            {
1095                $name = $table_name;
1096                if ( $name =~ s/(\W)$// )
1097                {
1098                    $name .= '_pkey' . $1;
1099                }
1100                else
1101                {
1102                    $name .= '_pkey';
1103                }
1104            }
1105            $self->{struct}->{table_defs}->{$name}->{type}       = 'PRIMARY';
1106            $self->{struct}->{table_defs}->{$name}->{local_cols} = \@local_cols;
1107            next;
1108        }
1109
1110        # it seems, perl 5.6 isn't greedy enough .. let's help a bit
1111        my ($data_types_regex) = join( '|', sort { length($b) <=> length($a) } keys %{ $self->{opts}->{valid_data_types} } );
1112        $data_types_regex =~ s/ /\\ /g;    # backslash spaces to allow the /x modifier below
1113        my ( $name, $type, $suffix ) = (
1114            $col =~ m/\s*(\S+)\s+                         # capture the column name
1115                        ((?:$data_types_regex|\S+)        # check for all allowed data types OR anything that looks like a bad data type to give a good error
1116                        (?:\s*\(\d+(?:\?COMMA\?\d+)?\))?) # allow the data type to have a precision specifier such as NUMERIC(4,6) on it
1117                        \s*(\W.*|$)                       # capture the suffix of the column definition, e.g. constraints
1118                     /ix
1119        );
1120        return $self->do_err("Column definition is missing a data type!") unless ($type);
1121        return undef unless ( $self->IDENTIFIER($name) );
1122
1123        $name = $self->replace_quoted_ids($name);
1124
1125        my @possible_constraints = ('PRIMARY KEY', 'NOT NULL', 'UNIQUE');
1126
1127        for my $constraint (@possible_constraints)
1128        {
1129            my $count = $suffix =~ s/$constraint//gi;
1130            next if $count == 0;
1131
1132            return $self->do_err(qq~Duplicate column constraint: '$constraint'!~)
1133                if $count > 1;
1134
1135            return $self->do_err(qq{Can't have two PRIMARY KEYs in a table!})
1136                if $constraint eq 'PRIMARY KEY' and $primary_defined++;
1137
1138            push @{ $self->{struct}->{table_defs}->{columns}->{$name}->{constraints} }, $constraint;
1139        }
1140
1141        $suffix =~ s/^\s+//;
1142        $suffix =~ s/\s+$//;
1143
1144        return $self->do_err("Unknown column constraint: '$suffix'!") unless ($suffix eq '');
1145
1146        $type = uc $type;
1147        my $length;
1148        if ( $type =~ m/(.+)\((.+)\)/ )
1149        {
1150            $type   = $1;
1151            $length = $2;
1152        }
1153        if ( !$self->{opts}->{valid_data_types}->{$type} )
1154        {
1155            return $self->do_err("'$type' is not a recognized data type!");
1156        }
1157        $self->{struct}->{table_defs}->{columns}->{$name}->{data_type}   = $type;
1158        $self->{struct}->{table_defs}->{columns}->{$name}->{data_length} = $length;
1159        push(
1160            @{ $self->{struct}->{column_defs} },
1161            {
1162                type    => 'column',
1163                value   => $name,
1164                fullorg => $name,
1165            }
1166        );
1167
1168        my $tmpname = $name;
1169        $tmpname = lc $tmpname unless ( $tmpname =~ m/^(?:\p{Word}+\.)?"/ );
1170        return $self->do_err("Duplicate column names!") if $is_col_name{$tmpname}++;
1171
1172    }
1173    $self->{struct}->{table_names} = [$table_name];
1174    return 1;
1175}
1176
1177###############
1178# SQL SUBRULES
1179###############
1180
1181sub SET_CLAUSE_LIST
1182{
1183    my ( $self, $set_string ) = @_;
1184    my @sets = extract_multiple($set_string, [
1185        sub { my ($m, $r, $p) = extract_bracketed($_[0], "()", qr/[^,(]*/); (($p||'').($m||''), $r, ''); },
1186        qr/([^,(]+)/,
1187      ], undef, 1);
1188    my ( @cols, @vals );
1189    for my $set (@sets)
1190    {
1191        my ( $col, $val ) = split( m/ = /, $set );
1192        return $self->do_err('Incomplete SET clause!') unless ( defined($col) && defined($val) );
1193        push( @cols, $col );
1194        push( @vals, $val );
1195    }
1196    return undef
1197      unless ( $self->{struct}->{column_defs} = $self->ROW_VALUE_LIST( join ',', @cols ) );
1198    return undef unless ( $self->LITERAL_LIST( join ',', @vals ) );
1199    return 1;
1200}
1201
1202sub SET_QUANTIFIER
1203{
1204    my ( $self, $str ) = @_;
1205    if ( $str =~ /^(DISTINCT|ALL)\s+(.*)$/si )
1206    {
1207        $self->{struct}->{set_quantifier} = uc $1;
1208        $str = $2;
1209    }
1210    return $str;
1211}
1212
1213#
1214#	DAA v1.11
1215#	modify to transform || strings into
1216#	CONCAT(<expr>); note that we
1217#	only xform the topmost expressions;
1218#	if a concat is contained within a subfunction,
1219#	it should get handled by ROW_VALUE()
1220#
1221sub transform_concat
1222{
1223    my ( $obj, $colstr ) = @_;
1224
1225    pos($colstr) = 0;
1226    my $parens  = 0;
1227    my $spos    = 0;
1228    my @concats = ();
1229    my $alias   = ( $colstr =~ s/^(.+)(\s+AS\s+\S+)$/$1/ ) ? $2 : '';
1230
1231    while ( $colstr =~ /\G.*?([\(\)\|])/gcs )
1232    {
1233        if ( $1 eq '(' )
1234        {
1235            $parens++;
1236        }
1237        elsif ( $1 eq ')' )
1238        {
1239            $parens--;
1240        }
1241        elsif (( !$parens )
1242            && ( substr( $colstr, $-[1] + 1, 1 ) eq '|' ) )
1243        {
1244
1245            #
1246            # its a concat outside of parens, push prior string on stack
1247            #
1248            push @concats, substr( $colstr, $spos, $-[1] - $spos );
1249            $spos = $+[1] + 1;
1250            pos($colstr) = $spos;
1251        }
1252    }
1253
1254    #
1255    #	no concats, return original
1256    #
1257    return $colstr unless scalar @concats;
1258
1259    #
1260    #	don't forget the last one!
1261    #
1262    push @concats, substr( $colstr, $spos );
1263    return 'CONCAT(' . join( ', ', @concats ) . ")$alias";
1264}
1265
1266#
1267#	DAA v1.10
1268#	improved column list extraction
1269#	original doesn't seem to handle
1270#	commas within function argument lists
1271#
1272#	DAA v1.11
1273#	modify to transform || strings into
1274#	CONCAT(<expr-list>)
1275#
1276sub extract_column_list
1277{
1278    my ( $self, $colstr ) = @_;
1279
1280    my @collist = ();
1281    pos($colstr) = 0;
1282    my $parens = 0;
1283    my $spos   = 0;
1284    while ( $colstr =~ m/\G.*?([\(\),])/gcs )
1285    {
1286        if ( $1 eq '(' )
1287        {
1288            $parens++;
1289        }
1290        elsif ( $1 eq ')' )
1291        {
1292            $parens--;
1293        }
1294        elsif ( !$parens )
1295        {    # its a comma outside of parens
1296            push( @collist, substr( $colstr, $spos, $-[1] - $spos ) );
1297            $collist[-1] =~ s/^\s+//;
1298            $collist[-1] =~ s/\s+$//;
1299            return $self->do_err('Bad column list!') if ( $collist[-1] eq '' );
1300            $spos = $+[1];
1301        }
1302    }
1303    return $self->do_err('Unbalanced parentheses!') if ($parens);
1304
1305    # don't forget the last one!
1306    push( @collist, substr( $colstr, $spos ) );
1307    $collist[-1] =~ s/^\s+//;
1308    $collist[-1] =~ s/\s+$//;
1309    return $self->do_err('Bad column list!') if ( $collist[-1] eq '' );
1310
1311    # scan for and convert string concats to CONCAT()
1312    foreach ( 0 .. $#collist )
1313    {
1314        $collist[$_] = $self->transform_concat( $collist[$_] ) if ( $collist[$_] =~ m/\|\|/ );
1315    }
1316
1317    return @collist;
1318}
1319
1320sub SELECT_LIST
1321{
1322    my ( $self, $col_str ) = @_;
1323    if ( $col_str =~ m/^\s*\*\s*$/ )
1324    {
1325        $self->{struct}->{column_defs} = [
1326            {
1327                type  => 'column',
1328                value => '*'
1329            }
1330        ];
1331        $self->{struct}->{column_aliases} = {};
1332
1333        return 1;
1334    }
1335    my @col_list = $self->extract_column_list($col_str);
1336    return undef unless ( scalar(@col_list) );
1337
1338    my ( @newcols, %aliases );
1339    for my $col (@col_list)
1340    {
1341        # DAA:
1342        # need better alias test here, since AS is a common
1343        # keyword that might be used in a function
1344        my ( $fld, $alias ) =
1345            ( $col =~ m/^(.+?)\s+(?:AS\s+)?([A-Z]\p{Word}*|\?QI\d+\?)$/i )
1346          ? ( $1, $2 )
1347          : ( $col, undef );
1348        $col = $fld;
1349        if ( $col =~ m/^(\S+)\.\*$/ )
1350        {
1351            my $table = $1;
1352            if ( defined($alias) )
1353            {
1354                return $self->do_err("'$table.*' cannot be aliased");
1355            }
1356            $table = $self->{tmp}->{is_table_alias}->{$table}
1357              if ( $self->{tmp}->{is_table_alias}->{$table} );
1358            $table = $self->{tmp}->{is_table_alias}->{"\L$table"}
1359              if ( $self->{tmp}->{is_table_alias}->{"\L$table"} );
1360            return undef unless ( $self->TABLE_NAME($table) );
1361            $table = $self->replace_quoted_ids($table);
1362            push(
1363                @newcols,
1364                {
1365                    type  => 'column',
1366                    value => "$table.*",
1367                }
1368            );
1369        }
1370        else
1371        {
1372            my $newcol;
1373            $newcol = $self->SET_FUNCTION_SPEC($col);
1374            return if ( $self->{struct}->{errstr} );
1375            $newcol ||= $self->ROW_VALUE($col);
1376            return if ( $self->{struct}->{errstr} );
1377            return $self->do_err("Invalid SELECT entry '$col'")
1378              unless ( defined( _HASH($newcol) ) );
1379
1380            # FIXME this might be better done later and only if not 2 functions with the same name are selected
1381            if ( !defined($alias)
1382                && ( ( 'function' eq $newcol->{type} ) || ( 'setfunc' eq $newcol->{type} ) ) )
1383            {
1384                $alias = $newcol->{name};
1385            }
1386
1387            if ( defined($alias) )
1388            {
1389                $alias                                              = $self->replace_quoted_ids($alias);
1390                $newcol->{alias}                                    = $alias;
1391                $aliases{ $newcol->{fullorg} }                      = $alias;
1392                $self->{struct}->{ORG_NAME}->{ $newcol->{fullorg} } = $alias;
1393                $self->{struct}->{ALIASES}->{$alias}                = $newcol->{fullorg};
1394            }
1395            push( @newcols, $newcol );
1396        }
1397    }
1398    $self->{struct}->{column_aliases} = \%aliases;
1399    $self->{struct}->{column_defs}    = \@newcols;
1400    return 1;
1401}
1402
1403sub SET_FUNCTION_SPEC
1404{
1405    my ( $self, $col_str ) = @_;
1406
1407    if ( $col_str =~ m/^(COUNT|AVG|SUM|MAX|MIN) \((.*)\)\s*$/i )
1408    {
1409        my $set_function_name    = uc $1;
1410        my $set_function_arg_str = $2;
1411        my $distinct             = 'ALL';
1412        if ( $set_function_arg_str =~ s/(DISTINCT|ALL) (.+)$/$2/i )
1413        {
1414            $distinct = uc $1;
1415        }
1416        my $count_star = ( $set_function_name eq 'COUNT' ) && ( $set_function_arg_str eq '*' );
1417
1418        my $set_function_arg;
1419        if ($count_star)
1420        {
1421            return $self->do_err("Keyword DISTINCT is not allowed for COUNT(*)")
1422              if ( 'DISTINCT' eq $distinct );
1423            $set_function_arg = {
1424                type  => 'column',
1425                value => '*'
1426            };
1427        }
1428        else
1429        {
1430            $set_function_arg = $self->ROW_VALUE($set_function_arg_str);
1431            return if ( $self->{struct}->{errstr} );
1432            return unless ( defined( _HASH($set_function_arg) ) );
1433        }
1434
1435        $self->{struct}->{has_set_functions} = 1;
1436
1437        my $value = {
1438            name     => $set_function_name,
1439            arg      => $set_function_arg,
1440            argstr   => lc($set_function_arg_str),
1441            distinct => $distinct,
1442            type     => 'setfunc',
1443            fullorg  => $col_str,
1444        };
1445        return $value;
1446    }
1447    else
1448    {
1449        return undef;
1450    }
1451}
1452
1453sub LIMIT_CLAUSE
1454{
1455    my ( $self, $limit_clause ) = @_;
1456
1457    #    $limit_clause = trim($limit_clause);
1458    $limit_clause =~ s/^\s+//;
1459    $limit_clause =~ s/\s+$//;
1460
1461    return 1 if !$limit_clause;
1462    my $offset;
1463    my $limit;
1464    my $junk;
1465($offset, $limit, $junk ) = split /,|OFFSET/i, $limit_clause;
1466    if ($limit_clause =~ m/(\d+)\s+OFFSET\s+(\d+)/) {
1467	$limit = $1;
1468	$offset = $2;
1469    } else {
1470	( $offset, $limit, $junk ) = split /,/i, $limit_clause;
1471    }
1472    return $self->do_err('Bad limit clause!:'.$limit_clause)
1473      if ( defined $limit and $limit =~ /[^\d]/ )
1474      or ( defined $offset and $offset =~ /[^\d]/ )
1475      or defined $junk;
1476    if ( defined $offset and !defined $limit )
1477    {
1478        $limit = $offset;
1479        undef $offset;
1480    }
1481    $self->{struct}->{limit_clause} = {
1482        limit  => $limit,
1483        offset => $offset,
1484    };
1485    return 1;
1486}
1487
1488sub SORT_SPEC_LIST
1489{
1490    my ( $self, $order_clause ) = @_;
1491    return 1 if !$order_clause;
1492    my @ocols;
1493    my @order_columns = split ',', $order_clause;
1494    for my $col (@order_columns)
1495    {
1496        my $newcol;
1497        my $newarg;
1498        if ( $col =~ /\s*(\S+)\s+(ASC|DESC)/si )
1499        {
1500            $newcol = $1;
1501            $newarg = uc $2;
1502        }
1503        elsif ( $col =~ /^\s*(\S+)\s*$/si )
1504        {
1505            $newcol = $1;
1506            $newarg = 'ASC';
1507        }
1508        else
1509        {
1510            return $self->do_err('Junk after column name in ORDER BY clause!');
1511        }
1512        $newcol = $self->COLUMN_NAME($newcol) or return;
1513        if ( $newcol =~ /^(.+)\..+$/s )
1514        {
1515            my $table = $1;
1516            $self->_verify_tablename( $table, "ORDER BY" );
1517        }
1518        push( @ocols, { $newcol => $newarg } );
1519    }
1520    $self->{struct}->{sort_spec_list} = \@ocols;
1521    return 1;
1522}
1523
1524sub SEARCH_CONDITION
1525{
1526    my ( $self, $str ) = @_;
1527    $str =~ s/^\s*WHERE (.+)/$1/;
1528    $str =~ s/^\s+//;
1529    $str =~ s/\s+$//;
1530    return $self->do_err("Couldn't find WHERE clause!") unless $str;
1531
1532    #
1533    #	DAA
1534    #	make these OO so subclasses can override them
1535    #
1536    $str = $self->repl_btwin($str);
1537
1538    #
1539    #	DAA
1540    #	add another abstract method so subclasses
1541    #	can inject their own syntax transforms
1542    #
1543    $str = $self->transform_syntax($str);
1544
1545    my $open_parens  = $str =~ tr/\(//;
1546    my $close_parens = $str =~ tr/\)//;
1547    if ( $open_parens != $close_parens )
1548    {
1549        return $self->do_err("Mismatched parentheses in WHERE clause!");
1550    }
1551    $str = nongroup_numeric( $self->nongroup_string($str) );
1552    my $pred =
1553        $open_parens
1554      ? $self->parens_search( $str, [] )
1555      : $self->non_parens_search( $str, [] );
1556    return $self->do_err("Couldn't find predicate!") unless $pred;
1557    $self->{struct}->{where_clause} = $pred;
1558    return 1;
1559}
1560
1561############################################################
1562# UTILITY FUNCTIONS CALLED TO PARSE PARENS IN WHERE CLAUSE
1563############################################################
1564
1565sub repl_btwin
1566{
1567    my ( $self, $str ) = @_;    # DAA make OO for subclassing
1568    my @lids;
1569
1570    my $i = -1;
1571    while ( $str =~ m/\G.*(?:IN|BETWEEN)\s+\(/g )
1572    {
1573        my $start   = pos($str) - 1;
1574        my $lparens = 1;
1575        my $rparens = 0;
1576        while ( $str =~ m/\G.*?([\(\)])/gcs )
1577        {
1578            ++$lparens if ( '(' eq $1 );
1579            ++$rparens if ( ')' eq $1 );
1580            last       if ( $lparens == $rparens );
1581        }
1582        my $now = pos($str);
1583        ++$i;
1584        my $subst = "?LI$i?";
1585        my $term = substr( $str, $start, $now - $start, $subst );
1586        $term = substr( $term, 1, length($term) - 2 );
1587        push( @lids, $term );
1588        pos($str) = $start + length($subst);
1589    }
1590
1591    $self->{struct}->{list_ids} = \@lids;
1592    return $str;
1593}
1594
1595# groups clauses by nested parens
1596#
1597#	DAA
1598#	rewrite to correct paren scan
1599#	and optimize code, and remove
1600#	recursion
1601#
1602sub parens_search
1603{
1604    my ( $self, $str, $predicates ) = @_;
1605    my $index = scalar( @{$predicates} );
1606
1607    # to handle WHERE (a=b) AND (c=d)
1608    # but needs escape space to not foul up AND/OR
1609
1610    #	locate all open parens
1611    #	locate all close parens
1612    #	apply non_paren_search to contents of
1613    #	inner parens
1614
1615    my $lparens = ( $str =~ tr/\(// );
1616    my $rparens = ( $str =~ tr/\)// );
1617    return $self->do_err( 'Unmatched ' . ( ( $lparens > $rparens ) ? 'left' : 'right' ) . " parentheses in '$str'!" )
1618      unless ( $lparens == $rparens );
1619
1620    return $self->non_parens_search( $str, $predicates )
1621      unless $lparens;
1622
1623    my @lparens = ();
1624    while ( $str =~ m/\G.*?([\(\)])/gcs )
1625    {
1626        push( @lparens, $-[1] ), next
1627          if ( $1 eq '(' );
1628
1629        #
1630        #	got a close paren, so pop the position of matching
1631        #	left paren and extract the expression, removing the
1632        #	parens
1633        #
1634        my $pos     = pop @lparens;
1635        my $predlen = $+[1] - $pos;
1636        my $pred    = substr( $str, $pos + 1, $predlen - 2 );
1637
1638        #
1639        #	note that this will pass thru any prior ^$index^ xlation,
1640        #	so we don't need to recurse to recover the predicate
1641        #
1642        substr( $str, $pos, $predlen ) = $pred, pos($str) = $pos + length($pred), next
1643          unless ( $pred =~ / (AND|OR) /i );
1644
1645        #
1646        #	handle AND/OR
1647        #
1648        push( @$predicates, substr( $str, $pos + 1, $predlen - 2 ) );
1649        my $replacement = "^$#$predicates^";
1650        substr( $str, $pos, $predlen ) = $replacement;
1651        pos($str) = $pos + length($replacement);
1652    }
1653
1654    return $self->non_parens_search( $str, $predicates );
1655}
1656
1657# creates predicates from clauses that either have no parens
1658# or ANDs or have been previously grouped by parens and ANDs
1659#
1660#	DAA
1661#	rewrite to fix paren scanning
1662#
1663sub non_parens_search
1664{
1665    my ( $self, $str, $predicates ) = @_;
1666    my $neg  = 0;
1667    my $nots = {};
1668
1669    $neg = 1, $nots = { pred => 1 }
1670      if ( $str =~ s/^NOT (\^.+)$/$1/i );
1671
1672    my ( $pred1, $pred2, $op );
1673    my $and_preds = [];
1674    ( $str, $and_preds ) = group_ands($str);
1675    $str = $and_preds->[$1]
1676      if $str =~ /^\s*~(\d+)~\s*$/;
1677
1678    return $self->non_parens_search( $$predicates[$1], $predicates )
1679      if ( $str =~ /^\s*\^(\d+)\^\s*$/ );
1680
1681    if ( $str =~ /\G(.*?)\s+(AND|OR)\s+(.*)$/igcs )
1682    {
1683        ( $pred1, $op, $pred2 ) = ( $1, $2, $3 );
1684
1685        if ( $pred1 =~ /^\s*\^(\d+)\^\s*$/ )
1686        {
1687            $pred1 = $self->non_parens_search( $$predicates[$1], $predicates );
1688        }
1689        else
1690        {
1691            $pred1 =~ s/\~(\d+)\~$/$and_preds->[$1]/g;
1692            $pred1 = $self->non_parens_search( $pred1, $predicates );
1693        }
1694
1695        #
1696        #	handle pred2 as a full predicate
1697        #
1698        $pred2 =~ s/\~(\d+)\~$/$and_preds->[$1]/g;
1699        $pred2 = $self->non_parens_search( $pred2, $predicates );
1700
1701        return {
1702            neg  => $neg,
1703            nots => $nots,
1704            arg1 => $pred1,
1705            op   => uc $op,
1706            arg2 => $pred2,
1707        };
1708    }
1709
1710    #
1711    #	terminal predicate
1712    #	need to check for singleton functions here
1713    #
1714    my $xstr = $str;
1715    my ( $k, $v );
1716    if ( $str =~ /^\s*([A-Z]\p{Word}*)\s*\[/gcs )
1717    {
1718
1719        #
1720        #	we've got a function, check if its a singleton
1721        #
1722        my $parens = 1;
1723        my $spos   = $-[1];
1724        my $epos   = 0;
1725        $epos = $-[1], $parens += ( $1 eq '[' ) ? 1 : -1 while ( ( $parens > 0 ) && ( $str =~ /\G.*?([\[\]])/gcs ) );
1726        $k = substr( $str, $spos, $epos - $spos + 1 );
1727        $k =~ s/\?(\d+)\?/$self->{struct}{literals}[$1]/g;
1728
1729        #
1730        #	for now we assume our parens are balanced
1731        #	now look for a predicate operator and a right operand
1732        #
1733        $v = $1, $v =~ s/\?(\d+)\?/$self->{struct}{literals}[$1]/g
1734          if ( $str =~ /\G\s+\S+\s*(.+)\s*$/gcs );
1735    }
1736    else
1737    {
1738        $xstr =~ s/\?(\d+)\?/$self->{struct}{literals}[$1]/g;
1739        ( $k, $v ) = $xstr =~ /^(\S+?)\s+\S+\s*(.+)\s*$/;
1740    }
1741    push @{ $self->{struct}{where_cols}{$k} }, $v
1742      if defined $k;
1743    return $self->PREDICATE($str);
1744}
1745
1746# groups AND clauses that aren't already grouped by parens
1747#
1748sub group_ands
1749{
1750    my $str = shift;
1751    my $and_preds = shift || [];
1752    return ( $str, $and_preds )
1753      unless $str =~ / AND / and $str =~ / OR /;
1754
1755    return $str, $and_preds
1756      unless ( $str =~ /^(.*?) AND (.*)$/i );
1757
1758    my ( $front, $back ) = ( $1, $2 );
1759    my $index = scalar @$and_preds;
1760    $front = $1
1761      if ( $front =~ /^.* OR (.*)$/i );
1762
1763    $back = $1
1764      if ( $back =~ /^(.*?) (OR|AND) .*$/i );
1765
1766    my $newpred = "$front AND $back";
1767    push @$and_preds, $newpred;
1768    $str =~ s/\Q$newpred/~$index~/i;
1769    return group_ands( $str, $and_preds );
1770}
1771
1772# replaces string function parens with square brackets
1773# e.g TRIM (foo) -> TRIM[foo]
1774#
1775#	DAA update to support UDFs
1776#	and remove recursion
1777#
1778sub nongroup_string
1779{
1780    my ( $self, $str ) = @_;
1781
1782    #
1783    #	add in any user defined functions
1784    #
1785    my $f = join( '|', FUNCTION_NAMES, $self->_udf_function_names );
1786
1787    #
1788    #	we need a scan here to permit arbitrarily nested paren
1789    #	arguments to functions
1790    #
1791    my $parens = 0;
1792    my $pos;
1793    my @lparens = ();
1794    while ( $str =~ /\G.*?((\b($f)\s*\()|[\(\)])/igcs )
1795    {
1796        if ( $1 eq ')' )
1797        {
1798            #
1799            #	close paren, see if any pending function open
1800            #	paren matches it
1801            #
1802            --$parens;
1803            $pos = $+[0], substr( $str, $+[0] - 1, 1 ) = ']', pos($str) = $pos, pop(@lparens)
1804              if ( @lparens && ( $lparens[-1] == $parens ) );
1805        }
1806        elsif ( $1 eq '(' )
1807        {
1808
1809            #
1810            #	just an open paren, count it and go on
1811            #
1812            ++$parens;
1813        }
1814        else
1815        {
1816
1817            #
1818            #	new function definition, capture its open paren
1819            #	also uppercase the function name
1820            #
1821            $pos = $+[0];
1822            substr( $str, $-[3], length($3) ) = uc $3;
1823            substr( $str, $+[0] - 1, 1 ) = '[';
1824            pos($str) = $pos;
1825            push @lparens, $parens;
1826            ++$parens;
1827        }
1828    }
1829
1830    #	return $self->do_err('Unmatched ' .
1831    #		(($parens > 0) ? 'left' : 'right') . ' parentheses!')
1832    #		if $parens;
1833    #
1834    #	DAA
1835    #	remove scoped recursion
1836    #
1837    #	return ( $str =~ /($f)\s*\(/i ) ?
1838    #		nongroup_string($str) : $str;
1839    return $str;
1840}
1841
1842# replaces math parens with square brackets
1843# e.g (4-(6+7)*9) -> MATH[4-MATH[6+7]*9]
1844#
1845sub nongroup_numeric
1846{
1847    my $str = $_[0];
1848    my $has_op;
1849
1850    #
1851    #	DAA
1852    #	optimize regex
1853    #
1854    if ( $str =~ m/\(([\p{Word} \*\/\+\-\[\]\?]+)\)/ )
1855    {
1856        my $match = $1;
1857        if ( $match !~ m/(LIKE |IS|BETWEEN|IN)/i )
1858        {
1859            my $re = quotemeta($match);
1860            $str =~ s/\($re\)/MATH\[$match\]/;
1861        }
1862        else
1863        {
1864            $has_op++;
1865        }
1866    }
1867
1868    #
1869    #	DAA
1870    #	remove scoped recursion
1871    #
1872    return ( !$has_op and $str =~ /\(([\p{Word} \*\/\+\-\[\]\?]+)\)/ )
1873      ? nongroup_numeric($str)
1874      : $str;
1875}
1876############################################################
1877
1878#########################################################
1879# LITERAL_LIST ::= <literal> [,<literal>]
1880#########################################################
1881sub LITERAL_LIST
1882{
1883    my ( $self, $str ) = @_;
1884    my @tokens = extract_multiple($str, [
1885        sub { my ($m, $r, $p) = extract_bracketed($_[0], "()", qr/[^,(]*/); (($p||'').($m||''), $r, ''); },
1886        qr/([^,(]+)/,
1887      ], undef, 1);
1888    my @values;
1889    for my $tok (@tokens)
1890    {
1891        my $val = $self->ROW_VALUE($tok);
1892        return $self->do_err(qq('$tok' is not a valid value or is not quoted!))
1893          unless $val;
1894        push @values, $val;
1895    }
1896    push( @{ $self->{struct}->{values} }, \@values );
1897    return 1;
1898}
1899
1900#############################################################################
1901# LITERAL ::= <quoted_string> | <question mark> | <number> | NULL/TRUE/FALSE
1902#############################################################################
1903sub LITERAL
1904{
1905    my ( $self, $str ) = @_;
1906
1907    #
1908    #	DAA
1909    #	strip parens (if any)
1910    #
1911    $str = $1 while ( $str =~ m/^\s*\(\s*(.+)\s*\)\s*$/ );
1912
1913    return 'null'    if $str =~ m/^NULL$/i;              # NULL
1914    return 'boolean' if $str =~ m/^(?:TRUE|FALSE)$/i;    # TRUE/FALSE
1915
1916    #    return 'empty_string' if $str =~ /^~E~$/i;    # NULL
1917    if ( $str eq '?' )
1918    {
1919        $self->{struct}->{num_placeholders}++;
1920        return 'placeholder';
1921    }
1922
1923    #    return 'placeholder' if $str eq '?';   # placeholder question mark
1924    return 'string' if $str =~ m/^'.*'$/s;               # quoted string
1925         # return 'number' if $str =~ m/^[+-]?(?=\d|\.\d)\d*(\.\d*)?([Ee]([+-]?\d+))?$/; # number
1926    return 'number' if ( looks_like_number($str) );    # number
1927
1928    return undef;
1929}
1930###################################################################
1931# PREDICATE
1932###################################################################
1933sub PREDICATE
1934{
1935    my ( $self, $str ) = @_;
1936
1937    my ( $arg1, $op, $arg2, $opexp );
1938
1939    $opexp = $self->{opts}{valid_comparison_NOT_ops_regex}, ( $arg1, $op, $arg2 ) = $str =~ /$opexp/i
1940      if $self->{opts}{valid_comparison_NOT_ops_regex};
1941
1942    $opexp = $self->{opts}{valid_comparison_twochar_ops_regex}, ( $arg1, $op, $arg2 ) = $str =~ /$opexp/i
1943      if ( !defined($op)
1944        && $self->{opts}{valid_comparison_twochar_ops_regex} );
1945
1946    $opexp = $self->{opts}{valid_comparison_ops_regex}, ( $arg1, $op, $arg2 ) = $str =~ /$opexp/i
1947      if ( !defined($op) && $self->{opts}{valid_comparison_ops_regex} );
1948
1949    #
1950    ### USER-DEFINED PREDICATE
1951    #
1952    unless ( defined $arg1 && defined $op && defined $arg2 )
1953    {
1954        $arg1 = $str;
1955        $op   = 'USER_DEFINED';
1956        $arg2 = '';
1957    }
1958
1959    $op = uc $op;
1960
1961    #	my $uname = $self->is_func($arg1);
1962    #        if (!$uname) {
1963    #           $arg1 =~ s/^(\S+).*$/$1/;
1964    #	    return $self->do_err("Bad predicate: '$arg1'!");
1965    #        }
1966
1967    my $negated = 0;    # boolean value showing if predicate is negated
1968    my %not;            # hash showing elements modified by NOT
1969                        #
1970                        # e.g. "NOT bar = foo"        -> %not = (arg1=>1)
1971                        #      "bar NOT LIKE foo"     -> %not = (op=>1)
1972                        #      "NOT bar NOT LIKE foo" -> %not = (arg1=>1,op=>1);
1973                        #      "NOT bar IS NOT NULL"  -> %not = (arg1=>1,op=>1);
1974                        #      "bar = foo"            -> %not = undef;
1975                        #
1976    $not{arg1}++
1977      if ( $arg1 =~ s/^NOT (.+)$/$1/i );
1978
1979    $not{op}++
1980      if ( $op =~ s/^(.+) NOT$/$1/i
1981        || $op =~ s/^NOT (.+)$/$1/i );
1982
1983    $negated = 1 if %not and scalar keys %not == 1;
1984
1985    return undef unless $arg1 = $self->ROW_VALUE($arg1);
1986
1987    if ( $op ne 'USER_DEFINED' )
1988    {    # USER-PREDICATE;
1989        return undef unless $arg2 = $self->ROW_VALUE($arg2);
1990    }
1991    else
1992    {
1993
1994        #        $arg2 = $self->ROW_VALUE($arg2);
1995    }
1996
1997    if (    defined( _HASH($arg1) )
1998        and defined( _HASH($arg2) )
1999        and ( ( $arg1->{type} || '' ) eq 'column' )
2000        and ( ( $arg2->{type} || '' ) eq 'column' )
2001        and ( $op eq '=' ) )
2002    {
2003        push( @{ $self->{struct}->{keycols} }, $arg1->{value} );
2004        push( @{ $self->{struct}->{keycols} }, $arg2->{value} );
2005    }
2006
2007    return {
2008        neg  => $negated,
2009        nots => \%not,
2010        arg1 => $arg1,
2011        op   => $op,
2012        arg2 => $arg2,
2013    };
2014}
2015
2016sub _udf_function_names
2017{
2018    $_[0]->{opts}->{_udf_function_names}
2019      or return $_[0]->{opts}->{_udf_function_names} = join( "|", map { uc $_ } keys %{ $_[0]->{opts}->{function_names} } );
2020    $_[0]->{opts}->{_udf_function_names};
2021}
2022
2023sub undo_string_funcs
2024{
2025    my ( $self, $str ) = @_;
2026    my $f = join( '|', FUNCTION_NAMES, $self->_udf_function_names );
2027
2028    #	eliminate recursion:
2029    #	we have to scan for closing brackets, since we may
2030    #	have intervening MATH elements with brackets
2031    my ( $brackets, $pos, @lbrackets ) = (0);
2032    while ( $str =~ /\G.*?((\b($f)\s*\[)|[\[\]])/igcs )
2033    {
2034        if ( $1 eq ']' )
2035        {
2036            #	close paren, see if any pending function open
2037            #	paren matches it
2038            $brackets--;
2039            $pos = $+[0], substr( $str, $+[0] - 1, 1 ) = ')', pos($str) = $pos, pop @lbrackets
2040              if ( @lbrackets && ( $lbrackets[-1] == $brackets ) );
2041        }
2042        elsif ( $1 eq '[' )
2043        {
2044            #	just an open paren, count it and go on
2045            $brackets++;
2046        }
2047        else
2048        {
2049            #	new function definition, capture its open paren
2050            #	also uppercase the function name
2051            $pos = $+[0];
2052            substr( $str, $-[3], length($3) ) = uc $3;
2053            substr( $str, $+[0] - 1, 1 ) = '(';
2054            pos($str) = $pos;
2055            push @lbrackets, $brackets;
2056            $brackets++;
2057        }
2058    }
2059
2060    return $str;
2061}
2062
2063sub undo_math_funcs
2064{
2065    my $str = $_[0];
2066
2067    #	eliminate recursion
2068    while ( $str =~ s/MATH\[([^\]\[]+?)\]/($1)/ )
2069    {
2070    }
2071
2072    return $str;
2073}
2074
2075#
2076#	DAA
2077#	need better nested function/parens handling
2078#
2079sub extract_func_args
2080{
2081    my ( $self, $value ) = @_;
2082
2083    my @final_args = ();
2084    my ( $spos, $parens, $epos, $delim ) = ( 0, 0, 0, 0 );
2085    while ( $value =~ m/\G.*?([\(\),])/gcs )
2086    {
2087        $epos  = $+[0];
2088        $delim = $1;
2089        unless ( $parens or ( $delim ne ',' ) )
2090        {
2091            push( @final_args, $self->ROW_VALUE( substr( $value, $spos, $epos - $spos - 1 ) ) );
2092            $spos = $epos;
2093            next;
2094        }
2095
2096        unless ( $delim eq ',' )
2097        {
2098            $parens += ( $delim eq '(' ) ? 1 : -1;
2099        }
2100    }
2101
2102    #	don't forget the last argument
2103    if ( $spos != length($value) )
2104    {
2105        $epos = length($value);
2106        push( @final_args, $self->ROW_VALUE( substr( $value, $spos, $epos - $spos ) ) );    # XXX
2107    }
2108
2109    return @final_args;
2110}
2111
2112###################################################################
2113# ROW_VALUE ::= <literal> | <column_name>
2114###################################################################
2115sub ROW_VALUE
2116{
2117    my ( $self, $str ) = @_;
2118
2119    $str =~ s/^\s+//;
2120    $str =~ s/\s+$//;
2121    $str = $self->undo_string_funcs($str);
2122    $str = undo_math_funcs($str);
2123    my ( $orgstr, $f, $bf ) = ( $str, FUNCTION_NAMES, BAREWORD_FUNCTIONS );
2124
2125    # USER-DEFINED FUNCTION
2126    my ( $user_func_name, $user_func_args, $is_func );
2127
2128    #	DAA
2129    #	need better paren check here
2130    if ( $str =~ m/^([^\s\(]+)\s*(.*)\s*$/ )
2131    {
2132        $user_func_name = $1;
2133        $user_func_args = $2;
2134
2135        # convert operator-like function to parenthetical format
2136        if (   ( $is_func = $self->is_func($user_func_name) )
2137            && ( $user_func_args !~ m/^\(.*\)$/ )
2138            && ( $is_func =~ /^(?:$bf)$/i ) )
2139        {
2140            $orgstr = $str = "$user_func_name ($user_func_args)";
2141        }
2142    }
2143    else
2144    {
2145        $user_func_name = $str;
2146        $user_func_name =~ s/^(\S+).*$/$1/;
2147        $user_func_args = '';
2148        $is_func        = $self->is_func($user_func_name);
2149    }
2150
2151    # BLKB
2152    # Limiting the parens convert shortcut, so that "SELECT LOG(1), PI" works as a
2153    # two functions, and "SELECT x FROM log" works as a table
2154    undef $is_func if ( $is_func && $is_func !~ /^(?:$bf)$/i && $str !~ m/^\S+\s*\(.*\)\s*$/ );
2155
2156    if ( $is_func && ( uc($is_func) !~ m/^($f)$/ ) )
2157    {
2158        my ( $name, $value ) = ( $user_func_name, '' );
2159        if ( $str =~ m/^(\S+)\s*\((.*)\)\s*$/ )
2160        {
2161            $name    = $1;
2162            $value   = $2;
2163            $is_func = $self->is_func($name);
2164        }
2165
2166        if ($is_func)
2167        {
2168            #
2169            #	DAA
2170            #	need a better argument extractor, since it can
2171            #	contain arbitrary (possibly parenthesized)
2172            #	expressions/functions
2173            #
2174            #           if ($value =~ /\(/ ) {
2175            #               $value = $self->ROW_VALUE($value);
2176            #           }
2177            #           my @args = split ',',$value;
2178
2179            my @final_args = $self->extract_func_args($value);
2180            my $usr_sub    = $self->{opts}->{function_names}->{$is_func};
2181            $self->{struct}->{procedure} = {};
2182            if ($usr_sub)
2183            {
2184                $value = {
2185                    type    => 'function',
2186                    name    => lc $name,
2187                    subname => $usr_sub,
2188                    value   => \@final_args,
2189                    fullorg => $orgstr,
2190                };
2191
2192                return $value;
2193            }
2194        }
2195    }
2196
2197    my $type;
2198    # MATH
2199    #
2200    if ( $str =~ m/[\*\+\-\/\%]/ )
2201    {
2202        my @vals;
2203        my $i            = -1;
2204        my $open_parens  = $str =~ tr/\(//;
2205        my $close_parens = $str =~ tr/\)//;
2206        if ( $open_parens != $close_parens )
2207        {
2208            return $self->do_err("Mismatched parentheses in term '$str'!");
2209        }
2210
2211        # $str =~ s/([^\s\*\+\-\/\%\)\(]+)/push @vals,$1;++$i;"?$i?"/ge;
2212        while ( $str =~ m/\G.*?([^\s\*\+\-\/\%\)\(]+)/g )
2213        {
2214            my $term  = $1;
2215            my $start = pos($str) - length($term);
2216            if ( $self->is_func($term) )
2217            {
2218                my $lparens = 0;
2219                my $rparens = 0;
2220                while ( $str =~ m/\G.*?([\(\)])/gcs )
2221                {
2222                    ++$lparens if ( '(' eq $1 );
2223                    ++$rparens if ( ')' eq $1 );
2224                    last       if ( $lparens == $rparens );
2225                }
2226                my $now = pos($str);
2227                ++$i;
2228                $term = substr( $str, $start, $now - $start, "?$i?" );
2229                push( @vals, $term );
2230                pos($str) = $start + length("?$i?");
2231            }
2232            else
2233            {
2234                push( @vals, $term );
2235                ++$i;
2236                substr( $str, $start, length($term), "?$i?" );
2237                pos($str) = $start + length("?$i?");
2238            }
2239        }
2240
2241        my @newvalues;
2242        foreach my $val (@vals)
2243        {
2244            my $newval = $self->ROW_VALUE($val);
2245            if ( $newval && $newval->{type} !~ m/number|column|placeholder|function/ )
2246            {
2247                return $self->do_err(qq[String '$val' not allowed in Numeric expression!]);
2248            }
2249            push( @newvalues, $newval );
2250        }
2251
2252        return {
2253            type    => 'function',
2254            name    => 'numeric_exp',
2255            str     => $str,
2256            value   => \@newvalues,
2257            fullorg => $orgstr,
2258        };
2259    }
2260
2261    # SUBSTRING (value FROM start [FOR length])
2262    #
2263    if ( $str =~ m/^SUBSTRING \((.+?) FROM (.+)\)\s*$/i )
2264    {
2265        my $name  = 'SUBSTRING';
2266        my $start = $2;
2267        my $value = $self->ROW_VALUE($1);
2268        my $length;
2269        if ( $start =~ /^(.+?) FOR (.+)$/i )
2270        {
2271            $start  = $1;
2272            $length = $2;
2273            $length = $self->ROW_VALUE($length);
2274        }
2275        $start = $self->ROW_VALUE($start);
2276        $str =~ s/\?(\d+)\?/$self->{struct}->{literals}->[$1]/g;
2277        if (   ( $start->{type} eq 'string' )
2278            or ( $start->{length} && ( $start->{length}->{type} eq 'string' ) ) )
2279        {
2280            return $self->do_err("Can't use a string as a SUBSTRING position: '$str'!");
2281        }
2282        return undef unless ($value);
2283        return $self->do_err("Can't use a number in SUBSTRING: '$str'!")
2284          if $value->{type} eq 'number';
2285        return {
2286            type    => 'function',
2287            name    => $name,
2288            value   => [$value],
2289            start   => $start,
2290            length  => $length,
2291            fullorg => $orgstr,
2292        };
2293    }
2294
2295    # TRIM ( [ [TRAILING|LEADING|BOTH] ['char'] FROM ] value )
2296    #
2297    if ( $str =~ m/^(TRIM) \((.+)\)\s*$/i )
2298    {
2299        my $name  = uc $1;
2300        my $value = $2;
2301        my ( $trim_spec, $trim_char );
2302        if ( $value =~ m/^(.+) FROM ([^\(\)]+)$/i )
2303        {
2304            my $front = $1;
2305            $value = $2;
2306            if ( $front =~ m/^\s*(TRAILING|LEADING|BOTH)(.*)$/i )
2307            {
2308                $trim_spec = uc $1;
2309                $trim_char = $2;
2310                $trim_char =~ s/^\s+//;
2311                $trim_char =~ s/\s+$//;
2312                undef $trim_char if ( length($trim_char) == 0 );
2313            }
2314            else
2315            {
2316                $trim_char = $front;
2317                $trim_char =~ s/^\s+//;
2318                $trim_char =~ s/\s+$//;
2319            }
2320        }
2321
2322        $trim_char ||= '';
2323        $trim_char =~ s/\?(\d+)\?/$self->{struct}->{literals}->[$1]/g;
2324        $value = $self->ROW_VALUE($value);
2325        return undef unless ($value);
2326        $str =~ s/\?(\d+)\?/$self->{struct}->{literals}->[$1]/g;
2327        my $value_type = $value->{type} if ref $value eq 'HASH';
2328        $value_type = $value->[0] if ( defined( _ARRAY($value) ) );
2329        return $self->do_err("Can't use a number in TRIM: '$str'!")
2330          if ( $value_type and $value_type eq 'number' );
2331
2332        return {
2333            type      => 'function',
2334            name      => $name,
2335            value     => [$value],
2336            trim_spec => $trim_spec,
2337            trim_char => $trim_char,
2338            fullorg   => $orgstr,
2339        };
2340    }
2341
2342    # UNKNOWN FUNCTION
2343    if ( $str =~ m/^(\S+) \(/ )
2344    {
2345        return $self->do_err("Unknown function '$1'");
2346    }
2347
2348    # STRING CONCATENATION
2349    #
2350    if ( $str =~ m/\|\|/ )
2351    {
2352        my @vals = split( m/ \|\| /, $str );
2353        my @newvals;
2354        for my $val (@vals)
2355        {
2356            my $newval = $self->ROW_VALUE($val);
2357            return undef unless ($newval);
2358            return $self->do_err("Can't use a number in string concatenation: '$str'!")
2359              if ( $newval->{type} eq 'number' );
2360            push @newvals, $newval;
2361        }
2362        return {
2363            type    => 'function',
2364            name    => 'str_concat',
2365            value   => \@newvals,
2366            fullorg => $orgstr,
2367        };
2368    }
2369
2370    # NULL, BOOLEAN, PLACEHOLDER, NUMBER
2371    #
2372    if ( $type = $self->LITERAL($str) )
2373    {
2374        undef $str if ( $type eq 'null' );
2375        $str = 1 if ( $type eq 'boolean' and $str =~ /^TRUE$/i );
2376        $str = 0 if ( $type eq 'boolean' and $str =~ /^FALSE$/i );
2377
2378        #        if ($type eq 'empty_string') {
2379        #           $str = '';
2380        #           $type = 'string';
2381        #	}
2382        $str = '' if ( $str and $str eq q('') );
2383        return {
2384            type    => $type,
2385            value   => $str,
2386            fullorg => $orgstr,
2387        };
2388    }
2389
2390    # QUOTED STRING LITERAL
2391    #
2392    if ( $str =~ m/\?(\d+)\?/ )
2393    {
2394        return {
2395            type    => 'string',
2396            value   => $self->{struct}->{literals}->[$1],
2397            fullorg => $self->{struct}->{literals}->[$1],
2398        };
2399    }
2400    elsif ( $str =~ /^\?LI(\d+)\?$/ )
2401    {
2402        return $self->ROW_VALUE_LIST( $self->{struct}->{list_ids}->[$1] );
2403    }
2404
2405    # COLUMN NAME
2406    #
2407    return undef unless ( $str = $self->COLUMN_NAME($str) );
2408
2409    if ( $str =~ m/^(.*)\./ )
2410    {
2411        my $table_name = $1;
2412        $self->_verify_tablename( $table_name, "WHERE" );
2413    }
2414
2415    #    push @{ $self->{struct}->{where_cols}},$str
2416    #       unless $self->{tmp}->{where_cols}->{"$str"};
2417    ++$self->{tmp}->{where_cols}->{$str};
2418    return {
2419        type    => 'column',
2420        value   => $str,
2421        fullorg => $orgstr,
2422    };
2423}
2424
2425#########################################################
2426# ROW_VALUE_LIST ::= <row_value> [,<row_value>...]
2427#########################################################
2428sub ROW_VALUE_LIST
2429{
2430    my ( $self, $row_str ) = @_;
2431    my @row_list = split ',', $row_str;
2432    if ( !( scalar @row_list ) )
2433    {
2434        return $self->do_err('Missing row value list!');
2435    }
2436    my @newvals;
2437    my $newval;
2438    for my $row_val (@row_list)
2439    {
2440        $row_val =~ s/^\s+//;
2441        $row_val =~ s/\s+$//;
2442
2443        return undef if !( $newval = $self->ROW_VALUE($row_val) );
2444        push @newvals, $newval;
2445    }
2446    return \@newvals;
2447}
2448
2449###############################################
2450# COLUMN NAME ::= [<table_name>.] <identifier>
2451###############################################
2452
2453sub COLUMN_NAME
2454{
2455    my ( $self, $str ) = @_;
2456    my ( $table_name, $col_name );
2457    if ( $str =~ m/^\s*(\S+)\.(\S+)$/s )
2458    {
2459        ( $table_name, $col_name ) = ( $1, $2 );
2460        if ( !$self->{opts}->{valid_options}->{SELECT_MULTIPLE_TABLES} )
2461        {
2462            return $self->do_err('Dialect does not support multiple tables!');
2463        }
2464        return undef unless ( $table_name = $self->TABLE_NAME($table_name) );
2465        $table_name = $self->replace_quoted_ids($table_name);
2466        $self->_verify_tablename($table_name);
2467    }
2468    else
2469    {
2470        $col_name = $str;
2471    }
2472
2473    $col_name =~ s/^\s+//;
2474    $col_name =~ s/\s+$//;
2475
2476    my $user_func = $col_name;
2477    $user_func =~ s/^(\S+).*$/$1/;
2478    if ( $col_name !~ m/^(TRIM|SUBSTRING)$/i )
2479    {
2480        undef $user_func unless ( $self->{opts}->{function_names}->{ uc $user_func } );
2481    }
2482    if ( !$user_func )
2483    {
2484        return undef unless ( ( $col_name eq '*' ) || $self->IDENTIFIER($col_name) );
2485    }
2486
2487    #
2488    # MAKE COL NAMES ALL UPPER CASE UNLESS IS DELIMITED IDENTIFIER
2489    my $orgcol = $col_name;
2490
2491    if ( $col_name =~ m/^\?QI(\d+)\?$/ )
2492    {
2493        $col_name = '"' . $self->{struct}->{quoted_ids}->[$1] . '"';
2494    }
2495    else
2496    {
2497        $col_name = lc $col_name
2498          unless (
2499            ( $self->{struct}->{command} eq 'CREATE' )
2500            ##############################################
2501            #
2502            # JZ addition to RR's alias patch
2503            #
2504            or ( $col_name =~ m/^(?:\p{Word}+\.)?"/ )
2505          );
2506
2507    }
2508
2509    #
2510    $col_name = $self->{struct}->{column_aliases}->{$col_name}
2511      if ( $self->{struct}->{column_aliases}->{$col_name} );
2512
2513    #    $orgcol = $self->replace_quoted_ids($orgcol);
2514    ##############################################
2515
2516    if ($table_name)
2517    {
2518        my $alias = $self->{tmp}->{is_table_alias}->{"\L$table_name"};
2519        $table_name = $alias if ( defined($alias) );
2520        $table_name = lc $table_name unless ( $table_name =~ m/^"/ );
2521        $col_name = "$table_name.$col_name" if ( -1 == index( $col_name, '.' ) );
2522    }
2523    return $col_name;
2524}
2525
2526#########################################################
2527# COLUMN NAME_LIST ::= <column_name> [,<column_name>...]
2528#########################################################
2529sub COLUMN_NAME_LIST
2530{
2531    my ( $self, $col_str ) = @_;
2532
2533    my @col_list = split( ',', $col_str );
2534    return $self->do_err('Missing column name list!') unless ( scalar(@col_list) );
2535
2536    my @newcols;
2537    for my $col (@col_list)
2538    {
2539        $col =~ s/^\s+//;
2540        $col =~ s/\s+$//;
2541
2542        my $newcol;
2543        return undef unless ( $newcol = $self->COLUMN_NAME($col) );
2544        push( @newcols, $newcol );
2545    }
2546
2547    return \@newcols;
2548}
2549
2550#####################################################
2551# TABLE_NAME_LIST := <table_name> [,<table_name>...]
2552#####################################################
2553sub TABLE_NAME_LIST
2554{
2555    my ( $self, $table_name_str ) = @_;
2556    my %aliases = ();
2557    my @tables;
2558    $table_name_str =~ s/(\?\d+\?),/$1:/g;    # fudge commas in functions
2559    my @table_names = split ',', $table_name_str;
2560    if ( scalar @table_names > 1
2561        and !$self->{opts}->{valid_options}->{SELECT_MULTIPLE_TABLES} )
2562    {
2563        return $self->do_err('Dialect does not support multiple tables!');
2564    }
2565
2566    my $bf = BAREWORD_FUNCTIONS;
2567    my %is_table_alias;
2568    for my $table_str (@table_names)
2569    {
2570        $table_str =~ s/(\?\d+\?):/$1,/g;     # unfudge commas in functions
2571        $table_str =~ s/\s+\(/\(/g;           # fudge spaces in functions
2572        my ( $table, $alias );
2573        my (@tstr) = split( m/\s+/, $table_str );
2574        if ( @tstr == 1 )
2575        {
2576            $table = $tstr[0];
2577        }
2578        elsif ( @tstr == 2 )
2579        {
2580            $table = $tstr[0];
2581            $alias = $tstr[1];
2582        }
2583        elsif ( @tstr == 3 )
2584        {
2585            return $self->do_err("Can't find alias in FROM clause!")
2586              unless ( uc( $tstr[1] ) eq 'AS' );
2587            $table = $tstr[0];
2588            $alias = $tstr[2];
2589        }
2590        else
2591        {
2592            return $self->do_err("Can't find table names in FROM clause!");
2593        }
2594
2595        $table =~ s/\(/ \(/g;    # unfudge spaces in functions
2596        my $u_name = $table;
2597        $u_name =~ s/^(\S+)\s*(.*$)/$1/;
2598        my $u_args = $2;
2599
2600        if (   ( $u_name = $self->is_func($u_name) )
2601            && ( $u_name =~ /^(?:$bf)$/i || $table =~ /^$u_name\s*\(/i ) )
2602        {
2603            $u_args = " $u_args" if ($u_args);
2604            my $u_func = $self->ROW_VALUE( $u_name . $u_args );
2605            $self->{struct}->{table_func}->{$u_name} = $u_func;
2606            $self->{struct}->{temp_table}            = 1;
2607            $table                                   = $u_name;
2608        }
2609        else
2610        {
2611            return undef unless ( $self->TABLE_NAME($table) );
2612        }
2613
2614        $table = $self->replace_quoted_ids($table);
2615        push( @tables, $table =~ m/^"/ ? $table : $table );
2616
2617        if ($alias)
2618        {
2619            return unless ( $self->TABLE_NAME($alias) );
2620            $alias = $self->replace_quoted_ids($alias);
2621            if ( $alias =~ m/^"/ )
2622            {
2623                push( @{ $aliases{$table} }, $alias );
2624                $is_table_alias{$alias} = $table;
2625            }
2626            else
2627            {
2628                push( @{ $aliases{$table} }, "\L$alias" );
2629                $is_table_alias{"\L$alias"} = $table;
2630            }
2631        }
2632    }
2633    my %is_table_name = map { $_ => 1 } @tables;
2634    $self->{tmp}->{is_table_alias}     = \%is_table_alias;
2635    $self->{tmp}->{is_table_name}      = \%is_table_name;
2636    $self->{struct}->{table_names}     = \@tables;
2637    $self->{struct}->{table_alias}     = \%aliases;
2638    $self->{struct}->{multiple_tables} = 1 if ( @tables > 1 );
2639    return 1;
2640}
2641
2642sub is_func($)
2643{
2644    my ( $self, $name ) = @_;
2645    $name =~ s/^(\S+).*$/$1/;
2646    return $name if ( $self->{opts}->{function_names}->{$name} );
2647    return uc $name if ( $self->{opts}->{function_names}->{ uc $name } );
2648    undef;
2649}
2650
2651#############################
2652# TABLE_NAME := <identifier>
2653#############################
2654sub TABLE_NAME
2655{
2656    my ( $self, $table_name ) = @_;
2657    if ( $table_name =~ m/^(.+?)\.([^\.]+)$/ )
2658    {
2659        my $schema = $1;    # ignored
2660        $table_name = $2;
2661    }
2662    if ( $table_name =~ m/\s*(\S+)\s+\S+/s )
2663    {
2664        return $self->do_err("Junk after table name '$1'!");
2665    }
2666    $table_name =~ s/\s+//s;
2667    if ( !$table_name )
2668    {
2669        return $self->do_err('No table name specified!');
2670    }
2671    return $table_name if ( $self->IDENTIFIER($table_name) );
2672
2673    #    return undef if !($self->IDENTIFIER($table_name));
2674    #    return 1;
2675}
2676
2677sub _verify_tablename
2678{
2679    my ( $self, $table_name, $location ) = @_;
2680    if ( defined($location) )
2681    {
2682        $location = " in $location";
2683    }
2684    else
2685    {
2686        $location = "";
2687    }
2688
2689    if ( $table_name =~ m/^"/ )
2690    {
2691        if (    !$self->{tmp}->{is_table_name}->{$table_name}
2692            and !$self->{tmp}->{is_table_alias}->{$table_name} )
2693        {
2694            return $self->do_err("Table '$table_name' referenced$location but not found in FROM list!");
2695        }
2696    }
2697    else
2698    {
2699        my @tblnamelist = ( keys( %{ $self->{tmp}->{is_table_name} } ), keys( %{ $self->{tmp}->{is_table_alias} } ) );
2700        my $tblnames = join( "|", @tblnamelist );
2701        unless ( $table_name =~ m/^(?:$tblnames)$/i )
2702        {
2703            return $self->do_err(
2704                "Table '$table_name' referenced$location but not found in FROM list (" . join( ",", @tblnamelist ) . ")!" );
2705        }
2706    }
2707
2708    return 1;
2709}
2710
2711###################################################################
2712# IDENTIFIER ::= <alphabetic_char> { <alphanumeric_char> | _ }...
2713#
2714# and must not be a reserved word or over 128 chars in length
2715###################################################################
2716sub IDENTIFIER
2717{
2718    my ( $self, $id ) = @_;
2719    if ( $id =~ m/^\?QI(.+)\?$/ or $id =~ m/^\?(.+)\?$/ )
2720    {
2721        return 1;
2722    }
2723    if ( $id =~ m/^[`](.+)[`]$/ )
2724    {
2725        $id = $1 and return 1;
2726    }
2727    if ( $id =~ m/^(.+)\.([^\.]+)$/ )
2728    {
2729        my $schema = $1;    # ignored
2730        $id = $2;
2731    }
2732    $id =~ s/\(|\)//g;
2733    return 1 if $id =~ m/^".+?"$/s;    # QUOTED IDENTIFIER
2734    my $err = "Bad table or column name: '$id' ";    # BAD CHARS
2735    if ( $id =~ /\W/ )
2736    {
2737        $err .= "has chars not alphanumeric or underscore!";
2738        return $self->do_err($err);
2739    }
2740    # CSV requires optional start with _
2741    my $badStartRx = uc( $self->{dialect} ) eq 'ANYDATA' ? qr/^\d/ : qr/^[_\d]/;
2742    if ( $id =~ $badStartRx )
2743    {                                                # BAD START
2744        $err .= "starts with non-alphabetic character!";
2745        return $self->do_err($err);
2746    }
2747    if ( length $id > 128 )
2748    {                                                # BAD LENGTH
2749        $err .= "contains more than 128 characters!";
2750        return $self->do_err($err);
2751    }
2752    $id = uc $id;
2753    if ( $self->{opts}->{reserved_words}->{$id} )
2754    {                                                # BAD RESERVED WORDS
2755        $err .= "is a SQL reserved word!";
2756        return $self->do_err($err);
2757    }
2758    return 1;
2759}
2760
2761########################################
2762# PRIVATE METHODS AND UTILITY FUNCTIONS
2763########################################
2764sub order_joins
2765{
2766    my ( $self, $links ) = @_;
2767    for my $link (@$links)
2768    {
2769        if ( $link !~ /\./ )
2770        {
2771            return [];
2772        }
2773    }
2774    @$links = map { s/^(.+)\..*$/$1/; $1; } @$links;
2775    my @all_tables;
2776    my %relations;
2777    my %is_table;
2778    while (@$links)
2779    {
2780        my $t1 = shift @$links;
2781        my $t2 = shift @$links;
2782        return undef unless defined $t1 and defined $t2;
2783        push @all_tables, $t1 unless $is_table{$t1}++;
2784        push @all_tables, $t2 unless $is_table{$t2}++;
2785        $relations{$t1}{$t2}++;
2786        $relations{$t2}{$t1}++;
2787    }
2788    my @tables     = @all_tables;
2789    my @order      = shift @tables;
2790    my %is_ordered = ( $order[0] => 1 );
2791    my %visited;
2792    while (@tables)
2793    {
2794        my $t    = shift @tables;
2795        my @rels = keys %{ $relations{$t} };
2796        for my $t2 (@rels)
2797        {
2798            next unless $is_ordered{$t2};
2799            push @order, $t;
2800            $is_ordered{$t}++;
2801            last;
2802        }
2803        if ( !$is_ordered{$t} )
2804        {
2805            push @tables, $t if $visited{$t}++ < @all_tables;
2806        }
2807    }
2808    return $self->do_err("Unconnected tables in equijoin statement!")
2809      if @order < @all_tables;
2810    return \@order;
2811}
2812
2813# PROVIDE BACKWARD COMPATIBILIT FOR JOCHEN'S FEATURE ATTRIBUTES TO NEW
2814#
2815#
2816sub set_feature_flags
2817{
2818    my ( $self, $select, $create ) = @_;
2819    if ( defined $select )
2820    {
2821        delete $self->{select};
2822        $self->{opts}->{valid_options}->{SELECT_MULTIPLE_TABLES} =
2823          $self->{opts}->{select}->{join} = $select->{join};
2824    }
2825    if ( defined $create )
2826    {
2827        delete $self->{create};
2828        for my $key ( keys %$create )
2829        {
2830            my $type = $key;
2831            $type =~ s/type_(.*)/\U$1/;
2832            $self->{opts}->{valid_data_types}->{$type} = $self->{opts}->{create}->{$key} =
2833              $create->{$key};
2834        }
2835    }
2836}
2837
2838sub clean_sql
2839{
2840    my ( $self, $sql ) = @_;
2841    my $fields;
2842    my $i = -1;
2843    my $e = '\\';
2844    $e = quotemeta($e);
2845
2846    #
2847    # patch from cpan@goess.org, adds support for col2=''
2848    #
2849    # $sql =~ s~'(([^'$e]|$e.|'')+)'~push(@$fields,$1);$i++;"?$i?"~ge;
2850    $sql =~ s~(?<!')'(([^'$e]|$e.|'')+)'~push(@$fields,$1);$i++;"?$i?"~ge;
2851
2852    #
2853    foreach (@$fields) { $_ =~ s/''/\\'/g; }
2854    my @a = $sql =~ m/((?<!\\)(?:(?:\\\\)*)')/g;
2855    if ( ( scalar(@a) % 2 ) == 1 )
2856    {
2857        $sql =~ s/^.*\?(.+)$/$1/;
2858        $self->do_err("Mismatched single quote before: <$sql>");
2859    }
2860    if ( $sql =~ m/\?\?(\d)\?/ )
2861    {
2862        $sql = $fields->[$1];
2863        $self->do_err("Mismatched single quote: <$sql>");
2864    }
2865    foreach (@$fields) { $_ =~ s/$e'/'/g; s/^'(.*)'$/$1/; }
2866
2867    #
2868    # From Steffen G. to correctly return newlines from $dbh->quote;
2869    #
2870    foreach (@$fields) { $_ =~ s/([^\\])\\r/$1\r/g; }
2871    foreach (@$fields) { $_ =~ s/([^\\])\\n/$1\n/g; }
2872
2873    $self->{struct}->{literals} = $fields;
2874
2875    my $qids;
2876    $i = -1;
2877    $e = q/""/;
2878
2879    #    $sql =~ s~"(([^"$e]|$e.)+)"~push(@$qids,$1);$i++;"?QI$i?"~ge;
2880    $sql =~ s/"(([^"]|"")+)"/push(@$qids,$1);$i++;"?QI$i?"/ge;
2881
2882    #@$qids = map { s/$e'/'/g; s/^'(.*)'$/$1/; $_} @$qids;
2883    $self->{struct}->{quoted_ids} = $qids if ($qids);
2884
2885    #    $sql =~ s~'(([^'\\]|\\.)+)'~push(@$fields,$1);$i++;"?$i?"~ge;
2886    #    @$fields = map { s/\\'/'/g; s/^'(.*)'$/$1/; $_} @$fields;
2887    #print "$sql [@$fields]\n";# if $sql =~ /SELECT/;
2888
2889## before line 1511
2890    my $comment_re = $self->{comment_re};
2891
2892    #    if ( $sql =~ s/($comment_re)//gs) {
2893    #       $self->{comment} = $1;
2894    #    }
2895    if ( $sql =~ m/(.*)$comment_re$/s )
2896    {
2897        $sql = $1;
2898        $self->{comment} = $2;
2899    }
2900    if ( $sql =~ m/^(.*)--(.*)(\n|$)/ )
2901    {
2902        $sql = $1;
2903        $self->{comment} = $2;
2904    }
2905
2906    $sql =~ s/\n/ /g;
2907    $sql =~ s/\s+/ /g;
2908    $sql =~ s/(\S)\(/$1 (/g;    # ensure whitespace before (
2909    $sql =~ s/\)(\S)/) $1/g;    # ensure whitespace after )
2910    $sql =~ s/\(\s*/(/g;        # trim whitespace after (
2911    $sql =~ s/\s*\)/)/g;        # trim whitespace before )
2912                                #
2913                                # $sql =~ s/\s*\(/(/g;   # trim whitespace before (
2914                                # $sql =~ s/\)\s*/)/g;   # trim whitespace after )
2915                                #    for my $op (qw(= <> < > <= >= \|\|))
2916                                #    {
2917                                #        $sql =~ s/(\S)$op/$1 $op/g;
2918                                #        $sql =~ s/$op(\S)/$op $1/g;
2919                                #    }
2920    $sql =~ s/(\S)([<>]?=|<>|<|>|\|\|)/$1 $2/g;
2921    $sql =~ s/([<>]?=|<>|<|>|\|\|)(\S)/$1 $2/g;
2922    $sql =~ s/< >/<>/g;
2923    $sql =~ s/< =/<=/g;
2924    $sql =~ s/> =/>=/g;
2925    $sql =~ s/\s*,/,/g;
2926    $sql =~ s/,\s*/,/g;
2927    $sql =~ s/^\s+//;
2928    $sql =~ s/\s+$//;
2929
2930    return $sql;
2931}
2932
2933sub trim
2934{
2935    my $str = $_[0] or return ('');
2936    $str =~ s/^\s+//;
2937    $str =~ s/\s+$//;
2938    return $str;
2939}
2940
2941sub do_err
2942{
2943    my ( $self, $err, $errstr ) = @_;
2944
2945    # $err = $errtype ? "DIALECT ERROR: $err" : "SQL ERROR: $err";
2946    $self->{struct}->{errstr} = $err;
2947
2948    carp $err  if ( $self->{PrintError} );
2949    croak $err if ( $self->{RaiseError} );
2950    return;
2951}
2952
2953#
2954#	DAA
2955#	abstract method so subclasses can provide
2956#	their own syntax transformations
2957#
2958sub transform_syntax
2959{
2960    my ( $self, $str ) = @_;
2961    return $str;
2962}
2963
2964sub DESTROY
2965{
2966    my $self = $_[0];
2967
2968    undef $self->{opts};
2969    undef $self->{struct};
2970    undef $self->{tmp};
2971    undef $self->{dialect};
2972    undef $self->{dialect_set};
2973}
2974
29751;
2976
2977__END__
2978
2979=pod
2980
2981=head1 NAME
2982
2983 SQL::Parser -- validate and parse SQL strings
2984
2985=head1 SYNOPSIS
2986
2987 use SQL::Parser;                                     # CREATE A PARSER OBJECT
2988 my $parser = SQL::Parser->new();
2989
2990 $parser->feature( $class, $name, $value );           # SET OR FIND STATUS OF
2991 my $has_feature = $parser->feature( $class, $name ); # A PARSER FEATURE
2992
2993 $parser->dialect( $dialect_name );                   # SET OR FIND STATUS OF
2994 my $current_dialect = $parser->dialect;              # A PARSER DIALECT
2995
2996
2997=head1 DESCRIPTION
2998
2999SQL::Parser is part of the SQL::Statement distribution and, most
3000interaction with the parser should be done through SQL::Statement.
3001The methods shown above create and modify a parser object.  To use the
3002parser object to parse SQL and to examine the resulting structure, you
3003should use SQL::Statement.
3004
3005B<Important Note>: Previously SQL::Parser had its own hash-based
3006interface for parsing, but that is now deprecated and will eventually
3007be phased out in favor of the object-oriented parsing interface of
3008SQL::Statement.  If you are unable to transition some features to the
3009new interface or have concerns about the phase out, please contact me.
3010See L<The Parse Structure> for details of the now-deprecated hash
3011method if you still need them.
3012
3013=head1 METHODS
3014
3015=head2 new()
3016
3017Create a new parser object
3018
3019 use SQL::Parser;
3020 my $parser = SQL::Parser->new();
3021
3022The new() method creates a SQL::Parser object which can then be
3023used to parse and validate the syntax of SQL strings. It takes two
3024optional parameters - 1) the name of the SQL dialect that will define
3025the syntax rules for the parser and 2) a reference to a hash which can
3026contain additional attributes of the parser.  If no dialect is specified,
3027'AnyData' is the default.
3028
3029 use SQL::Parser;
3030 my $parser = SQL::Parser->new( $dialect_name, \%attrs );
3031
3032The dialect_name parameter is a string containing any valid
3033dialect such as 'ANSI', 'AnyData', or 'CSV'.  See the section on
3034the dialect() method below for details.
3035
3036The C<attrs> parameter is a reference to a hash that can
3037contain error settings for the PrintError and RaiseError
3038attributes.
3039
3040An example:
3041
3042  use SQL::Parser;
3043  my $parser = SQL::Parser->new('AnyData', {RaiseError=>1} );
3044
3045  This creates a new parser that uses the grammar rules
3046  contained in the .../SQL/Dialects/AnyData.pm file and which
3047  sets the RaiseError attribute to true.
3048
3049=head2 dialect()
3050
3051 $parser->dialect( $dialect_name );     # load a dialect configuration file
3052 my $dialect = $parser->dialect;        # get the name of the current dialect
3053
3054 For example:
3055
3056   $parser->dialect('AnyData');  # loads the AnyData config file
3057   print $parser->dialect;       # prints 'AnyData'
3058
3059The C<$dialect_name> parameter may be the name of any dialect
3060configuration file on your system.  Use the
3061$parser->list('dialects') method to see a list of available
3062dialects.  At a minimum it will include "ANSI", "CSV", and
3063"AnyData".  For backwards compatibility 'Ansi' is accepted as a
3064synonym for 'ANSI', otherwise the names are case sensitive.
3065
3066Loading a new dialect configuration file erases all current
3067parser features and resets them to those defined in the
3068configuration file.
3069
3070=head2 feature()
3071
3072Features define the rules to be used by a specific parser
3073instance.  They are divided into the following classes:
3074
3075    * valid_commands
3076    * valid_options
3077    * valid_comparison_operators
3078    * valid_data_types
3079    * reserved_words
3080
3081Within each class a feature name is either enabled or
3082disabled. For example, under "valid_data_types" the name "BLOB"
3083may be either disabled or enabled.  If it is not enabled
3084(either by being specifically disabled, or simply by not being
3085specified at all) then any SQL string using "BLOB" as a data
3086type will throw a syntax error "Invalid data type: 'BLOB'".
3087
3088The feature() method allows you to enable, disable, or check the
3089status of any feature.
3090
3091 $parser->feature( $class, $name, 1 );             # enable a feature
3092
3093 $parser->feature( $class, $name, 0 );             # disable a feature
3094
3095 my $feature = $parser->feature( $class, $name );  # return status of a feature
3096
3097 For example:
3098
3099 $parser->feature('reserved_words','FOO',1);       # make 'FOO' a reserved word
3100
3101 $parser->feature('valid_data_types','BLOB',0);    # disallow 'BLOB' as a
3102                                                   # data type
3103
3104                                                   # determine if the LIKE
3105                                                   # operator is supported
3106 my $LIKE = $parser->feature('valid_comparison_operators','LIKE');
3107
3108See the section below on "Backwards Compatibility" for use of
3109the feature() method with SQL::Statement 0.1x style parameters.
3110
3111=begin undocumented
3112
3113=head2 clean_sql
3114
3115=head2 command
3116
3117=head2 create_op_regexen
3118
3119=head2 do_err
3120
3121=head2 errstr
3122
3123=head2 extract_column_list
3124
3125=head2 extract_func_args
3126
3127=head2 group_ands
3128
3129=head2 is_func
3130
3131=head2 list
3132
3133=head2 non_parens_search
3134
3135=head2 nongroup_numeric
3136
3137=head2 nongroup_string
3138
3139=head2 order_joins
3140
3141=head2 parens_search
3142
3143=head2 parse
3144
3145=head2 repl_btwin
3146
3147=head2 replace_quoted
3148
3149=head2 replace_quoted_commas
3150
3151=head2 replace_quoted_ids
3152
3153=head2 set_feature_flags
3154
3155=head2 structure
3156
3157=head2 transform_concat
3158
3159=head2 trim
3160
3161=head2 transform_syntax
3162
3163=head2 undo_math_funcs
3164
3165=head2 undo_string_funcs
3166
3167=end undocumented
3168
3169=head1 Supported SQL syntax
3170
3171The SQL::Statement distribution can be used to either just parse SQL
3172statements or to execute them against actual data.  A broader set of
3173syntax is supported in the parser than in the executor.  For example
3174the parser allows you to specify column constraints like PRIMARY KEY.
3175Currently, these are ignored by the execution engine.  Likewise syntax
3176such as RESTRICT and CASCADE on DROP statements or LOCAL GLOBAL TEMPORARY
3177tables in CREATE are supported by the parser but ignored by the executor.
3178
3179To see the list of Supported SQL syntax formerly kept in this pod, see
3180L<SQL::Statement>.
3181
3182=head1 Subclassing SQL::Parser
3183
3184In the event you need to either extend or modify SQL::Parser's
3185default behavior, the following methods may be overridden:
3186
3187=over
3188
3189=item C<$self->E<gt>C<get_btwn($string)>
3190
3191Processes the BETWEEN...AND... predicates; default converts to
31922 range predicates.
3193
3194=item C<$self->E<gt>C<get_in($string)>
3195
3196Process the IN (...list...) predicates; default converts to
3197a series of OR'd '=' predicate, or AND'd '<>' predicates for
3198NOT IN.
3199
3200=item C<$self->E<gt>C<transform_syntax($string)>
3201
3202Abstract method; default simply returns the original string.
3203Called after repl_btwn() and repl_in(), but before any further
3204predicate processing is applied. Possible uses include converting
3205other predicate syntax not recognized by SQL::Parser into user-defined
3206functions.
3207
3208=back
3209
3210=head1 The parse structure
3211
3212This section outlines the B<now-deprecated> hash interface to the
3213parsed structure.  It is included B<for backwards compatibility only>.
3214You should use the SQL::Statement object interface to the structure
3215instead.  See L<SQL::Statement>.
3216
3217B<Parse Structures>
3218
3219Here are some further examples of the data structures returned
3220by the structure() method after a call to parse().  Only
3221specific details are shown for each SQL instance, not the entire
3222structure.
3223
3224B<parse()>
3225
3226Once a SQL::Parser object has been created with the new()
3227method, the parse() method can be used to parse any number of
3228SQL strings.  It takes a single required parameter -- a string
3229containing a SQL command.  The SQL string may optionally be
3230terminated by a semicolon.  The parse() method returns a true
3231value if the parse is successful and a false value if the parse
3232finds SQL syntax errors.
3233
3234Examples:
3235
3236  1) my $success = $parser->parse('SELECT * FROM foo');
3237
3238  2) my $sql = 'SELECT * FROM foo';
3239     my $success = $parser->parse( $sql );
3240
3241  3) my $success = $parser->parse(qq!
3242         SELECT id,phrase
3243           FROM foo
3244          WHERE id < 7
3245            AND phrase <> 'bar'
3246       ORDER BY phrase;
3247   !);
3248
3249  4) my $success = $parser->parse('SELECT * FRoOM foo ');
3250
3251In examples #1,#2, and #3, the value of $success will be true
3252because the strings passed to the parse() method are valid SQL
3253strings.
3254
3255In example #4, however, the value of $success will be false
3256because the string contains a SQL syntax error ('FRoOM' instead
3257of 'FROM').
3258
3259In addition to checking the return value of parse() with a
3260variable like $success, you may use the PrintError and
3261RaiseError attributes as you would in a DBI script:
3262
3263 * If PrintError is true, then SQL syntax errors will be sent as
3264   warnings to STDERR (i.e. to the screen or to a file if STDERR
3265   has been redirected).  This is set to true by default which
3266   means that unless you specifically turn it off, all errors
3267   will be reported.
3268
3269 * If RaiseError is true, then SQL syntax errors will cause the
3270   script to die, (i.e. the script will terminate unless wrapped
3271   in an eval).  This is set to false by default which means
3272   that unless you specifically turn it on, scripts will
3273   continue to operate even if there are SQL syntax errors.
3274
3275Basically, you should leave PrintError on or else you will not
3276be warned when an error occurs.  If you are simply validating a
3277series of strings, you will want to leave RaiseError off so that
3278the script can check all strings regardless of whether some of
3279them contain SQL errors.  However, if you are going to try to
3280execute the SQL or need to depend that it is correct, you should
3281set RaiseError on so that the program will only continue to
3282operate if all SQL strings use correct syntax.
3283
3284IMPORTANT NOTE #1: The parse() method only checks syntax, it
3285does NOT verify if the objects listed actually exist.  For
3286example, given the string "SELECT model FROM cars", the parse()
3287method will report that the string contains valid SQL but that
3288will not tell you whether there actually is a table called
3289"cars" or whether that table contains a column called 'model'.
3290Those kinds of verifications are performed by the
3291SQL::Statement module, not by SQL::Parser by itself.
3292
3293IMPORTANT NOTE #2: The parse() method uses rules as defined by
3294the selected dialect configuration file and the feature()
3295method.  This means that a statement that is valid in one
3296dialect may not be valid in another.  For example the 'CSV' and
3297'AnyData' dialects define 'BLOB' as a valid data type but the
3298'ANSI' dialect does not.  Therefore the statement 'CREATE TABLE
3299foo (picture BLOB)' would be valid in the first two dialects but
3300would produce a syntax error in the 'ANSI' dialect.
3301
3302B<structure()>
3303
3304After a SQL::Parser object has been created and the parse()
3305method used to parse a SQL string, the structure() method
3306returns the data structure of that string.  This data structure
3307may be passed on to other modules (e.g. SQL::Statement) or it
3308may be printed out using, for example, the Data::Dumper module.
3309
3310The data structure contains all of the information in the SQL
3311string as parsed into its various components.  To take a simple
3312example:
3313
3314 $parser->parse('SELECT make,model FROM cars');
3315 use Data::Dumper;
3316 print Dumper $parser->structure;
3317
3318Would produce:
3319
3320 $VAR1 = {
3321          'column_defs' => [
3322                              { 'type'  => 'column',
3323                                'value' => 'make', },
3324                              { 'type'  => 'column',
3325                                'value' => 'model', },
3326                            ],
3327          'command' => 'SELECT',
3328          'table_names' => [
3329                             'cars'
3330                           ]
3331        };
3332
3333
3334 'SELECT make,model, FROM cars'
3335
3336      command => 'SELECT',
3337      table_names => [ 'cars' ],
3338      column_names => [ 'make', 'model' ],
3339
3340 'CREATE TABLE cars ( id INTEGER, model VARCHAR(40) )'
3341
3342      column_defs => {
3343          id    => { data_type => INTEGER     },
3344          model => { data_type => VARCHAR(40) },
3345      },
3346
3347 'SELECT DISTINCT make FROM cars'
3348
3349      set_quantifier => 'DISTINCT',
3350
3351 'SELECT MAX (model) FROM cars'
3352
3353    set_function   => {
3354        name => 'MAX',
3355        arg  => 'models',
3356    },
3357
3358 'SELECT * FROM cars LIMIT 5,10'
3359
3360    limit_clause => {
3361        offset => 5,
3362        limit  => 10,
3363    },
3364
3365 'SELECT * FROM vars ORDER BY make, model DESC'
3366
3367    sort_spec_list => [
3368        { make  => 'ASC'  },
3369        { model => 'DESC' },
3370    ],
3371
3372 "INSERT INTO cars VALUES ( 7, 'Chevy', 'Impala' )"
3373
3374    values => [ 7, 'Chevy', 'Impala' ],
3375
3376=head1 SUPPORT
3377
3378You can find documentation for this module with the perldoc command.
3379
3380    perldoc SQL::Parser
3381    perldoc SQL::Statement
3382
3383You can also look for information at:
3384
3385=over 4
3386
3387=item * RT: CPAN's request tracker
3388
3389L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=SQL-Statement>
3390
3391=item * AnnoCPAN: Annotated CPAN documentation
3392
3393L<http://annocpan.org/dist/SQL-Statement>
3394
3395=item * CPAN Ratings
3396
3397L<http://cpanratings.perl.org/s/SQL-Statement>
3398
3399=item * Search CPAN
3400
3401L<http://search.cpan.org/dist/SQL-Statement/>
3402
3403=back
3404
3405=head2 Where can I go for help?
3406
3407For questions about installation or usage, please ask on the
3408dbi-users@perl.org mailing list or post a question on PerlMonks
3409(L<http://www.perlmonks.org/>, where Jeff is known as jZed).
3410Jens does not visit PerlMonks on a regular basis.
3411
3412If you have a bug report, a patch or a suggestion, please open a new
3413report ticket at CPAN (but please check previous reports first in case
3414your issue has already been addressed). You can mail any of the module
3415maintainers, but you are more assured of an answer by posting to the
3416dbi-users list or reporting the issue in RT.
3417
3418Report tickets should contain a detailed description of the bug or
3419enhancement request and at least an easily verifiable way of
3420reproducing the issue or fix. Patches are always welcome, too.
3421
3422=head2 Where can I go for help with a concrete version?
3423
3424Bugs and feature requests are accepted against the latest version
3425only. To get patches for earlier versions, you need to get an
3426agreement with a developer of your choice - who may or not report the
3427the issue and a suggested fix upstream (depends on the license you
3428have chosen).
3429
3430=head2 Business support and maintenance
3431
3432For business support you can contact Jens via his CPAN email
3433address rehsackATcpan.org. Please keep in mind that business
3434support is neither available for free nor are you eligible to
3435receive any support based on the license distributed with this
3436package.
3437
3438
3439=head1 AUTHOR & COPYRIGHT
3440
3441 This module is
3442
3443 copyright (c) 2001,2005 by Jeff Zucker and
3444 copyright (c) 2007-2020 by Jens Rehsack.
3445
3446 All rights reserved.
3447
3448The module may be freely distributed under the same terms as
3449Perl itself using either the "GPL License" or the "Artistic
3450License" as specified in the Perl README file.
3451
3452Jeff can be reached at: jzuckerATcpan.org
3453Jens can be reached at: rehsackATcpan.org or via dbi-devATperl.org
3454
3455=cut
3456