File Coverage

blib/lib/SQL/Yapp.pm

Criterion	Covered	Total	%
statement	2376	2938	80.8
branch	712	1106	64.3
condition	147	293	50.1
subroutine	519	722	71.8
pod	0	298	0.0
total	3754	5357	70.0

#! /usr/bin/perl -w

package SQL::Yapp;

use strict;
use warnings;
use vars         qw($VERSION @EXPORT_OK);
use base         qw(Exporter);
use Carp         qw(longmess carp croak confess);
use Hash::Util   qw(lock_keys lock_hash);
use Scalar::Util qw(looks_like_number blessed);
use Data::Dumper;
use Filter::Simple;
use Text::Balanced;

require v5.8;

$VERSION= 2.000;

@EXPORT_OK=qw(
    dbh
    get_dbh
    quote
    quote_identifier
    check_identifier
    runtime_check
    xlat_catalog
    xlat_schema
    xlat_table
    xlat_column
    xlat_charset
    xlat_collate
    xlat_constraint
    xlat_index
    xlat_transliteration
    xlat_transcoding
    xlat_engine
    parse
    ASTERISK
    QUESTION
    NULL
    TRUE
    FALSE
    UNKNOWN
    DEFAULT
);

use constant SQL_MARK        => "\0__SQL__";
use constant COMMA_STR       => ', ';
use constant LARGE_LIMIT_CNT => '18446744073709551615';

use constant NOT_IN_LIST => 0;
use constant IN_LIST     => 1;

use constant NO_PARENS   => 0;
use constant PARENS      => 1;

use constant NO_SHIFT    => 0;
use constant SHIFT       => 1;

my $get_dbh=              undef;
my $quote_id=             undef;
my $quote_val=            undef;
my $quote_id_default=     undef;
my $quote_val_default=    undef;
my $xlat_catalog=         sub($) { $_[0] };
my $xlat_schema=          sub($) { $_[0] };
my $xlat_table=           sub($) { $_[0] };
my $xlat_column=          sub($) { $_[0] };
my $xlat_charset=         sub($) { $_[0] };
my $xlat_collate=         sub($) { $_[0] };
my $xlat_constraint=      sub($) { $_[0] };
my $xlat_index=           sub($) { $_[0] };
my $xlat_transliteration= sub($) { $_[0] };
my $xlat_transcoding=     sub($) { $_[0] };
my $xlat_engine=          sub($) { $_[0] };
my $check_identifier=     sub($$$$$) { };
my $runtime_check=        0;
my $sql_marker=           'sql';
my $do_prec=              0;
my $debug=                0;

my %dialect= (  # known dialects
    generic    => 1,
    std        => 1,
    mysql      => 1,
    postgresql => 1,
    oracle     => 1,
);

my $write_dialect= 'generic'; # not well-supported yet, only a few things are done
my %read_dialect= (
    mysql    => 1,
    postgresql => 1,
    oracle   => 1,
);

# SQL often has several tokens used as one keyword.  In order to
# simplify the parser, we combine them in the scanner already.  This
# also produces nicer  error messages with more information for the
# user (e.g. 'Unexpected IS NOT NULL'...).
my %multi_token= (
    IS => {
        NULL => {},
        TRUE => {},
        FALSE => {},
        UNKNOWN => {},
        NORMALIZED => {},
        NOT => {
            NULL => {},
            TRUE => {},
            FALSE => {},
            UNKNOWN => {},
            NORMALIZED => {},
            A => { SET => {} },
            OF => {},
        },
        DISTINCT => { FROM => {} },
        A => { SET => {} },
        OF => {},
    },
    GROUP => { BY => {} },
    ORDER => { BY => {} },
    WITH => {
        ROLLUP => {},
        ORDINALITY => {},
        LOCAL => { TIME => { ZONE => {} } },
        TIME  => { ZONE => {} },
    },
    WITHOUT => { TIME => { ZONE => {} } },
    FOR => {
        UPDATE => {},
        SHARE  => {},
    },
    LOCK => { IN => { SHARE => { MODE => {} } } },

    SIMILAR => { TO => {} },
    BETWEEN => {
        SYMMETRIC  => {},
        ASYMMETRIC => {},
    },
    MEMBER => { OF => {} },

    PRIMARY => { KEY => {} },
    FOREIGN => { KEY => {} },

    CHARACTER => {
        SET => {},
        VARYING => {},
    },
    NATIONAL => { CHARACTER => {} },
    NCHAR => {
        VARYING => {}
    },
    DEFAULT => {
        VALUES => {},
        CHARACTER => {
            SET => {}
        },
    },
    ON => {
        DUPLICATE => { KEY => { UPDATE => {} } },
        DELETE => {},
        UPDATE => {},
        COMMIT => {},
    },
    OVERRIDING => {
        USER   => { VALUE => {} },
        SYSTEM => { VALUE => {} }
    },
    CREATE => {
        TABLE => {},
        LOCAL => {
            TABLE => {},
            TEMPORARY => { TABLE => {} },
        },
        GLOBAL => {
            TABLE => {},
            TEMPORARY => { TABLE => {} },
        },
        INDEX => {},
    },
    ALTER => {
        TABLE => {},
        IGNORE => { TABLE => {} },
        ONLINE => {
            TABLE => {},
            IGNORE => { TABLE => {} },
        },
        OFFLINE => {
            TABLE => {},
            IGNORE => { TABLE => {} },
        },
        COLUMN => {
        },
    },
    DROP => {
        TABLE => {},
        TEMPORARY => { TABLE => {} },

        SIGN => {},
        ZEROFILL => {},
        COLLATE  => {},
        TIME => { ZONE => {} },
        CHARACTER => { SET => {} },

        DEFAULT => {},
        UNIQUE => {},
        AUTO_INCREMENT => {},
        UNIQUE => { KEY => {} },
        PRIMARY => { KEY => {} },
        FOREIGN => { KEY => {} },
        KEY => {},
        INDEX => {},

        NOT => { NULL => {} },

        COLUMN => {},
        CONSTRAINT => {},
    },
    NOT => {
        LIKE => {},
        CLIKE => {},
        SIMILAR => { TO => {}, },
        BETWEEN => {
            SYMMETRIC  => {},
            ASYMMETRIC => {},
        },
        MEMBER => { OF => {} },
        NULL => {},
    },

    NO => {
        ACTION => {},
    },

    BINARY => { VARYING => {} },
    TEXT => { BINARY => {} },
    TINYTEXT => { BINARY => {} },
    MEDIUMTEXT => { BINARY => {} },
    LONGTEXT => { BINARY => {} },
    UNIQUE => { KEY => {} },
    IF => {
        NOT => { EXISTS => {} },  # Ouch! (should be :if-does-not-exist, of course)
        EXISTS => {},
    },
    SET => {
        NULL => {},
        DEFAULT => {},
        NOT => { NULL => {} },
        SET => { DATA => { TYPE => {} } },
    },
    PRESERVE => { ROWS => {} },
    DELETE   => { ROWS => {} },
    RENAME => {
        TO => {},
        COLUMN => {},
    },
    ADD => {
        COLUMN => {},
    },
    MODIFY => {
        COLUMN => {},
    },
    CHANGE => {
        COLUMN => {},
    },
);
my %synonym= (
    'NORMALISED'          => 'NORMALIZED',
    'CHAR'                => 'CHARACTER',
    'CHAR_LENGTH'         => 'CHARACTER_LENGTH',
    'CHARACTER VARYING'   => 'VARCHAR',
    'NATIONAL CHARACTER'  => 'NCHAR',
    'CHAR LARGE OBJECT'   => 'CLOB',
    'NCHAR LARGE OBJECT'  => 'NCLOB',
    'BINARY LARGE OBJECT' => 'BLOB',
    'NVARCHAR'            => 'NCHAR VARYING',
    'DEC'                 => 'DECIMAL',
    'INTEGER'             => 'INT',
    'BINARY VARYING'      => 'VARBINARY',
    'CHARSET'             => 'CHARACTER SET',
    'TEMP'                => 'TEMPORARY',
);

my %type_spec= ();

my @SELECT_INITIAL= (
    'SELECT',
    # 'WITH' # NOT YET
);

my @CREATE_TABLE_INITIAL= (
    'CREATE TABLE',
    'CREATE TEMPORARY TABLE',
    'CREATE LOCAL TABLE',
    'CREATE GLOBAL TABLE',
    'CREATE LOCAL TEMPORARY TABLE',
    'CREATE GLOBAL TEMPORARY TABLE',
);

my @DROP_TABLE_INITIAL= (
    'DROP TABLE',
    'DROP TEMPORARY TABLE',
);

my @ALTER_TABLE_INITIAL= (
    'ALTER TABLE',
    'ALTER IGNORE TABLE',
    'ALTER ONLINE TABLE',
    'ALTER ONLINE IGNORE TABLE',
    'ALTER OFFLINE TABLE',
    'ALTER OFFLINE IGNORE TABLE',
);

######################################################################
# Use settings:

sub get_set
{
    my $var= shift;
    my $r= $$var;
    ($$var)= @_ if scalar(@_);
    return $;
}

sub get_dbh()
{
    return $get_dbh->();
}

sub dbh(;&)
{
    get_set (\$get_dbh, @_);
    if ($get_dbh) {
        $quote_id_default=  sub(@) { $get_dbh->()->quote_identifier(@_); };
        $quote_val_default= sub($) { $get_dbh->()->quote($_[0]); };
    }
    else {
        $quote_id_default=  undef;
        $quote_val_default= undef;
    }
}

sub quote_identifier(;&)     { get_set (\$quote_id,             @_); }
sub quote(;&)                { get_set (\$quote_val,            @_); }
sub xlat_catalog(;&)         { get_set (\$xlat_catalog,         @_); }
sub xlat_schema(;&)          { get_set (\$xlat_schema,          @_); }
sub xlat_table(;&)           { get_set (\$xlat_table,           @_); }
sub xlat_column(;&)          { get_set (\$xlat_column,          @_); }
sub xlat_charset(;&)         { get_set (\$xlat_charset,         @_); }
sub xlat_collate(;&)         { get_set (\$xlat_collate,         @_); }
sub xlat_constraint(;&)      { get_set (\$xlat_constraint,      @_); }
sub xlat_index(;&)           { get_set (\$xlat_index,           @_); }
sub xlat_transcoding(;&)     { get_set (\$xlat_transcoding,     @_); }
sub xlat_transliteration(;&) { get_set (\$xlat_transliteration, @_); }
sub xlat_engine(;&)          { get_set (\$xlat_engine,          @_); }

sub check_identifier(;&)     { get_set (\$check_identifier,     @_); }
sub runtime_check(;$)        { get_set (\$runtime_check,        @_); }

sub sql_marker(;$)           { get_set (\$sql_marker,   @_); }  # used only internally

sub catalog_prefix($)        { my ($p)= @_; xlat_catalog    { $p.$_[0] }; }
sub schema_prefix($)         { my ($p)= @_; xlat_schema     { $p.$_[0] }; }
sub table_prefix($)          { my ($p)= @_; xlat_table      { $p.$_[0] }; }
sub column_prefix($)         { my ($p)= @_; xlat_column     { $p.$_[0] }; }
sub constraint_prefix($)     { my ($p)= @_; xlat_constraint { $p.$_[0] }; }

sub debug($)                 { ($debug)= @_; }

sub read_dialect1($)
{
    my ($s)= @_;
    if ($s eq 'all') {
        for my $s1 (keys %dialect) {
            $read_dialect{$s1}= 1;
        }
    }
    else {
        croak "Unknown dialect: read_dialect=$s" unless $dialect{$s};
        $read_dialect{$s}= 1;
    }
}

sub read_dialect($)
{
    my ($s)= @_;
    %read_dialect=();
    if (!ref($s)) {
        read_dialect1($s);
    }
    elsif (ref($s) eq 'ARRAY') {
        for my $s1 (@$s) {
            read_dialect1($s1);
        }
    }
    else {
        die "Illegal reference: ".ref($s);
    }
}

sub write_dialect($)
{
    my ($s)= @_;
    croak "Unknown dialect: write_dialect=$s" unless $dialect{$s};
    $write_dialect= $s;
}

sub dialect($)
{
    my ($s)= @_;
    read_dialect($s);
    write_dialect($s);
}

######################################################################
# Init

my %import_handler_nonref= (
    'marker'               => \&sql_marker,
    'catalog_prefix'       => \&catalog_prefix,
    'schema_prefix'        => \&schema_prefix,
    'table_prefix'         => \&table_prefix,
    'column_prefix'        => \&column_prefix,
    'constraint_prefix'    => \&constraint_prefix,
    'debug'                => \&debug,
    'read_dialect'         => \&read_dialect,
    'write_dialect'        => \&write_dialect,
    'dialect'              => \&dialect,
);
my %import_handler_bool= (
    'runtime_check'        => \&runtime_check,
);
my %import_handler_ref= (
    'dbh'                  => \&dbh,
    'quote'                => \"e,
    'quote_identifier'     => \"e_identifier,
    'xlat_catalog'         => \&xlat_catalog,
    'xlat_schema'          => \&xlat_schema,
    'xlat_table'           => \&xlat_table,
    'xlat_column'          => \&xlat_column,
    'xlat_charset'         => \&xlat_charset,
    'xlat_collate'         => \&xlat_collate,
    'xlat_constraint'      => \&xlat_constraint,
    'xlat_index'           => \&xlat_index,
    'xlat_transliteration' => \&xlat_transliteration,
    'xlat_transcoding'     => \&xlat_transcoding,
    'xlat_engine'          => \&xlat_engine,
    'check_identifier'     => \&check_identifier,
);

sub type_spec()
{
    return (
        'DOUBLE PRECISION' => 'INT',
        'REAL'     => 'INT',
        'BIGINT'   => 'INT',
        'SMALLINT' => 'INT',
        'INT' => {
        },

        # numbers with 0 or 1 precision marker:
        'FLOAT' => {
            prec1 => 1,
        },

        # numbers with 0, 1, or 2 precision numbers:
        'NUMERIC' => 'DECIMAL',
        'DECIMAL' => {
            prec1 => 1,
            prec2 => 1,
        },

        # character strings:
        'VARCHAR' => 'CHARACTER',
        'CHARACTER' => {
            prec1   => 1,
            charset => 1,
            collate => 1,
        },

        # clobs:
        'CLOB' => {
            prec1     => 1,
            prec_mul  => 1,
            prec_unit => 1,
            charset   => 1,
            collate   => 1,
        },

        # nchar:
        'NCHAR VARYING' => 'NCHAR',
        'NCHAR' => {
            prec1   => 1,
            collate => 1,
        },

        # nclobs:
        'NCLOB' => {
            prec1     => 1,
            prec_mul  => 1,
            prec_unit => 1,
            collate   => 1,
        },

        # binary strings:
        'VARBINARY' => 'BINARY',     # not standard
        'BINARY' => {
            prec1 => 1,
        },

        # blobs:
        'BLOB' => {
            prec1     => 1,
            prec_mul  => 1,
            prec_unit => 1,
        },

        # simple types without further attributes or lengths:
        'SERIAL' => 'BOOLEAN', # column spec, but handled as type for simplicity reasons
        'BOOLEAN' => {
        },

        # date/time:
        'DATE' => 'TIME',
        'TIMESTAMP' => 'TIME',
        'TIME' => {
            timezone => 1
        },

        # Dialects come last because they may redefine above settings:
        # If two dialects are contracting, you must find a common solution
        # and put it at the end of this list:
        ($read_dialect{mysql} ?
            (
                'SMALLINT'    => 'INT',
                'BIGINT'      => 'INT',
                'TINYINT'     => 'INT',
                'MEDIUMINT'   => 'INT',
                'BIT'         => 'INT',
                'BIT VARYING' => 'INT',
                'FLOAT'       => 'INT',
                'INT' => {
                    prec1    => 1,
                    zerofill => 1,
                    sign     => 1,
                },

                'FLOAT'   => 'NUMERIC',
                'DECIMAL' => 'NUMERIC',
                'REAL'    => 'NUMERIC',
                'DOUBLE'  => 'NUMERIC',
                'NUMERIC' => {
                    prec1    => 1,
                    prec2    => 1,
                    zerofill => 1,
                    sign     => 1,
                },

                'DATETIME'   => 'TIME',
                'YEAR'       => 'TIME',

                'TINYBLOB'   => 'BINARY',
                'MEDIUMBLOB' => 'BINARY',
                'LONGBLOB'   => 'BINARY',

                'TINYTEXT'   => 'CHARACTER',
                'MEDIUMTEXT' => 'CHARACTER',
                'LONGTEXT'   => 'CHARACTER',
                'TEXT'       => 'CHARACTER',

                'TINYTEXT BINARY'   => 'CHARACTER',
                'MEDIUMTEXT BINARY' => 'CHARACTER',
                'LONGTEXT BINARY'   => 'CHARACTER',
                'TEXT BINARY'       => 'CHARACTER',

                'ENUM' => {
                    value_list => 1,
                    charset => 1,
                    collate => 1,
                },

                'SET' => {
                    value_list => 1,
                    charset => 1,
                    collate => 1,
                },
            )
        :   ()
        ),
        ($read_dialect{postgresql} ?
            (
                'BYTEA'     => 'BINARY',
                'INT2'      => 'INT',
                'INT4'      => 'INT',
                'INT8'      => 'INT',
                'POINT'     => 'BOOLEAN',
                'LINE'      => 'BOOLEAN',
                'LSEG'      => 'BOOLEAN',
                'BOX'       => 'BOOLEAN',
                'PATH'      => 'BOOLEAN',
                'POLYGON'   => 'BOOLEAN',
                'CIRCLE'    => 'BOOLEAN',
                'MONEY'     => 'BOOLEAN',
                'IRDR'      => 'BOOLEAN',
                'INET'      => 'BOOLEAN',
                'MACADDR'   => 'BOOLEAN',
                'UUID'      => 'BOOLEAN',
                'TEXT'      => 'CHARACTER',
                'SERIAL4'   => 'SERIAL',
                'SERIAL8'   => 'SERIAL',
                'BIGSERIAL' => 'SERIAL',
            )
        :   ()
        ),
        ($read_dialect{oracle} ?
            (
                'NUMBER' => 'NUMERIC'
            )
        :   ()
        ),
    );
}

sub import
{
    my ($pack, @opt)= @_;
    my @super_param= ();
    my $i=0;
    while ($i < scalar(@opt)) {
        my $k= $opt[$i];
        if ($i+1 < scalar(@opt)) {
            my $v= $opt[$i+1];
            if (my $handler= $import_handler_nonref{$k}) {
                $handler->($v);
                $i++;
            }
            elsif ($v eq '0' || $v eq '1') {
                if (my $handler= $import_handler_bool{$k}) {
                    $handler->($v);
                    $i++;
                }
                else {
                    croak "Error: Unrecognised package option for ".__PACKAGE__.": $k\n";
                }
            }
            elsif (ref($v)) {
                if (my $handler= $import_handler_ref{$k}) {
                    $handler->($v);
                    $i++;
                }
                else {
                    croak "Error: Unrecognised package option for ".__PACKAGE__.": $k\n";
                }
            }
            else {
                push @super_param, $k;
            }
        }
        else {
            push @super_param, $k;
        }
        $i++;
    }

    &Exporter::import($pack,@super_param);

    %type_spec= type_spec();
}

######################################################################
# Tools

sub my_dumper($)
{
    my ($x)= @_;

    my $d= Data::Dumper->new([$x],['x']);
    $d->Terse(1);
    $d->Purity(1);
    $d->Indent(1);

    my $s= $d->Dump;
    return $s
        if length($s) <= 400;

    return substr($s,0,400).'...';
}

# longmess gives me: bizarre copy of hash.  So confess does not work.
# Don't ask me why, I spent some time to debug this, but now I am
# sick of it.  So here's my primitive version:
sub my_longmess()
{
    my $i= 2;
    my @mess= ();
    while (my ($pack, $file, $line, $function)= caller($i)) {
        push @mess, "\t$file:$line: ${pack}::${function}\n";
        $i++;
    }
    return "Call Stack:\n".join('', reverse @mess);
}

sub my_confess(;$)
{
    die my_longmess.'DIED: '.($_[0] || 'Error');
}

######################################################################
# Non-trivial access to module variables:

sub get_quote_val()
{
    return
        $quote_val ||
        $quote_val_default ||
        do {
            croak "Error: No quote() function set.\n".
                  "\tUse ".__PACKAGE__."::quote() or ".__PACKAGE__."::dbh().\n";
        };
}

sub get_quote_id()
{
    return
        $quote_id ||
        $quote_id_default ||
        do {
            croak "Error: No quote_identifier() function set.\n".
                  "\tUse ".__PACKAGE__."::quote_identifier() or ".__PACKAGE__."::dbh().\n";
        };
}

######################################################################
# Recursive Descent parser:

# This is pure theory, because it will probably not occur, but:
#
# Assume:
#     not b + c       == not (b + c)        ; just like in SQL
#     a * b + c       == (a * b) + c
#
# =>  a * not b + c   == (a * not b) + c    ; illegal in SQL for another reason, but
#                                           ; still.  Assume it was ok and numeric
#                                           ; and boolean could be mixed at will.
#
# =>  parsing of the + sign is influenced not only by the immediate predecessor
#     operator 'sin', but also by '*'.
#
# This is currently not so.  Instead a * not b + c is parsed as a * not(b + c).
# I checked this with the Perl parser, which does the same:
#
#    my $a= 1 && not 0 || 1;   # ==> $a == 0
#
# Anyway, precedences are currently disabled, because of so much confusion, and
# particularly because of different precedences of the = operator in different
# positions.

use constant ASSOC_NON   => undef;
use constant ASSOC_LEFT  => -1;
use constant ASSOC_RIGHT => +1;

sub make_op($$;%)
{
    my ($value, $type, %opt)= @_;
    my $read_value= $opt{read_value} || $value;
    my $read_type=  $opt{read_type}  || $type;
    my $result= {
        read_value => $read_value,
        value      => $value,
        value2     => $opt{value2},             # for infix3
        read_type  => $read_type,               # how to parse?
        type       => $type,                    # how to print?
        result0    => $opt{result0},            # for 'infix()' operators invoked with 0 arguments
                                                # if undef => error to invoke with 0 arguments
        prec       => $opt{prec},
        assoc      => $opt{assoc},
        rhs        => $opt{rhs} || 'expr',
        rhs_map    => $opt{rhs_map} || {},
        comparison => $opt{comparison},         # for checking ANY/SOME and ALL
        dialect    => $opt{dialect} || {},
        accept     => $opt{accept},
        allow_when => $opt{allow_when},
    };
    lock_hash %$result;
    return $result;
}

sub declare_op($$;%)
{
    my ($value, $type, %opt)= @_;
    my $result= make_op($value, $type, %opt);
    return ($result->{read_value} => $result);
}

# There are two ways of normalising a functor:
#   (a) Accepting a secondary form for an otherwise standard, and widely supported
#       functor.  Example: the power function.  The std say it's called 'POWER',
#       and this is how we want to always normalise it.  To accept the MySQL form
#       with infixed ^, use the read_value attribute:
#
#           declare_op('POWER', 'funcall', ... read_value => '^');
#
#       The 'dialect' hash keys should not defined were because there's a perfect
#       normalisation for all dialects and accepting ^ is only a convenience.
#
#       These normalisations will *always* be done.
#
#   (b) Translating between non-standard or unavailable operators: here, we need
#       to know which dialect we produce.  It we don't, we keep what the user
#       wrote and pass the syntax on as is.  For translation, use the 'dialect'
#       hash table to define how to write the operator in different output modes.
#       if the output more is not found, the operator will not be touched:
#
#           declare_op('||', 'infix()', ...
#               dialect => {
#                   mysql => make_op('CONCAT', 'funcall')
#               }
#           ),
#
#       If the current print dialect is not found, nothing is changed, otherwise
#       the settings are taken from the corresponding hash entry.  If a '-default'
#       is given, then that one is used for default normalisation.
#       If the value of a hash entry is 1 instead of a ref(), then the functor
#       is not normalised for that dialect.
#
# For reducing input acception, use the 'accept' list: e.g. to accept the
# XOR operator only in MySQL and Postgres modes, use:
#
#           declare_op('XOR', 'infix()', ... accept => [ 'mysql', 'postgresql' ]);
#
# ONLY restrict the input syntax if the input cannot be normalised in a
# standard way.  Currently, we have no strict input mode: we only reject what
# cannot be rectified, regardless of %read_dialect, and that's the rule for now.
#
# Also note: you cannot freely switch type, but only if the number of
# parameters of the write type subsumes those of the read type:
#
#                  min      max
#     funcall      0        undef
#     funcall1col  1        1        # one param which is a column name
#     infix()      0/1      undef    # min depends on whether result0 is set
#     prefix       1        1
#     prefixn      1        1        # never parens around param
#     prefix1      1        1        # disallows point-wise application
#     suffix       1        1
#     infix2       2        2
#     infix23      2        3
#     infix3       3        3
#
# Note that all used symbolic operators must be known to token_scan_rec(),
# otherwise they are not correctly extracted from the input stream.

#
# Missing:
#
#     & | ~ (bit operations in MySQL)
#
#     ::    CAST (or TREAT?) in PostgreSQL
#

# If the type is found in the following table, stringification will be
# handled by _prefix() and _suffix().  Otherwise, the compiled Perl
# code will already contain the logic of how to build the SQL command.
my %functor_kind= (
    'infix()'  => 'suffix',
    'infix2'   => 'suffix',
    #'infix23' => 'suffix',  # complex syntax, cannot be changed later, see funcsep
    #'infix3'  => 'suffix',  # complex syntax, cannot be changed later, see funcsep

    'funcall'  => 'prefix',
    #'funcsep' => 'prefix',  # complex syntax, currently not supported

    # Not built via _suffix() or _prefix():
    #
    # prefixn

    'suffix'   => 'suffix',  # applied point-wise, different from funcall
    'prefix'   => 'prefix',  # applied point-wise, different from funcall
    'funcall1' => 'prefix',  # applied point-wise, different from funcall
    'prefix()' => 'prefix',  # not applied point-wise
);
my %functor_suffix= ( # for functors read in infix or suffix notation
    # aliasses:
    '==' => '=',
    '!=' => '<>',

    # infix2 and infix():
    declare_op('POWER', 'funcall', prec => 80, assoc => ASSOC_RIGHT,
                                read_value => '**', read_type => 'infix2'), # Oracle
    #declare_op('POWER', 'funcall', prec => 80, assoc => ASSOC_RIGHT,
    #                            read_value => '^', read_type => 'infix2'), # not MySQL
    #declare_op('POWER', 'funcall', prec => 80, assoc => ASSOC_RIGHT
    #                           read_value => ':', read_type => 'infix2'),  # Postgres??

    # bitwise operators:
    declare_op('^', 'infix()', result0 => 0,
                               assoc => ASSOC_LEFT,
                               dialect => {
                                   oracle => make_op('BITXOR', 'funcall'),
                               }),

    declare_op('|', 'infix()', result0 => 0,
                               assoc => ASSOC_LEFT,
                               dialect => {
                                   oracle => make_op('BITOR', 'funcall'),
                               }),

    declare_op('&', 'infix()', assoc => ASSOC_LEFT,
                               dialect => {
                                   oracle => make_op('BITAND', 'funcall'),
                               }),

    # others:
    declare_op('*',   'infix()', prec => 70, assoc => ASSOC_LEFT, result0 => 1),
    declare_op('/',   'infix2',  prec => 70, assoc => ASSOC_LEFT),

    declare_op('MOD', 'funcall', prec => 70, assoc => ASSOC_NON,
                                 read_value => '%', read_type  => 'infix2',), # MySQL, Postgres

    declare_op('+',   'infix()', prec => 60, assoc => ASSOC_LEFT, result0 => 0),
    declare_op('-',   'infix2',  prec => 60, assoc => ASSOC_LEFT),

    declare_op('=',   'infix2',  prec => 50, assoc => ASSOC_NON, comparison => 1, allow_when => 1),
    declare_op('<>',  'infix2',  prec => 50, assoc => ASSOC_NON, comparison => 1, allow_when => 1),
    declare_op('<',   'infix2',  prec => 50, assoc => ASSOC_NON, comparison => 1, allow_when => 1),
    declare_op('>',   'infix2',  prec => 50, assoc => ASSOC_NON, comparison => 1, allow_when => 1),
    declare_op('<=',  'infix2',  prec => 50, assoc => ASSOC_NON, comparison => 1, allow_when => 1),
    declare_op('>=',  'infix2',  prec => 50, assoc => ASSOC_NON, comparison => 1, allow_when => 1),

    declare_op('AND', 'infix()', prec => 30, assoc => ASSOC_LEFT, result0 => 1),
    declare_op('OR',  'infix()', prec => 30, assoc => ASSOC_LEFT, result0 => 0),

    declare_op('XOR', 'infix()', prec => 30, assoc => ASSOC_LEFT, result0 => 0,
                                 accept => [ 'mysql', 'postgresql', 'oracle']),

    declare_op('||',  'infix()', assoc => ASSOC_LEFT, result0 => '',
                                 dialect => {
                                     mysql => make_op('CONCAT','funcall',result0 => ''),
                                 }),

    declare_op('OVERLAPS',  'infix2', allow_when => 1),

    declare_op('IS DISTINCT FROM', 'infix2', allow_when => 1),

    declare_op('IS OF',     'infix2', rhs => 'type_list', allow_when => 1),
    declare_op('IS NOT OF', 'infix2', rhs => 'type_list', allow_when => 1),

    declare_op('IN',        'infix2', rhs => 'expr_list', allow_when => 1),
    declare_op('NOT IN',    'infix2', rhs => 'expr_list', allow_when => 1),

    # infix23
    declare_op('NOT SIMILAR TO', 'infix23', value2 => 'ESCAPE', allow_when => 1),
    declare_op('SIMILAR TO',     'infix23', value2 => 'ESCAPE', allow_when => 1),

    declare_op('LIKE',           'infix23', value2 => 'ESCAPE', allow_when => 1),
    declare_op('NOT LIKE',       'infix23', value2 => 'ESCAPE', allow_when => 1),

    declare_op('CLIKE',          'infix23', value2 => 'ESCAPE', allow_when => 1),
    declare_op('NOT CLIKE',      'infix23', value2 => 'ESCAPE', allow_when => 1),

    # infix3
    declare_op('BETWEEN',                'infix3', value2 => 'AND', prec => 31, allow_when => 1),
    declare_op('BETWEEN SYMMETRIC',      'infix3', value2 => 'AND', prec => 31, allow_when => 1),
    declare_op('BETWEEN ASYMMETRIC',     'infix3', value2 => 'AND', prec => 31, allow_when => 1),
    declare_op('NOT BETWEEN',            'infix3', value2 => 'AND', prec => 31, allow_when => 1),
    declare_op('NOT BETWEEN SYMMETRIC',  'infix3', value2 => 'AND', prec => 31, allow_when => 1),
    declare_op('NOT BETWEEN ASYMMETRIC', 'infix3', value2 => 'AND', prec => 31, allow_when => 1),

    # suffix
    declare_op('IS NORMALIZED',     'suffix', prec => 45, allow_when => 1),
    declare_op('IS NOT NORMALIZED', 'suffix', prec => 45, allow_when => 1),
    declare_op('IS TRUE',           'suffix', prec => 45, allow_when => 1),
    declare_op('IS NOT TRUE',       'suffix', prec => 45, allow_when => 1),
    declare_op('IS FALSE',          'suffix', prec => 45, allow_when => 1),
    declare_op('IS NOT FALSE',      'suffix', prec => 45, allow_when => 1),
    declare_op('IS NULL',           'suffix', prec => 45, allow_when => 1),
    declare_op('IS NOT NULL',       'suffix', prec => 45, allow_when => 1),
    declare_op('IS UNKNOWN',        'suffix', prec => 45, allow_when => 1),
    declare_op('IS NOT UNKNOWN',    'suffix', prec => 45, allow_when => 1),
    declare_op('IS A SET',          'suffix', prec => 45, allow_when => 1),
    declare_op('IS NOT A SET',      'suffix', prec => 45, allow_when => 1),
);

my %functor_prefix= ( # functors read in prefix notation:
    declare_op('+',   'prefix1', prec => 90, read_type => 'prefix'), # prefix1 disallows list context
    declare_op('-',   'prefix',  prec => 90),
    declare_op('NOT', 'prefix',  prec => 40),

    declare_op('~', 'prefix',   dialect => {                                   # MySQL
                                    oracle => make_op('BITNOT', 'funcall'),     # funcall1:
                                }),

    # Allow AND and OR as prefix operators.
    # Because - and + are already defined, they are not translated this way.
    declare_op('AND', 'prefix()',, read_type => 'prefix',
               dialect => {
                   -default => make_op('AND', 'infix()', result0 => 1),
               }),
    declare_op('OR', 'prefix()', read_type => 'prefix',
               dialect => {
                   -default => make_op('OR', 'infix()', result0 => 0),
               }),

    declare_op('BITXOR', 'funcall', assoc => ASSOC_LEFT,
                                dialect => {
                                    mysql => make_op('^', 'infix()'),
                                }),
    declare_op('BITOR', 'funcall', assoc => ASSOC_LEFT,
                                dialect => {
                                    mysql => make_op('|', 'infix()'),
                                }),
    declare_op('BITAND', 'funcall', assoc => ASSOC_LEFT,
                                dialect => {
                                    mysql => make_op('&', 'infix()'),
                                }),

    declare_op('POWER',  'funcall',
               read_value => 'POW'), # MySQL

    declare_op('CONCAT', 'funcall',
               dialect => {
                   'mysql'  => undef, # keep
                   -default => make_op('||', 'infix()', result0 => ''),
               }),

    declare_op('CONCATENATE', 'funcall',
               dialect => {
                   'mysql'  => make_op('CONCAT', 'funcall'),
                   -default => make_op('||',     'infix()', result0 => ''),
               }),

    declare_op('VALUES', 'funcall', accept => [ 'mysql' ], read_type => 'funcall1col'),

    # Funcalls with special separators instead of commas (who invented these??):
    # NOTE: These *must* start with (, otherwise they are even more special
    #       than funcsep.  Note that because of the hilarious syntax of UNNEST,
    #       the closing paren is included in the rhs pattern.
    declare_op('CAST', 'funcsep',
                rhs => [ \q{expr}, 'AS', \q{type}, ')' ]),

    declare_op('TREAT', 'funcsep',
                rhs => [ \q{expr}, 'AS', \q{type}, ')' ]),

    declare_op('TRANSLATE', 'funcsep',
                rhs => [ \q{expr}, 'AS', \q{transliteration}, ')' ]),

    declare_op('POSITION','funcsep',
                rhs => [ \q{string_expr}, 'IN', \q{expr},    # hack for 'IN' infix op.
                         [ 'USING', \q{char_unit} ], ')' ]),

    declare_op('SUBSTRING', 'funcsep',
                rhs => [ \q{expr}, 'FROM', \q{expr},
                         [ 'FOR', \q{expr}], [ 'USING', \q{char_unit} ], ')' ]),

    declare_op('CHARACTER_LENGTH', 'funcsep',
                rhs => [ \q{expr}, [ 'USING', \q{char_unit} ], ')' ]),

    declare_op('CONVERT', 'funcsep',
                rhs => [ \q{expr}, 'USING', \q{transcoding}, ')' ]),

    declare_op('OVERLAY', 'funcsep',
                rhs => [ \q{expr}, 'PLACING', \q{expr}, 'FROM', \q{expr},
                         [ 'FOR', \q{expr} ], [ 'USING', \q{char_unit} ], ')' ]),

    declare_op('EXTRACT', 'funcsep',
                rhs => [ \q{expr}, 'FROM', \q{expr}, ')']),

    declare_op('UNNEST', 'funcsep',
                rhs => [ \q{expr}, ')', [ 'WITH ORDINALITY' ] ]),
);

my %functor_special= ( # looked up manually, not generically.
    declare_op('ANY',     'prefixn'),  # n=no paren.  I know, it's lame.
    declare_op('SOME',    'prefixn'),
    declare_op('ALL',     'prefixn'),
    declare_op('DEFAULT', 'funcall', accept => [ 'mysql' ], read_type => 'funcall1col'),
        # Special functor because it collides with DEFAULT pseudo
        # constant, so it needs extra care during parsing.
);

# Reserved words from SQL-2003 spec:
my @reserved= qw(
    ADD ALL ALLOCATE ALTER AND ANY ARE ARRAY AS ASENSITIVE ASYMMETRIC
    AT ATOMIC AUTHORIZATION BEGIN BETWEEN BIGINT BINARY BLOB BOOLEAN
    BOTH BY CALL CALLED CASCADED CASE CAST CHAR CHARACTER CHECK CLOB
    CLOSE COLLATE COLUMN COMMIT CONNECT CONSTRAINT CONTINUE
    CORRESPONDING CREATE CROSS CUBE CURRENT CURRENT_DATE
    CURRENT_DEFAULT_TRANSFORM_GROUP CURRENT_PATH CURRENT_ROLE
    CURRENT_TIME CURRENT_TIMESTAMP CURRENT_TRANSFORM_GROUP_FOR_TYPE
    CURRENT_USER CURSOR CYCLE DATE DAY DEALLOCATE DEC DECIMAL DECLARE
    DEFAULT DELETE DEREF DESCRIBE DETERMINISTIC DISCONNECT DISTINCT
    DOUBLE DROP DYNAMIC EACH ELEMENT ELSE END END-EXEC ESCAPE EXCEPT
    EXEC EXECUTE EXISTS EXTERNAL FALSE FETCH FILTER FLOAT FOR FOREIGN
    FREE FROM FULL FUNCTION GET GLOBAL GRANT GROUP GROUPING HAVING
    HOLD HOUR IDENTITY IMMEDIATE IN INDICATOR INNER INOUT INPUT
    INSENSITIVE INSERT INT INTEGER INTERSECT INTERVAL INTO IS
    ISOLATION JOIN LANGUAGE LARGE LATERAL LEADING LEFT LIKE LOCAL
    LOCALTIME LOCALTIMESTAMP MATCH MEMBER MERGE METHOD MINUTE MODIFIES
    MODULE MONTH MULTISET NATIONAL NATURAL NCHAR NCLOB NEW NO NONE NOT
    NULL NUMERIC OF OLD ON ONLY OPEN OR ORDER OUT OUTER OUTPUT OVER
    OVERLAPS PARAMETER PARTITION PRECISION PREPARE PRIMARY PROCEDURE
    RANGE READS REAL RECURSIVE REF REFERENCES REFERENCING RELEASE
    RETURN RETURNS REVOKE RIGHT ROLLBACK ROLLUP ROW ROWS SAVEPOINT
    SCROLL SEARCH SECOND SELECT SENSITIVE SESSION_USER SET SIMILAR
    SMALLINT SOME SPECIFIC SPECIFICTYPE SQL SQLEXCEPTION SQLSTATE
    SQLWARNING START STATIC SUBMULTISET SYMMETRIC SYSTEM SYSTEM_USER
    TABLE THEN TIME TIMESTAMP TIMEZONE_HOUR TIMEZONE_MINUTE TO
    TRAILING TRANSLATION TREAT TRIGGER TRUE UNION UNIQUE UNKNOWN
    UNNEST UPDATE USER USING VALUE VALUES VARCHAR VARYING WHEN
    WHENEVER WHERE WINDOW WITH WITHIN WITHOUT YEAR
);
my %reserved= ( map { $_ => 1 } @reserved );

sub double_quote_perl($)
{
    my ($s)= @_;
    $s =~ s/([\\\"\$\@])/\\$1/g;
    $s =~ s/\t/\\t/g;
    $s =~ s/\n/\\n/g;
    $s =~ s/\r/\\r/g;
    $s =~ s/([\x00-\x1f\x7f])/sprintf("\\x%02x", ord($1))/gsex;
    return "\"$s\"";
}

sub single_quote_perl($)
{
    my ($s)= @_;
    $s =~ s/([\\\'])/\\$1/g;
    return "'$s'";
}

sub quote_perl($)
{
    my ($s)= @_;
    return 'undef' unless defined $s;
    return ($s =~ /[\x00-\x1f\x7f\']/) ? double_quote_perl($s) : single_quote_perl($s);
}

sub skip_ws($)
{
    my ($lx)= @_;
    my $s= $lx->{text_p};

    for(;;) {
        if ($$s =~ /\G\n/gc) {         # count lines
            $lx->{line}++;
            next;
        }
        next if $$s =~ /\G[^\n\S]+/gc; # other space but newline
        next if $$s =~ /\G\#[^\n]*/gc; # comments
        last;
    }
}

sub token_new($$;$%)
{
    my ($lx, $kind, $value, %opt)= @_;
    my_confess unless $kind;
    my $t= {
        lx          => $lx,
        line        => $lx->{line_before},      # start of token: rel. line num. in $lx->{text_p}
        line_after  => $lx->{line},
        pos         => $lx->{pos_before},       # start of token: string position in $lx->{text_p}
        pos_after   => pos(${ $lx->{text_p} }), # end   of token: string position in $lx->{text_p}
        kind        => $kind,
        value       => $value,
        str         => $opt{str},
        type        => $opt{type},              # interproc: 'variable', 'block', 'num', etc.
        perltype    => $opt{perltype},          # interproc: 'array', 'scalar', 'hash', 'list'
        prec        => $opt{prec},
        error       => $opt{error},
    };
    lock_keys %$t;
    return $t;
}

sub token_describe($)
{
    my ($t)= @_;

    my %opt= ();
    for my $key(qw(value str prec)) {
        if (defined $t->{$key}) {
            $opt{$key}= $t->{$key};
        }
    }
    for my $key(qw(perltype type)) {
        if ($t->{$key}) {
            $opt{$key}= $t->{$key};
        }
    }

    if (scalar(keys %opt)) {
        return "$t->{kind} (".
                   join(", ",
                       map {
                           my $k= $_;
                           "$k=".quote_perl($opt{$k})
                       }
                       sort keys %opt
                   ).
               ")";
    }
    else {
        return quote_perl($t->{kind});
    }
}

sub error_new($$$)
{
    my ($lx, $value, $expl)= @_;
    return token_new ($lx, 'error', $value, str => $expl, error => 1);
}

sub syn_new($$$)
{
    my ($lx, $type, $name)= @_;
    return token_new ($lx, $name, undef, perltype => '', type => $type);
        # perltype and type are for * and ?, which can occur as
        # syntactic values in expressions.
}

sub interpol_new($$$$$)
{
    my ($lx, $interpol, $value, $type, $perltype)= @_;
    return token_new ($lx, "interpol$interpol", $value,
               type  => $type,
               perltype => $perltype
           );
}

sub token_scan_codeblock($$)
{
    my ($lx, $interpol)= @_;
    my $s= $lx->{text_p};

    # Text::Balanced actually honours and updates pos($$s), so we can
    # interface directly:
    my ($ex)= Text::Balanced::extract_codeblock($$s, '{}()[]');
    return error_new($lx, 'codeblock', $@->{error})
        if $@;

    $lx->{line}+= ($ex =~ tr/\n//);
    return interpol_new ($lx, $interpol, "do$ex", 'block', 'list');
        # $ex contains {}, so do$ex is sound.
}

sub token_scan_variable($$$)
{
    my ($lx, $interpol, $perltype)= @_;
    my $s= $lx->{text_p};

    my ($ex)= Text::Balanced::extract_variable($$s);
    return error_new($lx, 'variable', $@->{error})
        if $@;

    $lx->{line}+= ($ex =~ tr/\n//);
    return interpol_new ($lx, $interpol, $ex, 'variable', $perltype);
}

sub token_scan_delimited($$$)
{
    my ($lx, $interpol, $delim)= @_;
    my $s= $lx->{text_p};

    my ($ex)= Text::Balanced::extract_delimited($$s, $delim);
    return error_new($lx, 'delimited', $@->{error})
        if $@;

    $lx->{line}+= ($ex =~ tr/\n//);
    return interpol_new ($lx, $interpol, $ex, 'string', 'scalar');
}

sub token_num_new($$$)
{
    my ($lx, $interpol, $value)= @_;
    return interpol_new ($lx, $interpol || 'Expr', $value, 'num', 'scalar');
}

sub ident_new($$)
{
    my ($lx, $value)= @_;
    return token_new ($lx, 'ident', $value, perltype => 'scalar');
}

sub keyword_new($$) # either syn or function
{
    my ($lx, $name)= @_;
    if ($reserved{$name}) {
        return syn_new($lx, 'reserved', $name);
    }
    else {
        return syn_new($lx, 'keyword', $name);
    }
}

sub replace_synonym($)
{
    my ($name)= @_;
    while (my $syn= $synonym{$name}) {
        $name= $syn;
    }
    return $name;
}

sub multi_token_new($$)
{
    my ($lx, $name)= @_;
    my $s= $lx->{text_p};

    $name= replace_synonym($name);
    if (my $tree= $multi_token{$name}) {
        SUB_TOKEN: for (;;) {
            skip_ws($lx);

            my $p= pos($$s);
            last SUB_TOKEN unless $$s =~ /\G ([A-Z][A-Z_0-9]*)\b /gcsx;
            my $sub_name= $1;

            $sub_name= replace_synonym($sub_name);
            $tree= $tree->{$sub_name};
            unless ($tree) {
                pos($$s)= $p; # unscan rejected keyword
                last SUB_TOKEN;
            }

            $name.= " $sub_name";
            $name= replace_synonym($name);
        }
        return syn_new ($lx, 'keyword', $name); # never a function, always a keyword
    }
    else {
        return keyword_new ($lx, $name);
    }
}

sub good_interpol_type($);

sub token_scan_rec($$);
sub token_scan_rec($$)
{
    my ($lx, $interpol)= @_;
    my $s= $lx->{text_p};

    skip_ws($lx);

    $lx->{pos_before}=  pos($$s);
    $lx->{line_before}= $lx->{line}; # strings may contain \n, so this may change.

    # idents: distinguished by case:
    return multi_token_new ($lx, $1) if $$s =~ /\G ([A-Z][A-Z_0-9]*)\b /gcsx;
    return ident_new ($lx, $1)       if $$s =~ /\G ([a-z][a-z_0-9]*)\b /gcsx;
    return ident_new ($lx, $1)       if $$s =~ /\G \`([^\n\\\`]+)\`      /gcsx;

    if ($$s =~ /\G ([A-Z][a-z][A-Za-z0-9]*)\b /gcsx) {
        # type specifiers change the token context itself, so we recurse here.
        my $interpol_new= $1;
        return error_new ($lx, $interpol_new, 'unknown type cast')
            unless good_interpol_type($interpol_new);

        return error_new ($lx, $interpol_new, 'duplicate type case')
            if $interpol;

        my $tok= token_scan_rec ($lx, $interpol_new);
        return $tok if $tok->{error};

        return error_new ($lx, $tok->{kind},
                   "Expected Perl interpolation after type cast to '$interpol_new'")
            unless $tok->{kind} =~ /^interpol/;

        return $tok;
    }

    return error_new ($lx, $1, 'illegal identifier: neither keyword nor name')
        if $$s =~ /\G ([A-Za-z_][A-Za-z_0-9]*) /gcsx;

    # Numbers, strings, and embedded Perl code are handled alike: they will be
    # extracted as is and evaluated as is.  This way, much of the embedded SQL
    # syntax is just like in Perl, and you don't face surprises.  The uniform
    # kind of this token is 'interpol'.  The precise type is stored in the
    # str attribute, in case anyone wants to know later.

    # numbers:
    ## ints:
    return token_num_new ($lx, $interpol, hex($1)) if $$s =~ /\G 0x([0-9a-f_]+)\b /gcsix;
    return token_num_new ($lx, $interpol, oct($1)) if $$s =~ /\G (0b[0-1_]+)\b    /gcsx;
    return token_num_new ($lx, $interpol, $1)      if $$s =~ /\G ([1-9][0-9_]*)\b /gcsx;
    return token_num_new ($lx, $interpol, oct($1)) if $$s =~ /\G ([0][0-7_]*)\b   /gcsx;
         # Note: oct() interprets 0b as binary, and there's not bin().

    return token_num_new ($lx, $interpol, $1)      if $$s =~ /\G ([1-9][0-9_]*)(?=[KMG]\b) /gcsx;
         # special case for , which we split in two.

    ## floats:
    return token_num_new ($lx, $interpol, $1)
        if $$s =~ /\G( (?= [1-9]             # not empty, but numeric
                         | [.][0-9]
                       )
                       (?: [1-9] [0-9_]* )?
                       (?: [.]   [0-9_]+ )?
                       (?: e[-+] [0-9_]+ )?\b )/gcsix;

    return error_new ($lx, $1, 'not a number')
        if $$s =~ /\G ([0-9][a-z_0-9]*) /gcsix;

    # embedded Perl:
    return token_scan_variable  ($lx, $interpol, 'scalar') if $$s =~ /\G (?= \$\S      ) /gcsx;
    return token_scan_variable  ($lx, $interpol, 'array')  if $$s =~ /\G (?= \@\S      ) /gcsx;
    return token_scan_variable  ($lx, $interpol, 'hash')   if $$s =~ /\G (?= \%[^\s\d] ) /gcsx;
    return token_scan_codeblock ($lx, $interpol)           if $$s =~ /\G (?= \{        ) /gcsx;
    return token_scan_delimited ($lx, $interpol, $1)       if $$s =~ /\G (?= [\'\"]    ) /gcsx;

    # symbols:
    return syn_new ($lx, 'symbol', $1)
        if $$s =~ /\G(
                       ==   | !=   | <= | >=
                    |  \&\& | \|\| | \! | \^\^
                    |  \*\* | \^
                    |  [-+*\/;:,.()\[\]{}<=>?\%\&\|]
                    )/gcsx;

    # specials:
    return error_new ($lx, $1, 'Unexpected character') if $$s =~ /\G(.)/gcs;
    return syn_new   ($lx, 'special', '');
}

sub token_scan($)
{
   my ($lx)= @_;
   my $t= token_scan_rec($lx, '');
   #print STDERR "DEBUG: scanned: ".token_describe($t)."\n";
   return $t;
}

sub lexer_shift($)
# returns the old token kind
{
    my ($lx)= @_;
    my $r= $lx->{token}{kind};
    $lx->{token}= token_scan($lx);
    return $r;
}

sub lexer_new($$$)
{
    my ($s, $file, $line_start)= \(@_);
    my $lx= {
        text_p      => $s,
        token       => undef,
        file        => $$file,
        line_start  => $$line_start,  # relative start line of text in file
        line        => 1,             # current line (after current token)
        prev_line   => 1,             # end line of previous token (before white space)
        line_before => 1,             # start line of current token (after white space)
        pos_before  => 0,             # pos($$s) at start of current token
        error       => undef,
    };
    lock_keys %$lx;
    lexer_shift($lx);
    return $lx;
}

sub flatten($);
sub flatten($)
{
    my ($x)= @_;
    return $x
        unless ref($x);

    return map { flatten($_) } @$x
        if ref($x) eq 'ARRAY';

    return flatten([ sort keys %$x ])
        if ref($x) eq 'HASH';

    my_confess "No idea how to flatten $x";
}

sub flatten_hash($);
sub flatten_hash($)
{
    my ($x)= @_;
    return map {$_ => 1} flatten $x;
}

sub looking_at_raw($$)
{
    my ($lx, $kind)= @_;
    return unless $kind;

    my %kind= flatten_hash $kind;
    return $lx->{token}{kind}
        if $kind{$lx->{token}{kind}};

    return; # Don't return undef, but an empty list, so in array context, we get 0 results
            # This principle is used everywhere in this file.  In scalar context, we still
            # get undef from am empty list.
}

sub looking_at($$;$)
{
    my ($lx, $kind, $do_shift)= @_;
    if (my $x= looking_at_raw($lx,$kind)) {
        lexer_shift($lx) if $do_shift;
        return $x;
    }
    return;
}

sub english_or(@)
{
    my $map= undef;
    $map= shift
        if ref($_[0]) eq 'CODE';

    my @l= sort map flatten($_), @_;

    @l= map { $map->($_) } @l
        if $map;

    return 'nothing'         if scalar(@l) == 0;
    return $l[0]             if scalar(@l) == 1;
    return "$l[0] or $l[1]" if scalar(@l) == 2;

    return join(", ", @l[0..$#l-1], "or $l[-1]");
}

sub expect($$;$)
{
    my ($lx, $kind, $do_shift)= @_;
    if (my $x= looking_at($lx, $kind, $do_shift)) {
        return $x;
    }
    elsif (my $err= lx_token_error($lx)) {
        $lx->{error}= $err;
    }
    else {
        $lx->{error}= 'Expected '.(english_or \"e_perl, $kind).
                      ', but found '.token_describe($lx->{token});
    }
    return;
}

# Parse Functions
# ---------------
# These functions return either:
#
#    undef  - in case of a syntax error
#             $lx->{error} will contain more information
#
#    [...]  - In case of a sequence of things (parse_list)
#
#    {...}  - In case of a successfully parsed item.
#             The hash contains a 'type' plus additional
#             slots depending on what was parsed.
#
#             These things can be created with create().
#
#             Note that tokens may be used here, too.
#
# Note: you cannot *try* to parse something and in case of a
# failure, do something else, because pos() and the $lx->{token}
# will have changed.  E.g. when calling parse_list, you *must*
# pass all things that might end a list instead of reading up
# to an error.  That's what the look-ahead token is for!

sub create($$@)
{
    my ($lx, $kind, @more)= @_;
    my $r= {
        (ref($kind) ?
            (
               kind => $kind->[0],
               type => $kind->[1]
            )
        :   (
               kind => $kind,
               type => ''
            )
        ),
        line => $lx->{token}{line},
        map { $_ => undef } @more,
    };
    lock_keys %$r;
    return $r;
}

# special creates that occur frequently:
sub create_Expr($)
{
    my ($lx)= @_;
    return create ($lx, 'Expr', qw(maybe_check token functor arg switchval otherwise));
}

sub parse_list($$$$;$)
# We allow multiple separators and also lists beginning with
# separators, but we do not allow them to end with the same separator.
# If a separator is encountered, we assume that the list continues.

# There is one exception: if you specify an $end, then before the
# $end, there may be too many separators.  This is handy for
# statements that often end in ; just before the closing }.

#  is implicit treated as an $end in all invocations.

# A token matching $end is not shifted.
#
# If $end is given, lists may be empty.  Otherwise, they may
# not be.

# The result is either a list reference or undef in case
# of an error.  $lx->{error} will then be set accordingly.
{
    my ($result, $lx, $parse_elem, $list_sep, $end)= @_;

    my %pos= ();
    ELEMENT: {do {
        do {
            # check that we have no infinite loop:
            my $p= pos(${ $lx->{text_p} });
            die "BUG: pos() not shifted in list" if $pos{$p}++;

            # check for end:
            last ELEMENT if looking_at($lx, $end);
            last ELEMENT if looking_at($lx, '');

            # allow too many separators:
        } while (looking_at($lx, $list_sep, SHIFT));

        # parse one element:
        return unless
            my @result1= $parse_elem->($lx);

        # append that element to result:
        push @$result, @result1;

        # check whether the list continues:
    } while (looking_at($lx, $list_sep, SHIFT))};

    return $result;
}

sub parse_try_list($$$)
# List without delimiter, but sequenced prefix-marked elements.
# For example: a list of JOIN clauses.
#
# The parsers for such elements must handle try-parsing, i.e.,
# returning undef while not setting $lx->{error} to indicate
# that they are not looking at a prefix-marked element.
{
    my ($result, $lx, $parse_elem)= @_;

    while (my @result1= $parse_elem->($lx)) {
        push @$result, @result1;
    }

    return if $lx->{error};
    return $result;
}

sub find_ref(\%$)
# Finds a ref-valued value in a hash table, allowing redirections.
# If nothing is found, '' is returned (which would never be returned
# otherwise, because it is neither a ref(), nor undef).
{
    my ($hash, $key)= @_;
    my $result= undef;
    local $SIG{__DIE__}= \&my_confess;
    if (exists $hash->{$key}) {
        $result= $hash->{$key}
    }
    elsif (exists $hash->{-default}) {
        $result= $hash->{-default}
    }
    else {
        return '';
    }

    until (ref($result) || !defined $result) {      # No infinite loop protection!
        die "'$result' key not in hash table"
            unless exists $hash->{$result};
        $result= $hash->{$result};
    }

    return $result;
}

sub switch($%) # waiting for Perl 5.10: given/when/default
{
    my ($value, %case)= @_;
    if (my $code= find_ref(%case, $value)) {
        return $code->();
    }

    my_confess "Expected ".(english_or \"e_perl, \%case).", but found '$value'";
}

sub lx_token_error($)
{
    my ($lx)= @_;
    if ($lx->{token}{error}) {
        return 'Found '.
               quote_perl($lx->{token}{value}).': '.
               $lx->{token}{str};
    }
    return;
}

sub parse_choice($%)
{
    my ($lx, %opt)= @_;
    return switch ($lx->{token}{kind},
        -default => sub {
            if (my $err= lx_token_error($lx)) { # already have an error message.
                $lx->{error}= 'In '.(caller(3))[3].": $err";
            }
            elsif (scalar(keys %opt) > 10) {
                $lx->{error}= 'In '.(caller(3))[3].': '.
                              ' Unexpected '.token_describe($lx->{token});
            }
            else {
                $lx->{error}= 'In '.(caller(3))[3].': Expected '.
                              (english_or \"e_perl, \%opt).
                              ', but found '.
                              token_describe($lx->{token});
            }
            return;
        },
        %opt, # may override -default
    );
}

sub parse_plain_ident($)
{
    my ($lx)= @_;
    return parse_choice($lx,
        'interpol' => sub {
            my $r= $lx->{token};

            # If it is unambiguous, even "..." interpolation is intepreted as
            # a column name.
            #if (FORCE_STRING && $r->{type} eq 'string') {
            #    $lx->{error}=
            #        'Expected identifier, but found string: '.token_describe($r).
            #        "\n\t".
            #        "If you want to construct an identifier name, use {$r->{value}}.";
            #    return;
            #}
            #els
            if ($r->{type} eq 'num') {
                $lx->{error}=
                    'Expected identifier, but found number: '.token_describe($r).
                    "\n\t".
                    "If you want to construct an identifier name, use {$r->{value}}.";
                return;
            }

            lexer_shift($lx);
            return $r;
        },

        'interpolColumn'          => 'ident',
        'interpolTable'           => 'ident',
        'interpolCharSet'         => 'ident',
        'interpolEngine'          => 'ident',
        'interpolCollate'         => 'ident',
        'interpolConstraint'      => 'ident',
        'interpolIndex'           => 'ident',
        'interpolTranscoding'     => 'ident',
        'interpolTransliteration' => 'ident',
        '*' => 'ident',
        'ident' => sub {
            my $r= $lx->{token};
            lexer_shift($lx);
            return $r;
        },
    );
}

sub parse_ident_chain($$)
{
    my ($lx, $arr)= @_;
    return parse_list($arr, $lx, \&parse_plain_ident, '.');
}

sub check_column(@)
{
    while (scalar(@_) < 4) { unshift @_, undef; }
    my ($cat,$sch,$tab,$col)= @_;

    #return unless !defined $cat || my $cat= $cat->{
    #check_ident ('Column', $cat, $sch, $tab, $col);
}

sub parse_column($;$)
# The interpretation of the identifier chain is left to the column{1,2,3,4}
# family of functions.  It is as follows:
#
# Depending on the number of elements in the chain, the following types
# are allowed:
#
# 1 Element:
#    - Column: a fully qualified column object, maybe including
#      a table specification
#    - ColumnName: a single identifier object with a column name
#    - string: a single identifier, too, will be quoted accordingly.
#
# 2 Elements:
#    - First element: Table or string
#      Last element:  ColumnName or string
#
# more Elements:
#    - All but last element: string only
#    - Last element: ColumnName or string
{
    my ($lx, $arr)= @_;
    my $r= create ($lx, 'Column', qw(ident_chain));
    $arr||= [];
    return
        unless parse_ident_chain($lx, $arr);

    my_confess if scalar(@$arr) < 1;
    if (scalar(@$arr) > 4) {
        $lx->{error}= 'Too many parts of column identifier chain. '.
                      'Maximum is 4, found '.scalar(@$arr);
        return;
    }

    check_column(@$arr);

    $r->{ident_chain}= $arr;

    lock_keys %$r;
    return $r;
}

sub parse_schema_qualified($$)
{
    my ($lx, $kind)= @_;

    my $r= create ($lx, $kind, qw(ident_chain));
    my $arr= [];
    return
        unless parse_ident_chain($lx, $arr);

    my_confess if scalar(@$arr) < 1;
    if (scalar(@$arr) > 3) {
        $lx->{error}= 'Too many identifiers in $kind. '.
                      'Maximum is 3, found '.scalar(@$arr);
        return;
    }

    $r->{ident_chain}= $arr;

    lock_keys %$r;
    return $r;
}

sub parse_table($)
# The interpretation of the identifier chain is left to the table{1,2,3}
# family of functions.  It is as follows:
#
# Depending on the number of elements in the chain, the following types
# are allowed:
#
# 1 Element:
#    - Table:  a fully qualified table object
#    - string: a single identifier, too, will be quoted accordingly.
#
# more Elements:
#    - all elements: string
{
    my ($lx)= @_;
    return parse_schema_qualified($lx, 'Table');
}

sub parse_charset($)
{
    my ($lx)= @_;
    return parse_schema_qualified($lx, 'CharSet');
}

sub parse_constraint($)
{
    my ($lx)= @_;
    return parse_schema_qualified($lx, 'Constraint');
}

sub parse_index($)
{
    my ($lx)= @_;
    return parse_schema_qualified($lx, 'Index');
}

sub parse_collate($)
{
    my ($lx)= @_;
    return parse_schema_qualified($lx, 'Collate');
}

sub parse_transliteration($)
{
    my ($lx)= @_;
    return parse_schema_qualified($lx, 'Transliteration');
}

sub parse_transcoding($)
{
    my ($lx)= @_;
    return parse_schema_qualified($lx, 'Transcoding');
}

sub parse_engine($)
{
    my ($lx)= @_;
    return parse_schema_qualified($lx, 'Engine');
}


sub parse_column_name($)
{
    my ($lx)= @_;
    my $r= create ($lx, 'ColumnName', qw(token));

    parse_choice($lx,
        'ident' => sub {
            $r->{type}= 'ident';
            $r->{token}= $lx->{token};
            lexer_shift($lx);
        },

        'interpolColumn' => 'interpol',
        'interpol' => sub {
            $r->{type}= 'interpol';
            $r->{token}= $lx->{token};
            lexer_shift($lx);
        },
    );
    return if $lx->{error};

    lock_keys %$r;
    return $r;
}

sub parse_column_index($)
{
    my ($lx)= @_;
    my $r= create ($lx, 'ColumnIndex', qw(name length desc));

    return unless
        $r->{name}= parse_column_name($lx);

    if (looking_at($lx, '(', SHIFT)) {
        return unless
            $r->{length}= parse_limit_expr($lx)
        and expect ($lx, ')', SHIFT);
    }

    if (looking_at($lx, 'DESC', SHIFT)) {
        $r->{desc}= 1;
    }
    elsif (looking_at($lx, 'ASC', SHIFT)) {
        #ignore
    }

    lock_hash %$r;
    return $r;
}

sub parse_table_name($)
{
    my ($lx)= @_;
    my $r= create ($lx, 'TableName', qw(token));

    parse_choice($lx,
        'ident' => sub {
            $r->{type}= 'ident';
            $r->{token}= $lx->{token};
            lexer_shift($lx);
        },

        'interpolTable' => 'interpol',
        'interpol' => sub {
            $r->{type}= 'interpol';
            $r->{token}= $lx->{token};
            lexer_shift($lx);
        },
    );
    return if $lx->{error};

    lock_keys %$r;
    return $r;
}

sub parse_table_as($)
{
    my ($lx)= @_;
    my $r= create ($lx, 'TableAs', qw(table as));

    return unless
        $r->{table}= parse_table($lx);

    if (looking_at($lx, 'AS', SHIFT)) {
        return unless
            $r->{as}= parse_table_name($lx);
    }

    lock_hash %$r;
    return $r;
}

sub parse_value_or_column_into($$$)
{
    my ($lx, $r, $type)= @_;

    my $token= $lx->{token};
    lexer_shift($lx);

    if (looking_at($lx, '.')) {
        $r->{type}= 'column';
        $r->{arg}=  parse_column($lx, [ $token ]);
    }
    else {
        $r->{type}=  $type;
        $r->{token}= $token;
    }
}

sub parse_expr($;$$);
sub parse_select_stmt($);
sub parse_funcsep($$$);
sub parse_expr_post($$$$);

use constant ACTION_AMBIGUOUS => undef;
use constant ACTION_REDUCE    => -1;
use constant ACTION_SHIFT     => +1;

sub plural($;$$)
{
    my ($cnt, $sg, $pl)= @_;
    return $cnt == 1 ? (defined $sg ? $sg : '') : (defined $pl ? $pl : 's');
}

sub parse_limit_expr($)
{
    my ($lx)= @_;
    return unless
        my $limit= parse_limit_num($lx);
    my $r= create_Expr ($lx);
    $r->{type}= 'limit';
    $r->{arg}= $limit;
    lock_hash %$r;
    return $r;
}

sub parse_char_unit($)
{
    my ($lx)= @_;
    my $r= create($lx, 'CharUnit', qw(name));
    $r->{name}= expect($lx, ['CHARACTERS', 'CODE_UNITS', 'OCTETS'], SHIFT);
    lock_hash %$r;
    return $r;
}

sub parse_list_delim($$)
{
    my ($lx, $func)= @_;
    return unless
        expect($lx, '(', SHIFT)
    and my $list= parse_list([], $lx, $func, ',', ')')
    and expect($lx, ')', SHIFT);
    return $list;
}

sub parse_type_post_inner($)
{
    my ($lx)= @_;

    my $functor= undef;
    my @arg= ();
    parse_choice ($lx,
        -default => sub {
            if (my $spec= find_ref(%type_spec, $lx->{token}{kind})) {
                if ($spec->{value_list}) {
                    $functor= 'basewlist',
                    push @arg, lexer_shift($lx);
                    return unless
                        my $value_list= parse_list_delim($lx, \&parse_expr);
                    push @arg, @$value_list;
                }
                else {
                    $functor= 'base';
                    push @arg, lexer_shift($lx);
                }
            }
        },

        'UNSIGNED' => 'SIGNED',
        'SIGNED' => sub {
            $functor= 'property';
            push @arg, 'sign', lexer_shift($lx);
        },
        'DROP SIGN' => sub {
            $functor= 'property';
            push @arg, 'sign', '';
            lexer_shift($lx);
        },

        'ZEROFILL' => sub {
            $functor= 'property';
            push @arg, 'zerofill', lexer_shift($lx);
        },

        'DROP ZEROFILL' => sub {
            $functor= 'property';
            push @arg, 'zerofill', '';
            lexer_shift($lx);
        },

        'ASCII' => sub {
            my $cs= create($lx, 'CharSet', qw(token));
            $cs->{token}= ident_new($lx, 'latin1');
            $functor= 'property';
            push @arg, 'charset', $cs;
            lexer_shift($lx);
        },
        'UNICODE' => sub {
            my $cs= create($lx, 'CharSet', qw(token));
            $cs->{token}= ident_new($lx, 'ucs2');
            $functor= 'property';
            push @arg, 'charset', $cs;
            lexer_shift($lx);
        },
        'CHARACTER SET' => sub {
            lexer_shift($lx);
            return unless
                my $arg= parse_charset($lx);
            $functor= 'property';
            push @arg, 'charset', $arg;
        },
        'DROP CHARACTER SET' => sub {
            $functor= 'property';
            push @arg, 'charset', '';
            lexer_shift($lx);
        },

        'COLLATE' => sub {
            lexer_shift($lx);
            return unless
                my $arg= parse_collate($lx);
            $functor= 'property';
            push @arg, 'collate', $arg;
        },
        'DROP COLLATE' => sub {
            $functor= 'property';
            push @arg, 'collate', '';
            lexer_shift($lx);
        },

        'WITH LOCAL TIME ZONE' => 'WITH TIME ZONE',
        'WITHOUT TIME ZONE' => 'WITH TIME ZONE',
        'WITH TIME ZONE' => sub {
            $functor= 'property';
            push @arg, 'timezone', lexer_shift($lx);
        },

        'DROP TIME ZONE' => sub {
            $functor= 'property';
            push @arg, 'timezone', '';
            lexer_shift($lx);
        },

        '(' => sub {
            lexer_shift($lx);
            return unless
                my $list= parse_list ([], $lx, \&parse_limit_expr, ',', ')');

            parse_choice($lx,
                'K' => 'G',
                'M' => 'G',
                'G' => sub {
                     if (scalar(@$list) > 1) {
                         $lx->{error}= "At most one value in () expected, but found ".scalar($list);
                         return;
                     }

                     $functor= 'largelength';
                     push @arg, $list->[0];

                     push @arg, lexer_shift($lx);

                     if (looking_at($lx, ')')) {
                         push @arg, '';
                     }
                     else {
                         return unless
                             my $unit= parse_char_unit($lx);

                         push @arg, $unit;
                     }
                },

                'ident' => sub {
                     if (scalar(@$list) > 1) {
                         $lx->{error}= "At most one value in () expected, but found ".scalar($list);
                         return;
                     }

                     $functor= 'largelength';
                     push @arg, '';

                },

                -default => sub {
                    if (scalar(@$list) > 2) {
                        $lx->{error}= "At most two values in () expected, but found ".scalar($list);
                        return;
                    }

                    $functor= 'length';
                    push @arg, @$list;
                }
            );
            return if $lx->{error};
            return unless expect($lx, ')', SHIFT);
        },
    );

    return ($functor, \@arg);
}

sub parse_type_post($$);
sub parse_type_post($$)
{
    my ($lx, $base)= @_;
    my $r= create($lx, 'TypePost', qw(base functor arg));
    $r->{base}= $base;

    ($r->{functor}, $r->{arg})= parse_type_post_inner($lx);
    return
        if $lx->{error};

    return $base
        unless defined $r->{functor};

    return parse_type_post ($lx, $r);
}

sub parse_type($)
{
    my ($lx)= @_;
    my $r= create($lx, 'Type', qw(base token));

    if (looking_at($lx, ['interpol', 'interpolType'])) {
        $r->{type}= 'interpol';
        $r->{token}= $lx->{token};
        lexer_shift($lx);
    }
    else {
        unless ($type_spec{$lx->{token}{kind}}) {
            $lx->{error}= 'Expected type name, but found '.token_describe($lx->{token});
            return;
        }
        $r->{type}= 'base';
        $r->{base}= $lx->{token}{kind};
    }

    lock_hash %$r;
    return parse_type_post ($lx, $r);
}

sub parse_type_list($) # without enclosing (...)
{
    my ($lx)= @_;
    return unless
        my $arg= parse_list ([], $lx, \&parse_type, ',', ')');

    my $r= create ($lx, ['TypeList','explicit'], qw(arg));
    $r->{arg}= $arg;
    lock_hash %$r;
    return $r;
}

sub parse_type_list_delim($) # with enclosing (...)
{
    my ($lx)= @_;

    return parse_choice($lx,
        '(' => sub {
            lexer_shift($lx);
            return unless
                my $r= parse_type_list ($lx)
            and expect ($lx, ')', SHIFT);
            return $r;
        },

        'interpol' => sub { # Perl array reference:
            my $r= create ($lx, ['TypeList','interpol'], qw(token));
            $r->{token}= $lx->{token};
            lexer_shift($lx);
            lock_hash %$r;
            return $r;
        },
    );
}

sub parse_on_action($)
{
    my ($lx)= @_;
    return looking_at($lx, ['RESTRICT', 'CASCADE', 'SET NULL', 'SET DEFAULT', 'NO ACTION'], SHIFT);
}

sub parse_references($)
{
    my ($lx)= @_;
    my $r= create($lx, 'References', qw(table column match on_delete on_update));

    lexer_shift($lx);

    return unless
        $r->{table}= parse_table($lx)
    and $r->{column}= parse_list_delim($lx, \&parse_column_name);

    if (looking_at($lx, 'MATCH', SHIFT)) {
        $r->{match}= expect ($lx, ['FULL','PARTIAL','SINGLE'], SHIFT);
    }

    parse_try_list([], $lx, sub {
        parse_choice($lx,
            'ON DELETE' => sub {
                lexer_shift($lx);
                return unless
                    $r->{on_delete}= parse_on_action($lx);
            },
            'ON UPDATE' => sub {
                lexer_shift($lx);
                return unless
                    $r->{on_update}= parse_on_action($lx);
            },
            -default => sub {}
        );
    });
    return if $lx->{error};

    lock_hash %$r;
    return $r;
}

sub parse_column_spec_post_inner($)
{
    my ($lx)= @_;
    my $functor= undef;
    my @arg= ();

    my $constraint= undef;
    if (looking_at($lx, 'CONSTRAINT', SHIFT)) {
        return unless
            $constraint= parse_constraint($lx);
    }

    parse_choice($lx,
        -default => sub {
            if ($constraint) {
                $lx->{error}= 'Constraint expected';
            }
            else {
                my ($func, $arg)= parse_type_post_inner($lx); # inherit column type post
                if ($func) {
                    $functor= "type_$func";
                    @arg= @$arg;
                }
            }
        },
        'NOT NULL' => sub {
            $functor= 'property';
            push @arg, $constraint, 'notnull', lexer_shift($lx);
        },
        'NULL' => sub {
            $functor= 'property';
            push @arg, $constraint, 'notnull', '';
            lexer_shift($lx);
        },

        'AUTO_INCREMENT' => sub {
            $functor= 'property';
            push @arg, $constraint, 'autoinc', lexer_shift($lx);
        },
        'DROP AUTO_INCREMENT' => sub {
            $functor= 'property';
            push @arg, $constraint, 'autoinc', '';
            lexer_shift($lx);
        },

        'UNIQUE' => sub {
            $functor= 'property';
            push @arg, $constraint, 'unique', lexer_shift($lx);
        },
        'DROP UNIQUE' => sub {
            $functor= 'property';
            push @arg, $constraint, 'unique', '';
            lexer_shift($lx);
        },

        'PRIMARY KEY' => sub {
            $functor= 'property';
            push @arg, $constraint, 'primary', lexer_shift($lx);
        },
        'DROP PRIMARY KEY' => sub {
            $functor= 'property';
            push @arg, $constraint, 'primary', '';
            lexer_shift($lx);
        },

        'KEY' => sub {
            $functor= 'property';
            push @arg, $constraint, 'key', lexer_shift($lx);
        },
        'DROP KEY' => sub {
            $functor= 'property';
            push @arg, $constraint, 'key', '';
            lexer_shift($lx);
        },

        'DEFAULT' => sub {
            lexer_shift($lx);
            return unless
                my $val= parse_expr($lx);
            $functor= 'property';
            push @arg, $constraint, 'default', $val;
        },
        'DROP DEFAULT' => sub {
            lexer_shift($lx);
            $functor= 'property';
            push @arg, $constraint, 'default', '';
        },

        'CHECK' => sub {
            lexer_shift($lx);
            return unless
                my $val= parse_expr($lx);
            $functor= 'property';
            push @arg, $constraint, 'check', $val;
        },
        'DROP CHECK' => sub {
            lexer_shift($lx);
            $functor= 'property';
            push @arg, $constraint, 'check', '';
        },

        ($read_dialect{mysql} ?
            (
                'COMMENT' => sub {
                    lexer_shift($lx);
                    return unless
                        my $val= parse_expr($lx);
                    $functor= 'property';
                    push @arg, $constraint, 'comment', $val;
                },
                'DROP COMMENT' => sub {
                    lexer_shift($lx);
                    $functor= 'property';
                    push @arg, $constraint, 'comment', '';
                },
                'COLUMN_FORMAT' => sub {
                    lexer_shift($lx);
                    $functor= 'property';
                    push @arg, $constraint, 'column_format',
                               expect($lx, ['FIXED','DYNAMIC','DEFAULT'], SHIFT);
                },
                'STORAGE' => sub {
                    lexer_shift($lx);
                    $functor= 'property';
                    push @arg, $constraint, 'storage',
                               expect($lx, ['DISK','MEMORY','DEFAULT'], SHIFT);
                }
            )
        :   ()
        ),

        'REFERENCES' => sub {
            return unless
                my $ref= parse_references($lx);
            $functor= 'property';
            push @arg, $constraint, 'references', $ref;
        },
        'DROP REFERENCES' => sub {
            lexer_shift($lx);
            $functor= 'property';
            push @arg, $constraint, 'references', '';
        },
    );

    return ($functor, \@arg);
}

sub parse_column_spec_post($$);
sub parse_column_spec_post($$)
{
    my ($lx, $base)= @_;

    my $r= create($lx, 'ColumnSpecPost', qw(base functor arg));
    $r->{base}= $base;
    $r->{arg}= [];

    ($r->{functor}, $r->{arg})= parse_column_spec_post_inner($lx);
    return
        if $lx->{error};

    return $base
        unless defined $r->{functor};

    return parse_column_spec_post ($lx, $r);
}

sub parse_column_spec($)
{
    my ($lx)= @_;

    my $r= create($lx, 'ColumnSpec', qw(datatype name token));

    parse_choice($lx,
        'interpolColumnSpec' => 'interpol',
        'interpol' => sub {
            $r->{type}= 'interpol';
            $r->{token}= $lx->{token};
            lexer_shift($lx);
        },

        -default => sub {
            $r->{type}= 'base';
            return unless
               $r->{datatype}= parse_type($lx);
        }
    );
    return if $lx->{error};

    lock_hash %$r;
    return parse_column_spec_post($lx, $r);

}

sub parse_expr_list($) # without enclosing (...)
{
    my ($lx)= @_;
    if (looking_at($lx, [@SELECT_INITIAL,'interpolStmt'])) {
        return unless
            my $q= parse_select_stmt($lx);

        my $r= create_Expr ($lx);
        $r->{type}= 'subquery';
        $r->{arg}=  $q;
        return $r;
    }
    else {
        my $r= create ($lx, ['ExprList','explicit'], qw(arg));

        return unless
            my $arg= parse_list ([], $lx, \&parse_expr, ',', ')');

        $r->{arg}= $arg;
        lock_hash %$r;
        return $r;
    }
}

sub parse_expr_list_delim($) # with enclosing (...)
{
    my ($lx)= @_;

    return parse_choice($lx,
        '(' => sub {
            lexer_shift($lx);
            return unless
                my $r= parse_expr_list ($lx)
            and expect ($lx, ')', SHIFT);
            return $r;
        },

        'interpol' => sub { # Perl array reference:
            my $r= create ($lx, ['ExprList','interpol'], qw(token));
            $r->{token}= $lx->{token};
            lexer_shift($lx);
            lock_hash %$r;
            return $r;
        },
    );
}

sub get_rhs($$)
{
    my ($left, $arg_i)= @_;
    return $left->{rhs_map}{$arg_i} || $left->{rhs};
}

sub parse_thing($$;$$)
{
    my ($lx, $thing_name, $left, $right_mark)= @_;
    return switch ($thing_name,
        'expr' => sub {
            return parse_expr ($lx, $left, $right_mark)
        },
        'type' => sub {
            return parse_type ($lx);
        },
        'string_expr' => sub {
            return parse_expr ($lx, $left, 'string')
        },
        'expr_list' => sub {
            return parse_expr_list_delim($lx);
        },
        'type_list' => sub {
            return parse_type_list_delim($lx);
        },
    );
}

sub parse_funcsep($$$)
{
    my ($lx, $r, $pattern)= @_;
    for my $e (@$pattern) {
        if (!ref($e)) {
            return unless
                expect($lx, $e, SHIFT);
            push @{ $r->{arg} }, $e; # no ref()
        }
        elsif (ref($e) eq 'SCALAR') {
            return unless
                my $arg= parse_thing($lx, $$e); # will return a ref()
            push @{ $r->{arg} }, $arg;
        }
        elsif (ref($e) eq 'ARRAY') {
            if (looking_at($lx, $e->[0])) {
                return unless
                    parse_funcsep($lx, $r, $e);
            }
        }
        else {
            die "Unrecognised pattern piece, ref()=".ref($e);
        }
    }
    return $r;
}

sub parse_check($)
{
    my ($lx)= @_;
    my $r= create ($lx, 'Check', qw(expr));

    my $cond= parse_expr_post($lx, undef, undef, create($lx, 'ExprEmpty'));
    return unless $cond;

    $r->{expr}= $cond;
    return $r;
}

sub parse_when_post($)
{
    my ($lx)= @_;

    return unless
        looking_at($lx, 'WHEN', SHIFT);  # no error if false (-> parse_try_list)

    my $cond;

    my $functor= find_functor(\%functor_suffix, $lx->{token}{kind});
    if ($functor && $functor->{allow_when}) {
        $cond= parse_expr_post($lx, undef, undef, create($lx, 'ExprEmpty'));
    }
    else {
        $cond= parse_expr($lx);
    }

    return unless
        $cond
    and expect($lx, 'THEN', SHIFT)
    and my $expr= parse_expr($lx);

    $cond->{maybe_check}= 1; # allow Check interpolation if this is an Expr

    return [ $cond, $expr ];
}

sub parse_when($)
{
    my ($lx)= @_;

    return unless
        looking_at($lx, 'WHEN', SHIFT)   # no error if false (-> parse_try_list)
    and my $cond= parse_expr($lx)
    and expect($lx, 'THEN', SHIFT)
    and my $expr= parse_expr($lx);

    return [ $cond, $expr ];
}

sub shift_or_reduce_pure($$$)
# $right_mark is either 0/undef, 1, or 'string', see parse_expr().
{
    my ($left, $right, $right_mark)= @_;

    # hack for 'IN':
    return ACTION_REDUCE
        if ($right_mark || '') eq 'string' &&
           $right->{value} eq 'IN';

    # currently, this is very simple, because we don't use precedences:
    return ACTION_SHIFT
        unless $left;

    # special rule to allow sequencing even for operators without precedence:
    return ACTION_REDUCE
        if $left->{value} eq $right->{value} &&
           $left->{read_type} eq 'infix()';

    # parse with precedences?
    if ($do_prec) {
        # if both have a precedence:
        if ($left->{prec} && $right->{prec}) {
            return ACTION_REDUCE
                if $left->{prec} > $right->{prec};

            return ACTION_SHIFT
                if $left->{prec} < $right->{prec};

            # if both have an associativity and the associativity is the same:
            if ($left->{assoc} && $right->{assoc} &&
                $left->{assoc} == $right->{assoc})
            {
                if ($left->{assoc} == ASSOC_LEFT && $right_mark) {
                    return ACTION_REDUCE;
                }
                else {
                    return ACTION_SHIFT;
                }
            }
        }
    }
    else {
        # no precedences at all:
        # For infix23 and infix3, we need to reduce, instead of failing:
        if (defined $left->{value2}) {
            return ACTION_REDUCE;
        }
    }

    # otherwise: ambiguous
    return ACTION_AMBIGUOUS;
}

sub shift_or_reduce($$$$)
{
    my ($lx, $left, $right, $right_mark)= @_;
    my $result= shift_or_reduce_pure ($left, $right, $right_mark);
    unless ($result) {
        $lx->{error}= "Use of operators '$left->{value}' vs. '$right->{value}' ".
                      "requires parentheses.";
    }
    return $result;
}

sub find_functor($$)
{
    my ($map, $kind)= @_;

    return unless
        my $functor= find_ref(%$map, $kind);

    if (my $accept= $functor->{accept}) {
        for my $a (@$accept) {
            if ($read_dialect{$a}) {
                return $functor;
            }
        }
        return;
    }

    return $functor;
}

sub set_expr_functor($$@)
{
    my ($r, $functor, @arg)= @_;
    my_confess if $r->{arg};

    $r->{type}=    $functor->{type};
    $r->{functor}= $functor;
    $r->{arg}=     [ @arg ];
}

sub parse_expr_post($$$$)
# $right_mark is either 0/undef, 1, or 'string', see parse_expr().
{
    my ($lx, $left, $right_mark, $arg1)= @_;

    # infix:
    my $kind= $lx->{token}{kind};

    if (my $right= find_functor(\%functor_suffix, $kind)) {
        return unless
            my $action= shift_or_reduce($lx, $left, $right, $right_mark);

        if ($action == ACTION_SHIFT) {
            lexer_shift ($lx);

            my $r= create_Expr ($lx);
            set_expr_functor ($r, $right, $arg1);

            switch ($right->{read_type},
                'infix2' => sub {
                    # parse second arg:
                    return unless
                        my $arg2= parse_thing ($lx, get_rhs($right,0), $right, 1);
                    push @{ $r->{arg} }, $arg2;
                },
                'infix()' => sub {
                    # parse sequence:
                    my $i=0;
                    do {
                        return unless
                            my $argi= parse_thing ($lx, get_rhs($right,$i++), $right, 1);
                        push @{ $r->{arg} }, $argi;
                    } while (looking_at($lx, $kind, SHIFT));             # same operator?
                },
                'infix23' => sub {
                    # parse second arg:
                    return unless
                        my $arg2= parse_thing ($lx, get_rhs($right,0), $right, 1);
                    push @{ $r->{arg} }, $arg2;

                    # maybe parse third arg:
                    if (looking_at ($lx, $right->{value2}, SHIFT)) {
                        return unless
                            my $arg3= parse_thing ($lx, get_rhs($right,1), $right, 1);
                        push @{ $r->{arg} }, $arg3;
                    }
                },
                'infix3' => sub {
                    # parse second arg:
                    return unless
                        my $arg2= parse_thing ($lx, get_rhs($right,0), $right, 1)
                    and expect ($lx, $right->{value2}, SHIFT)
                    and my $arg3= parse_thing ($lx, get_rhs($right,1), $right, 1); # descend

                    push @{ $r->{arg} }, $arg2, $arg3;
                },
                'suffix' => sub {
                    # nothing more to do
                }
            );
            return if $lx->{error};

            lock_keys %$r; # {maybe_check} may be modified if we parse WHEN clauses.

            return parse_expr_post ($lx, $left, $right_mark, $r); # descend
        }
    }

    return $arg1;
}

sub parse_expr($;$$)
# $right_mark is either 0/undef, 1, or 'string'.
# 'string' is a hack for POSITION(a IN b) and keeps parse_expr
# from shifting IN.  It's one of these typical design complications
# in SQL grammar that prevents you from writing a straight-forward
# recursive parser.  If $right_mark eq 'string', then $functor
# is undef.  Otherwise $functor is defined if $right_mark is true.
{
    my ($lx, $functor, $right_mark)= @_;
    my $r= create_Expr ($lx);

    parse_choice($lx,
        '.' => sub {
            lexer_shift($lx);
            $r->{type}= 'column';
            $r->{arg}=  parse_column ($lx);
        },

        'interpolColumn' => 'ident',
        'interpolTable'  => 'ident',
        '*'              => 'ident',
        'ident' => sub {
            $r->{type}= 'column';
            $r->{arg}=  parse_column ($lx);
        },

        'interpolExpr' => sub {
            $r->{type}= 'interpol';
            $r->{token}= $lx->{token};
            lexer_shift($lx);
        },

        'interpol' => sub {
            parse_value_or_column_into ($lx, $r, 'interpol');
        },

        'TRUE' => '?',
        'FALSE' => '?',
        'NULL' => '?',
        'UNKNOWN' => '?',
        'DEFAULT' => '?',
        '?' => sub {
            $r->{type}=  'interpol';
            $r->{token}= $lx->{token};
            lexer_shift($lx);

            # special care for functors like MySQL's DEFAULT(...).  Since
            # there's both DEFAULT and DEFAULT(...), we need to check.  We
            # use find_functor() in order to support read_dialect properly.
            if (looking_at($lx, '(', SHIFT) and
                my $functor= find_functor(\%functor_special, $r->{token}{kind}))
            {
                switch ($functor->{read_type},
                    'funcall1col' => sub {
                        return unless
                            my $arg= parse_column_name($lx)
                        and expect ($lx, ')', SHIFT);
                        set_expr_functor ($r, $functor, $arg);
                    }
                );
            }
        },

        'CASE' => sub {
            lexer_shift($lx);
            $r->{type}= 'case';
            if (looking_at($lx, ['WHEN','ELSE','END'])) { # without 'switchval'
                return unless
                    $r->{arg}= parse_try_list([], $lx, \&parse_when);
            }
            else { # with switchval
                return unless
                    $r->{switchval}= parse_expr($lx)
                and $r->{arg}= parse_try_list([], $lx, \&parse_when_post);
            }

            if (looking_at($lx, 'ELSE', SHIFT)) {
                return unless
                    $r->{otherwise}= parse_expr($lx);
            }

            return unless
                expect($lx, 'END', SHIFT);
        },

        'ALL' => 'SOME',
        'ANY' => 'SOME',
        'SOME' => sub {
            if (!$functor || !$functor->{comparison} || !$right_mark) {
                $lx->{error}= "$lx->{token}{kind} can only be used directly after a comparison.";
                return;
            }
            my $functor2= find_functor(\%functor_special, $lx->{token}{kind});
            unless ($functor2) {
                $lx->{error}= "Unexpected $lx->{token}{kind} in expression.";
                return;
            }
            lexer_shift($lx);

            return unless
                expect($lx, '(', SHIFT)
            and my $q= parse_select_stmt ($lx)
            and expect($lx, ')', SHIFT);

            my $r2= create_Expr($lx);
            $r2->{type}= 'subquery';
            $r2->{arg}=  $q;

            set_expr_functor ($r, $functor2, $r2);
        },

        '(' => sub {
            lexer_shift($lx);
            if (looking_at($lx, [@SELECT_INITIAL,'interpolStmt'])) {
                return unless
                    my $q= parse_select_stmt ($lx);
                $r->{type}= 'subquery';
                $r->{arg}=  $q;
            }
            else {
                return unless
                    my $arg= parse_expr($lx);
                $r->{type}= '()';
                $r->{arg}= $arg;
            }
            return unless
                expect($lx, ')', SHIFT);
        },

        -default => sub {
            my $functor2= find_functor(\%functor_prefix, $lx->{token}{kind});
            if (!$functor2 && $lx->{token}{type} eq 'keyword') {      # generic funcall
                $functor2= make_op($lx->{token}{kind}, 'funcall');
            }

            # prefix / funcall:
            if ($functor2) {
                set_expr_functor ($r, $functor2);
                lexer_shift($lx);

                switch ($functor2->{read_type},
                    'prefix' => sub {
                        my $arg;
                        if (looking_at($lx, '(', NO_SHIFT)) {
                            return unless
                                $r->{arg}= parse_list_delim ($lx, \&parse_expr);
                        }
                        else {
                            return unless
                                my $arg= parse_thing ($lx, get_rhs($functor2,0), $functor2, 0);
                            $r->{arg}= [ $arg ];
                        }
                    },
                    'funcall' => sub {
                        return unless
                            $r->{arg}= parse_list_delim ($lx, \&parse_expr);
                    },
                    'funcall1col' => sub {
                        return unless
                            expect ($lx, '(', SHIFT)
                        and my $arg1= parse_column_name($lx)
                        and expect ($lx, ')', SHIFT);
                        $r->{arg}= [ $arg1 ];
                    },
                    'funcsep' => sub {
                        return unless
                            expect ($lx, '(', SHIFT)
                        and parse_funcsep ($lx, $r, $functor2->{rhs});
                    },
                );
                return if $lx->{error};
            }
            # error:
            elsif (! $lx->{error}) {
                $lx->{error}= "Unexpected ".token_describe($lx->{token})." in expression";
            }

            return;
        },
    );
    return if $lx->{error};

    die unless $r;
    lock_keys %$r; # {arg} may be modified when parsing sequenced infix operators
                   # and {maybe_check} may be modified when parsing WHEN clauses

    # And now parse the suffix:
    return parse_expr_post ($lx, $functor, $right_mark, $r);
}

sub parse_limit_num($) # Simply returns the single token if it is appropriate.
{
    my ($lx)= @_;
    return parse_choice($lx,
        'interpolExpr' => 'interpol',
        '?'            => 'interpol',
        'interpol' => sub {
            my $r= $lx->{token};
            lexer_shift($lx);
            return $r;
        },
    );
}

sub parse_expr_as($)
{
    my ($lx)= @_;
    my $r= create ($lx, 'ExprAs', qw(expr as));

    return unless
        $r->{expr}= parse_expr($lx);

    if (looking_at($lx, 'AS', SHIFT)) {
        return unless
            $r->{as}= parse_column_name($lx);
    }

    lock_hash %$r;
    return $r;
}

sub parse_order($)
{
    my ($lx)= @_;
    my $r= create ($lx, 'Order', qw(type expr token desc));
    $r->{desc}= 0;

    parse_choice($lx,
        -default => sub {
            $r->{type}= 'expr';
            return unless
                $r->{expr}= parse_expr($lx);
        },

        'interpolOrder' => 'interpol',
        'interpol' => sub {
            if ($lx->{token}{type} eq 'string') {
                # Strings are still expressions, not column names.  There is no
                # other way of forcing Perl interpolation to String type, so
                # we assume a string here.
                $r->{type}= 'expr';
                return unless
                    $r->{expr}= parse_expr($lx);
            }
            else {
                $r->{type}= 'interpol';
                $r->{token}= $lx->{token};
                lexer_shift($lx);
            }
        },
    );
    return if $lx->{error};

    parse_choice($lx,
        -default => sub {}, # no error
        'ASC'    => sub { lexer_shift($lx); $r->{desc}= 0; },
        'DESC'   => sub { lexer_shift($lx); $r->{desc}= 1; },
    );

    lock_hash %$r;
    return $r;
}

sub parse_join($)
{
    my ($lx)= @_;
    my $r= create ($lx, 'Join', qw(token table qual on using natural));

    #print STDERR "parse join: ".token_describe($lx->{token})."\n";
    parse_choice($lx,
        'interpolJoin' => 'interpol',
        'interpol' => sub {
            $r->{type}=  'interpol',
            $r->{token}= $lx->{token};
            lexer_shift($lx);
        },

        -default => sub {
            my $shifted= 0;

            my $want_condition= 1;
            if (looking_at($lx, 'NATURAL', SHIFT)) {
                $r->{natural}= 1;
                $shifted= 1;
                $want_condition= 0;
            }

            parse_choice($lx,
                -default => sub {
                    $r->{type}= 'INNER';
                },

                'INNER' => sub{
                    $r->{type}= 'INNER';
                    lexer_shift($lx);
                    $shifted= 1;
                },

                'UNION' => 'CROSS',
                'CROSS' => sub {
                    if ($r->{natural}) {
                        $lx->{error}= "NATURAL cannot be used with CROSS or UNION JOIN";
                        return;
                    }

                    $r->{type}= lexer_shift($lx);
                    $want_condition= 0;
                    $shifted= 1;
                },

                'LEFT'  => 'FULL',
                'RIGHT' => 'FULL',
                'FULL' => sub {
                    $r->{type}= lexer_shift($lx);
                    looking_at($lx, 'OUTER', SHIFT);
                    $shifted= 1;
                },
            );
            return if $lx->{error};

            unless (looking_at ($lx, 'JOIN', SHIFT)) {
                if ($shifted) {
                    $lx->{error}= "Expected JOIN, but found ".token_describe($lx->{token});
                }
                $r= undef;
                return;
            }

            return unless
                $r->{table}= parse_list([], $lx, \&parse_table_as, ',');

            if ($want_condition) {
                parse_choice($lx,
                    'ON' => sub {
                        lexer_shift($lx);
                        $r->{on}= parse_expr($lx);
                    },
                    'USING' => sub {
                        lexer_shift($lx);
                        return unless
                            $r->{using}= parse_list_delim ($lx, \&parse_column_name);
                    },
                );
            }
        }
    );
    return if $lx->{error};
    return unless $r;

    lock_hash %$r;
    return $r;
}

sub push_option($$$)
{
    my ($lx, $list, $words)= @_;
    if (my $x= looking_at($lx, $words, SHIFT)) {
        push @$list, $x;
        return $x;
    }
    return 0;
}

sub push_option_list($$$)
{
    my ($lx, $list, $words)= @_;
    while (push_option($lx, $list, $words)) {}
}

sub parse_where($) # WHERE is supposed to haveing been parsed already here
{
    my ($lx)= @_;
    # FIXME: MISSING:
    #    - WHERE CURRENT OF (i.e., cursor support)
    return parse_expr($lx);
}

sub parse_select($)
{
    my ($lx)= @_;
    my $r= create ($lx, ['Stmt','Select'],
        qw(
            opt_front
            opt_back
            expr_list
            from
            join
            where
            group_by
            group_by_with_rollup
            having
            order_by
            limit_cnt
            limit_offset
        )
    );

    return unless expect($lx, 'SELECT', SHIFT);

    # Missing:
    #   PostgresQL:
    #     - DISTINCT **ON**
    #     - WITH
    #     - WINDOW
    #     - FETCH
    #     - FOR UPDATE|SHARE **OF** (  , ... ) 




3269




 





 





 





 





 





 



     # 




3270




 





 





 





 





 





 



     # All: 




3271




 





 





 





 





 





 



     #     - UNION 




3272




 





 





 





 





 





 



     #     - INTERSECT 




3273




 





 





 





 





 





 



     #     - EXCEPT 




3274




 





 





 





 





 





 



     #     - FETCH [ FIRST | NEXT ] count [ ROW | ROWS ] ONLY  (same as LIMIT in SQL:2008) 




3275




 





 





 





 





 





 



   




3276




180





 





 





 





 





498



     $r->{opt_front}= []; 




3277




180




  
 50
  




 





 





 





1147



     push_option ($lx, $r->{opt_front}, [ 




3278




 





 





 





 





 





 



         'DISTINCT', 'ALL', 




3279




 





 





 





 





 





 



         ($read_dialect{mysql} ? 




3280




 





 





 





 





 





 



             ('DISTINCTROW') 




3281




 





 





 





 





 





 



         :   () 




3282




 





 





 





 





 





 



         ) 




3283




 





 





 





 





 





 



     ]); 




3284




 





 





 





 





 





 



   




3285




180




  
 50
  




 





 





 





1321



     push_option_list ($lx, $r->{opt_front}, [ 




3286




 





 





 





 





 





 



         ($read_dialect{mysql} ? 




3287




 





 





 





 





 





 



             ( 




3288




 





 





 





 





 





 



                 'HIGH_PRIORITY', 'STRAIGHT_JOIN', 




3289




 





 





 





 





 





 



                 'SQL_SMALL_RESULT', 'SQL_BIG_RESULT', 'SQL_BUFFER_RESULT', 




3290




 





 





 





 





 





 



                 'SQL_CACHE', 'SQL_NO_CACHE', 'SQL_CALC_FOUND_ROWS' 




3291




 





 





 





 





 





 



             ) 




3292




 





 





 





 





 





 



         :   () 




3293




 





 





 





 





 





 



         ) 




3294




 





 





 





 





 





 



     ]); 




3295




 





 





 





 





 





 



   




3296




 





 





 





 





 





 



     return unless 




3297




180




  
100
  




 





 





 





927



         $r->{expr_list}= parse_list([], $lx, \&parse_expr_as, ','); 




3298




 





 





 





 





 





 



   




3299




179




  
100
  




 





 





 





665



     if (looking_at($lx, 'FROM', SHIFT)) { 




3300




 





 





 





 





 





 



         return unless 




3301




94




  
 50
  



  
 33
  




 





 





483



             $r->{from}= parse_list([], $lx, \&parse_table_as, ',') 




3302




 





 





 





 





 





 



         and $r->{join}= parse_try_list([], $lx, \&parse_join); 




3303




 





 





 





 





 





 



   




3304




94




  
100
  




 





 





 





305



         if (looking_at($lx, 'WHERE', SHIFT)) { 




3305




 





 





 





 





 





 



             return unless 




3306




44




  
 50
  




 





 





 





166



                 $r->{where}= parse_where ($lx); 




3307




 





 





 





 





 





 



         } 




3308




94




  
100
  




 





 





 





300



         if (looking_at($lx, 'GROUP BY', SHIFT)) { 




3309




 





 





 





 





 





 



             return unless 




3310




6




  
 50
  




 





 





 





32



                 $r->{group_by}= parse_list([], $lx, \&parse_order, ','); 




3311




 





 





 





 





 





 



   




3312




6





 





 





 





 





23



             $r->{group_by_with_rollup}= looking_at($lx, 'WITH ROLLUP', SHIFT); 




3313




 





 





 





 





 





 



         } 




3314




94




  
100
  




 





 





 





271



         if (looking_at($lx, 'HAVING', SHIFT)) { 




3315




 





 





 





 





 





 



             return unless 




3316




1




  
 50
  




 





 





 





3



                 $r->{having}= parse_expr ($lx); 




3317




 





 





 





 





 





 



         } 




3318




94




  
100
  




 





 





 





212



         if (looking_at($lx, 'ORDER BY', SHIFT)) { 




3319




 





 





 





 





 





 



             return unless 




3320




8




  
 50
  




 





 





 





35



                 $r->{order_by}= parse_list([], $lx, \&parse_order, ','); 




3321




 





 





 





 





 





 



         } 




3322




 





 





 





 





 





 



   




3323




94




  
100
  




 





 





 





284



         if (looking_at($lx, 'LIMIT', SHIFT)) { 




3324




4




  
 50
  




 





 





 





16



             unless (looking_at($lx, 'ALL', SHIFT)) { 




3325




4





 





 





 





 





19



                 my $first_num= parse_limit_num ($lx); 




3326




4




  
100
  




 





 





 





31



                 if (looking_at($lx, ',', SHIFT)) { 




3327




2





 





 





 





 





6



                     $r->{limit_offset}= $first_num; 




3328




2





 





 





 





 





6



                     $r->{limit_cnt}=    parse_limit_num($lx); 




3329




 





 





 





 





 





 



                 } 




3330




 





 





 





 





 





 



                 else { 




3331




2





 





 





 





 





9



                     $r->{limit_cnt}= $first_num; 




3332




 





 





 





 





 





 



                 } 




3333




 





 





 





 





 





 



             } 




3334




 





 





 





 





 





 



         } 




3335




94




  
100
  



  
100
  




 





 





573



         if (!$r->{limit_offset} && 




3336




 





 





 





 





 





 



             looking_at ($lx, 'OFFSET', SHIFT)) 




3337




 





 





 





 





 





 



         { 




3338




1





 





 





 





 





4



             $r->{limit_offset}= parse_limit_num ($lx); 




3339




 





 





 





 





 





 



         } 




3340




 





 





 





 





 





 



   




3341




94





 





 





 





 





353



         $r->{opt_back}=  []; 




3342




94




  
 50
  



  
 33
  




 





 





995



         push_option_list ($lx, $r->{opt_back}, [ 




 




 




  
 50
  




 





 





 





 



   




 




 




  
 50
  




 





 





 





 



   




3343




 





 





 





 





 





 



             ($read_dialect{mysql} || $read_dialect{postgresql} ? 




3344




 





 





 





 





 





 



                 ('FOR UPDATE') 




3345




 





 





 





 





 





 



             :   () 




3346




 





 





 





 





 





 



             ), 




3347




 





 





 





 





 





 



             ($read_dialect{mysql} ? 




3348




 





 





 





 





 





 



                 ( 




3349




 





 





 





 





 





 



                     'LOCK IN SHARE MODE'  # FIXME: normalise: PostgreSQL: FOR SHARE 




3350




 





 





 





 





 





 



                 ) 




3351




 





 





 





 





 





 



             :   () 




3352




 





 





 





 





 





 



             ), 




3353




 





 





 





 





 





 



             ($read_dialect{postgresql} ? 




3354




 





 





 





 





 





 



                 ( 




3355




 





 





 





 





 





 



                     'FOR SHARE',          # FIXME: normalise: MySQL: LOCK IN SHARE MODE 




3356




 





 





 





 





 





 



                     'NOWAIT' 




3357




 





 





 





 





 





 



                 ) 




3358




 





 





 





 





 





 



             :   () 




3359




 





 





 





 





 





 



             ), 




3360




 





 





 





 





 





 



         ]); 




3361




 





 





 





 





 





 



     } 




3362




 





 





 





 





 





 



   




3363




179





 





 





 





 





753



     lock_hash %$r; 




3364




179





 





 





 





 





6264



     return $r; 




3365




 





 





 





 





 





 



 } 




3366




 





 





 





 





 





 



   




3367




 





 





 





 





 





 



 sub parse_insert($) 




3368




 





 





 





 





 





 



 { 




3369




13





 





 




  
13
  



  
0
  




29



     my ($lx)= @_; 




3370




13





 





 





 





 





65



     my $r= create ($lx, ['Stmt','Insert'], 




3371




 





 





 





 





 





 



         qw( 




3372




 





 





 





 





 





 



             opt_front 




3373




 





 





 





 





 





 



             into 




3374




 





 





 





 





 





 



             column 




3375




 





 





 





 





 





 



             default_values 




3376




 





 





 





 





 





 



             value 




3377




 





 





 





 





 





 



             value_interpol 




3378




 





 





 





 





 





 



             set 




3379




 





 





 





 





 





 



             select 




3380




 





 





 





 





 





 



             duplicate_update 




3381




 





 





 





 





 





 



         ) 




3382




 





 





 





 





 





 



     ); 




3383




 





 





 





 





 





 



   




3384




13




  
 50
  




 





 





 





54



     return unless expect($lx, 'INSERT', SHIFT); 




3385




 





 





 





 





 





 



   




3386




 





 





 





 





 





 



     # PostgreSQL: 




3387




 





 





 





 





 





 



     #    - RETURNING ... 




3388




 





 





 





 





 





 



   




3389




13





 





 





 





 





66



     $r->{opt_front}= []; 




3390




13




  
 50
  




 





 





 





205



     push_option_list ($lx, $r->{opt_front}, [ 




3391




 





 





 





 





 





 



         ($read_dialect{mysql} ? 




3392




 





 





 





 





 





 



             ( 




3393




 





 





 





 





 





 



                 'IGNORE', 




3394




 





 





 





 





 





 



                 'LOW_PRIORITY', 




3395




 





 





 





 





 





 



                 'HIGH_PRIORITY', 




3396




 





 





 





 





 





 



                 'DELAYED', 




3397




 





 





 





 





 





 



             ) 




3398




 





 





 





 





 





 



         :   () 




3399




 





 





 





 





 





 



         ) 




3400




 





 





 





 





 





 



     ]); 




3401




 





 





 





 





 





 



   




3402




13





 





 





 





 





48



     looking_at($lx, 'INTO', SHIFT); # optional in MySQL 




3403




 





 





 





 





 





 



   




3404




 





 





 





 





 





 



     return unless 




3405




13




  
 50
  




 





 





 





47



         $r->{into}= parse_table($lx); 




3406




 





 





 





 





 





 



   




3407




13




  
100
  




 





 





 





32



     if (looking_at($lx, '(')) { 




3408




 





 





 





 





 





 



         return unless 




3409




5




  
 50
  




 





 





 





26



             $r->{column}= parse_list_delim($lx, \&parse_column_name); 




3410




 





 





 





 





 





 



     } 




3411




 





 





 





 





 





 



   




3412




 





 





 





 





 





 



     parse_choice($lx, 




3413




 





 





 





 





 





 



         'DEFAULT VALUES' => sub { 




3414




0





 





 




  
0
  




 





0



             lexer_shift($lx); 




3415




0





 





 





 





 





0



             $r->{default_values}= 1; 




3416




 





 





 





 





 





 



         }, 




3417




 





 





 





 





 





 



   




3418




 





 





 





 





 





 



         'VALUE' => 'VALUES', 




3419




 





 





 





 





 





 



         'VALUES' => sub { 




3420




5





 





 




  
5
  




 





16



             lexer_shift($lx); 




3421




5





 





 





 





 





23



             $r->{value}= parse_list([], $lx, \&parse_expr_list_delim, ','); 




3422




 





 





 





 





 





 



         }, 




3423




 





 





 





 





 





 



   




3424




 





 





 





 





 





 



         'SET' => sub { 




3425




 





 





 





 





 





 



             # MySQL extension, but will be normalised to VALUES clause, so we 




3426




 





 





 





 





 





 



             # always accept this even with !$read_dialect{mysql}. 




3427




8




  
 50
  




 




  
8
  




 





30



             if ($r->{column}) { 




3428




0





 





 





 





 





0



                 $lx->{error}= "Either column list or 'SET' expected, but found both."; 




3429




0





 





 





 





 





0



                 return; 




3430




 





 





 





 





 





 



             } 




3431




8





 





 





 





 





18



             lexer_shift($lx); 




3432




8





 





 





 





 





29



             $r->{set}= parse_list([], $lx, \&parse_expr, ','); 




3433




 





 





 





 





 





 



         }, 




3434




 





 





 





 





 





 



   




3435




13





 





 





 





 





73



         (map { $_ => 'interpolStmt' } @SELECT_INITIAL), 




3436




 





 





 





 





 





 



         'interpol' => 'interpolStmt', 




3437




 





 





 





 





 





 



         'interpolStmt' => sub { 




3438




0





 





 




  
0
  




 





0



             $r->{select}= parse_select_stmt($lx); 




3439




 





 





 





 





 





 



         }, 




3440




13





 





 





 





 





116



     ); 




3441




13




  
 50
  




 





 





 





250



     return if $lx->{error}; 




3442




 





 





 





 





 





 



   




3443




13




  
100
  



  
 66
  




 





 





70



     if ($read_dialect{mysql} && 




3444




 





 





 





 





 





 



         looking_at ($lx, 'ON DUPLICATE KEY UPDATE', SHIFT)) 




3445




 





 





 





 





 





 



     { 




3446




 





 





 





 





 





 



         return unless 




3447




1




  
 50
  




 





 





 





6



             $r->{duplicate_update}= parse_list([], $lx, \&parse_expr, ','); 




3448




 





 





 





 





 





 



     } 




3449




 





 





 





 





 





 



   




3450




13





 





 





 





 





50



     lock_hash %$r; 




3451




13





 





 





 





 





369



     return $r; 




3452




 





 





 





 





 





 



 } 




3453




 





 





 





 





 





 



   




3454




 





 





 





 





 





 



 sub parse_update($) 




3455




 





 





 





 





 





 



 { 




3456




9





 





 




  
9
  



  
0
  




24



     my ($lx)= @_; 




3457




9





 





 





 





 





54



     my $r= create ($lx, ['Stmt','Update'], 




3458




 





 





 





 





 





 



         qw( 




3459




 





 





 





 





 





 



             opt_front 




3460




 





 





 





 





 





 



             table 




3461




 





 





 





 





 





 



             set 




3462




 





 





 





 





 





 



             from 




3463




 





 





 





 





 





 



             join 




3464




 





 





 





 





 





 



             where 




3465




 





 





 





 





 





 



             order_by 




3466




 





 





 





 





 





 



             limit_cnt 




3467




 





 





 





 





 





 



             limit_offset 




3468




 





 





 





 





 





 



         ) 




3469




 





 





 





 





 





 



     ); 




3470




 





 





 





 





 





 



   




3471




9




  
 50
  




 





 





 





38



     return unless expect($lx, 'UPDATE', SHIFT); 




3472




 





 





 





 





 





 



   




3473




 





 





 





 





 





 



     # PostgreSQL: 




3474




 





 





 





 





 





 



     #    - RETURNING ... 




3475




 





 





 





 





 





 



   




3476




9





 





 





 





 





29



     $r->{opt_front}= []; 




3477




9




  
 50
  




 





 





 





218



     push_option_list ($lx, $r->{opt_front}, [ 




 




 




  
 50
  




 





 





 





 



   




3478




 





 





 





 





 





 



         ($read_dialect{mysql} ? 




3479




 





 





 





 





 





 



             ( 




3480




 





 





 





 





 





 



                 'IGNORE', 




3481




 





 





 





 





 





 



                 'LOW_PRIORITY', 




3482




 





 





 





 





 





 



             ) 




3483




 





 





 





 





 





 



         :   () 




3484




 





 





 





 





 





 



         ), 




3485




 





 





 





 





 





 



         ($read_dialect{postgresql} ? 




3486




 





 





 





 





 





 



             ( 




3487




 





 





 





 





 





 



                 'ONLY', 




3488




 





 





 





 





 





 



             ) 




3489




 





 





 





 





 





 



         :   () 




3490




 





 





 





 





 





 



         ) 




3491




 





 





 





 





 





 



     ]); 




3492




 





 





 





 





 





 



   




3493




 





 





 





 





 





 



     return unless 




3494




9




  
 50
  



  
 33
  




 





 





47



         $r->{table}= parse_list([], $lx, \&parse_table_as, ',') 




 




 





 




  
 33
  




 





 





 



   




3495




 





 





 





 





 





 



     and expect($lx, 'SET', SHIFT) 




3496




 





 





 





 





 





 



     and $r->{set}= parse_list([], $lx, \&parse_expr, ','); 




3497




 





 





 





 





 





 



   




3498




9




  
100
  




 





 





 





33



     if (looking_at($lx, 'FROM', SHIFT)) { 




3499




 





 





 





 





 





 



         return unless 




3500




1




  
 50
  




 





 





 





5



             $r->{from}= parse_list([], $lx, \&parse_table_as, ','); 




3501




 





 





 





 





 





 



     } 




3502




 





 





 





 





 





 



     return unless 




3503




9




  
 50
  




 





 





 





46



         $r->{join}= parse_try_list([], $lx, \&parse_join); 




3504




 





 





 





 





 





 



   




3505




9




  
 50
  




 





 





 





30



     if (looking_at($lx, 'WHERE', SHIFT)) { 




3506




 





 





 





 





 





 



         return unless 




3507




9




  
 50
  




 





 





 





210



             $r->{where}= parse_where ($lx); 




3508




 





 





 





 





 





 



     } 




3509




9




  
100
  




 





 





 





36



     if (looking_at($lx, 'ORDER BY', SHIFT)) { 




3510




 





 





 





 





 





 



         return unless 




3511




1




  
 50
  




 





 





 





4



             $r->{order_by}= parse_list([], $lx, \&parse_order, ','); 




3512




 





 





 





 





 





 



     } 




3513




9




  
100
  




 





 





 





24



     if (looking_at($lx, 'LIMIT', SHIFT)) { 




3514




1





 





 





 





 





5



         $r->{limit_cnt}= parse_limit_num($lx); 




3515




 





 





 





 





 





 



     } 




3516




 





 





 





 





 





 



   




3517




9





 





 





 





 





53



     lock_hash %$r; 




3518




9





 





 





 





 





296



     return $r; 




3519




 





 





 





 





 





 



 } 




3520




 





 





 





 





 





 



   




3521




 





 





 





 





 





 



 sub parse_delete($) 




3522




 





 





 





 





 





 



 { 




3523




4





 





 




  
4
  



  
0
  




11



     my ($lx)= @_; 




3524




4





 





 





 





 





24



     my $r= create ($lx, ['Stmt','Delete'], 




3525




 





 





 





 





 





 



         qw( 




3526




 





 





 





 





 





 



             opt_front 




3527




 





 





 





 





 





 



             from 




3528




 





 





 





 





 





 



             from_opt_front 




3529




 





 





 





 





 





 



             join 




3530




 





 





 





 





 





 



             using 




3531




 





 





 





 





 





 



             where 




3532




 





 





 





 





 





 



             order_by 




3533




 





 





 





 





 





 



             limit_cnt 




3534




 





 





 





 





 





 



             limit_offset 




3535




 





 





 





 





 





 



         ) 




3536




 





 





 





 





 





 



     ); 




3537




 





 





 





 





 





 



   




3538




4




  
 50
  




 





 





 





16



     return unless expect($lx, 'DELETE', SHIFT); 




3539




 





 





 





 





 





 



   




3540




 





 





 





 





 





 



     # PostgreSQL: 




3541




 





 





 





 





 





 



     #    - RETURNING ... 




3542




 





 





 





 





 





 



   




3543




4





 





 





 





 





12



     $r->{opt_front}= []; 




3544




4




  
 50
  




 





 





 





56



     push_option_list ($lx, $r->{opt_front}, [ 




3545




 





 





 





 





 





 



         ($read_dialect{mysql} ? 




3546




 





 





 





 





 





 



             ( 




3547




 





 





 





 





 





 



                 'IGNORE', 




3548




 





 





 





 





 





 



                 'LOW_PRIORITY', 




3549




 





 





 





 





 





 



                 'QUICK' 




3550




 





 





 





 





 





 



             ) 




3551




 





 





 





 





 





 



         :   () 




3552




 





 





 





 





 





 



         ) 




3553




 





 





 





 





 





 



     ]); 




3554




 





 





 





 





 





 



   




3555




4




  
 50
  




 





 





 





15



     return unless expect($lx, 'FROM', SHIFT); 




3556




 





 





 





 





 





 



   




3557




4





 





 





 





 





13



     $r->{from_opt_front}= []; 




3558




4




  
 50
  




 





 





 





23



     push_option ($lx, $r->{from_opt_front}, [ 




3559




 





 





 





 





 





 



         ($read_dialect{postgresql} ? 




3560




 





 





 





 





 





 



             ('ONLY') 




3561




 





 





 





 





 





 



         :   () 




3562




 





 





 





 





 





 



         ) 




3563




 





 





 





 





 





 



     ]); 




3564




 





 





 





 





 





 



   




3565




 





 





 





 





 





 



     return unless 




3566




4




  
 50
  




 





 





 





20



         $r->{from}= parse_list([], $lx, \&parse_table_as, ','); 




3567




 





 





 





 





 





 



   




3568




4




  
100
  




 





 





 





13



     if (looking_at($lx, 'USING', SHIFT)) { 




3569




 





 





 





 





 





 



         return unless 




3570




2




  
 50
  




 





 





 





9



             $r->{using}= parse_list([], $lx, \&parse_table_as, ','); 




3571




 





 





 





 





 





 



     } 




3572




 





 





 





 





 





 



   




3573




 





 





 





 





 





 



     return unless 




3574




4




  
 50
  




 





 





 





18



         $r->{join}= parse_try_list([], $lx, \&parse_join); 




3575




 





 





 





 





 





 



   




3576




4




  
100
  




 





 





 





12



     if (looking_at($lx, 'WHERE', SHIFT)) { 




3577




 





 





 





 





 





 



         return unless 




3578




3




  
 50
  




 





 





 





15



             $r->{where}= parse_where ($lx); 




3579




 





 





 





 





 





 



     } 




3580




4




  
 50
  




 





 





 





14



     if (looking_at($lx, 'ORDER BY', SHIFT)) { 




3581




 





 





 





 





 





 



         return unless 




3582




0




  
  0
  




 





 





 





0



             $r->{order_by}= parse_list([], $lx, \&parse_order, ','); 




3583




 





 





 





 





 





 



     } 




3584




4




  
 50
  




 





 





 





10



     if (looking_at($lx, 'LIMIT', SHIFT)) { 




3585




0





 





 





 





 





0



         $r->{limit_cnt}= parse_limit_num($lx); 




3586




 





 





 





 





 





 



     } 




3587




 





 





 





 





 





 



   




3588




4





 





 





 





 





15



     lock_hash %$r; 




3589




4





 





 





 





 





104



     return $r; 




3590




 





 





 





 





 





 



 } 




3591




 





 





 





 





 





 



   




3592




 





 





 





 





 





 



 sub keyword($$) 




3593




 





 





 





 





 





 



 { 




3594




1





 





 




  
1
  



  
0
  




3



     my ($lx, $keyword)= @_; 




3595




 





 





 





 





 





 



     return 




3596




1




  
 50
  




 





 





 





5



         unless $keyword; 




3597




 





 





 





 





 





 



   




3598




1




  
 50
  




 





 





 





3



     return $keyword 




3599




 





 





 





 





 





 



         if ref($keyword); 




3600




 





 





 





 





 





 



          




3601




1





 





 





 





 





4



     my $r= create($lx, 'Keyword', qw(keyword)); 




3602




1





 





 





 





 





4



     $r->{keyword}= $keyword; 




3603




1





 





 





 





 





6



     lock_hash %$r; 




3604




1





 





 





 





 





35



     return $r; 




3605




 





 





 





 





 





 



 } 




3606




 





 





 





 





 





 



   




3607




 





 





 





 





 





 



 sub parse_index_option($) 




3608




 





 





 





 





 





 



 { 




3609




1





 





 




  
1
  



  
0
  




3



     my ($lx)= @_; 




3610




1





 





 





 





 





2



     my $r= create($lx, 'IndexOption', qw(arg)); 




3611




 





 





 





 





 





 



   




3612




 





 





 





 





 





 



     parse_choice($lx, 




3613




 





 





 





 





 





 



         -default => sub { 




3614




1





 





 




  
1
  




 





4



             $r= undef; 




3615




 





 





 





 





 





 



         }, 




3616




 





 





 





 





 





 



   




3617




 





 





 





 





 





 



         # MySQL does not like it here, but only accepts it in front of the 




3618




 





 





 





 





 





 



         # column list, which is against the manual's description. 




3619




 





 





 





 





 





 



         #'USING' => sub { 




3620




 





 





 





 





 





 



         #    lexer_shift($lx); 




3621




 





 





 





 





 





 



         #    return unless 




3622




 





 





 





 





 





 



         #        my $t= expect($lx, ['BTREE','HASH','RTREE'], SHIFT); 




3623




 





 





 





 





 





 



         #    $r->{type}= 'using'; 




3624




 





 





 





 





 





 



         #    $r->{arg}=  $t; 




3625




 





 





 





 





 





 



         #}, 




3626




1





 





 





 





 





6



     ); 




3627




1




  
 50
  




 





 





 





12



     return unless $r; 




3628




0




  
  0
  




 





 





 





0



     return if $lx->{error}; 




3629




 





 





 





 





 





 



   




3630




0





 





 





 





 





0



     lock_hash %$r; 




3631




0





 





 





 





 





0



     return $r; 




3632




 





 





 





 





 





 



 } 




3633




 





 





 





 





 





 



   




3634




 





 





 





 





 





 



 sub parse_index_type ($) 




3635




 





 





 





 





 





 



 { 




3636




3





 





 




  
3
  



  
0
  




3



     my ($lx)= @_; 




3637




3




  
100
  




 





 





 





8



     if (looking_at($lx, 'USING', SHIFT)) { 




3638




1





 





 





 





 





5



         return expect($lx, ['BTREE','HASH','RTREE'], SHIFT); 




3639




 





 





 





 





 





 



     } 




3640




2





 





 





 





 





4



     return; 




3641




 





 





 





 





 





 



 } 




3642




 





 





 





 





 





 



   




3643




 





 





 





 





 





 



 sub parse_table_constraint($) 




3644




 





 





 





 





 





 



 { 




3645




3





 





 




  
3
  



  
0
  




6



     my ($lx)= @_; 




3646




3





 





 





 





 





9



     my $r= create($lx, "TableConstraint", qw(constraint index_type column index_option reference)); 




3647




3





 





 





 





 





9



     $r->{index_option}= []; 




3648




 





 





 





 





 





 



   




3649




3




  
 50
  




 





 





 





8



     if (looking_at($lx, 'CONSTRAINT', SHIFT)) { 




3650




 





 





 





 





 





 



         return unless 




3651




3




  
 50
  




 





 





 





8



             $r->{constraint}= parse_constraint($lx); 




3652




 





 





 





 





 





 



     } 




3653




 





 





 





 





 





 



   




3654




 





 





 





 





 





 



     parse_choice($lx, 




3655




 





 





 





 





 





 



         'PRIMARY KEY' => sub { 




3656




0





 





 




  
0
  




 





0



             lexer_shift($lx); 




3657




0





 





 





 





 





0



             $r->{type}=  'primary_key'; 




3658




0





 





 





 





 





0



             $r->{index_type}= parse_index_type($lx); 




3659




 





 





 





 





 





 



             return unless 




3660




0




  
  0
  



  
  0
  




 





 





0



                 $r->{column}= parse_list_delim($lx, \&parse_column_index) 




3661




 





 





 





 





 





 



             and $r->{index_option}= parse_try_list([], $lx, \&parse_index_option); 




3662




 





 





 





 





 





 



         }, 




3663




 





 





 





 





 





 



         'UNIQUE' => sub { 




3664




1





 





 




  
1
  




 





4



             lexer_shift($lx); 




3665




1





 





 





 





 





2



             $r->{type}= 'unique'; 




3666




1





 





 





 





 





4



             $r->{index_type}= parse_index_type($lx); 




3667




 





 





 





 





 





 



             return unless 




3668




1




  
 50
  



  
 33
  




 





 





6



                 $r->{column}= parse_list_delim($lx, \&parse_column_index) 




3669




 





 





 





 





 





 



             and $r->{index_option}= parse_try_list([], $lx, \&parse_index_option); 




3670




 





 





 





 





 





 



         }, 




3671




 





 





 





 





 





 



         'FULLTEXT' => sub { 




3672




0





 





 




  
0
  




 





0



             lexer_shift($lx); 




3673




0





 





 





 





 





0



             $r->{type}= 'fulltext'; 




3674




0





 





 





 





 





0



             $r->{index_type}= parse_index_type($lx); 




3675




 





 





 





 





 





 



             return unless 




3676




0




  
  0
  



  
  0
  




 





 





0



                 $r->{column}= parse_list_delim($lx, \&parse_column_index) 




3677




 





 





 





 





 





 



             and $r->{index_option}= parse_try_list([], $lx, \&parse_index_option); 




3678




 





 





 





 





 





 



         }, 




3679




 





 





 





 





 





 



         'SPATIAL' => sub { 




3680




0





 





 




  
0
  




 





0



             lexer_shift($lx); 




3681




0





 





 





 





 





0



             $r->{type}= 'spatial'; 




3682




0





 





 





 





 





0



             $r->{index_type}= parse_index_type($lx); 




3683




 





 





 





 





 





 



             return unless 




3684




0




  
  0
  



  
  0
  




 





 





0



                 $r->{column}= parse_list_delim($lx, \&parse_column_index) 




3685




 





 





 





 





 





 



             and $r->{index_option}= parse_try_list([], $lx, \&parse_index_option); 




3686




 





 





 





 





 





 



         }, 




3687




 





 





 





 





 





 



         'FOREIGN KEY' => sub { 




3688




2





 





 




  
2
  




 





6



             lexer_shift($lx); 




3689




2





 





 





 





 





5



             $r->{type}= 'foreign_key'; 




3690




2





 





 





 





 





5



             $r->{index_type}= parse_index_type($lx); 




3691




 





 





 





 





 





 



             return unless 




3692




2




  
 50
  



  
 33
  




 





 





8



                 $r->{column}= parse_list_delim($lx, \&parse_column_name) 




3693




 





 





 





 





 





 



             and $r->{reference}= parse_references($lx); 




3694




 





 





 





 





 





 



         }, 




3695




 





 





 





 





 





 



         # 'CHECK' => sub { 




3696




 





 





 





 





 





 



         # }, 




3697




 





 





 





 





 





 



         ($read_dialect{mysql} ? 




3698




 





 





 





 





 





 



             ( 




3699




 





 





 





 





 





 



                 'INDEX' => sub { 




3700




0





 





 




  
0
  




 





0



                     lexer_shift($lx); 




3701




0





 





 





 





 





0



                     $r->{type}= 'index'; 




3702




 





 





 





 





 





 



                     # FIXME: mysql allows an index name here 




3703




 





 





 





 





 





 



                     return unless 




3704




0




  
  0
  




 





 





 





0



                         $r->{column}= parse_list_delim($lx, \&parse_column_index); 




3705




0





 





 





 





 





0



                     $r->{index_option}= parse_try_list([], $lx, \&parse_index_option); 




3706




 





 





 





 





 





 



                 } 




3707




 





 





 





 





 





 



             ) 




3708




3




  
 50
  




 





 





 





45



         :   () 




3709




 





 





 





 





 





 



         ), 




3710




 





 





 





 





 





 



     ); 




3711




3




  
 50
  




 





 





 





84



     return if $lx->{error}; 




3712




 





 





 





 





 





 



   




3713




3





 





 





 





 





9



     lock_hash %$r; 




3714




3





 





 





 





 





63



     return $r; 




3715




 





 





 





 





 





 



 } 




3716




 





 





 





 





 





 



   




3717




 





 





 





 





 





 



 sub parse_table_option1($$$$) 




3718




 





 





 





 





 





 



 { 




3719




6





 





 




  
6
  



  
0
  




56



     my ($lx, $r, $name, $parse)= @_; 




3720




6





 





 





 





 





11



     $r->{type}= 'literal'; 




3721




6





 





 





 





 





10



     $r->{name}= $name; 




3722




6





 





 





 





 





16



     lexer_shift($lx); 




3723




6





 





 





 





 





15



     looking_at($lx, '=', SHIFT); # optional = 




3724




 





 





 





 





 





 



     return unless 




3725




6




  
 50
  




 





 





 





19



         $r->{value}= $parse->($lx); 




3726




6





 





 





 





 





15



     while (looking_at($lx, ',', SHIFT)) {} # optional , 




3727




6





 





 





 





 





15



     return $r; 




3728




 





 





 





 





 





 



 } 




3729




 





 





 





 





 





 



   




3730




 





 





 





 





 





 



 sub parse_on_commit_action($) 




3731




 





 





 





 





 





 



 { 




3732




1





 





 




  
1
  



  
0
  




2



     my ($lx)= @_; 




3733




1




  
 50
  




 





 





 





8



     return keyword ($lx, 




3734




 





 





 





 





 





 



         expect($lx, 




3735




 





 





 





 





 





 



             [ 




3736




 





 





 





 





 





 



                 'PRESERVE ROWS', 




3737




 





 





 





 





 





 



                 'DELETE ROWS', 




3738




 





 





 





 





 





 



                 ($read_dialect{postgresql} ? 




3739




 





 





 





 





 





 



                     ( 




3740




 





 





 





 





 





 



                         'DROP' 




3741




 





 





 





 





 





 



                     ) 




3742




 





 





 





 





 





 



                 :   () 




3743




 





 





 





 





 





 



                 ) 




3744




 





 





 





 





 





 



             ], 




3745




 





 





 





 





 





 



             SHIFT 




3746




 





 





 





 





 





 



         ) 




3747




 





 





 





 





 





 



     ); 




3748




 





 





 





 





 





 



 } 




3749




 





 





 





 





 





 



   




3750




 





 





 





 





 





 



 sub parse_table_option($) 




3751




 





 





 





 





 





 



 { 




3752




12





 





 




  
12
  



  
0
  




18



     my ($lx)= @_; 




3753




12





 





 





 





 





30



     my $r= create($lx, 'TableOption', qw(name value token)); 




3754




 





 





 





 





 





 



   




3755




 





 





 





 





 





 



     parse_choice($lx, 




3756




 





 





 





 





 





 



         -default => sub { 




3757




4





 





 




  
4
  




 





12



             $r= undef; 




3758




 





 





 





 





 





 



         }, 




3759




 





 





 





 





 





 



   




3760




 





 





 





 





 





 



         ($read_dialect{mysql} ? 




3761




 





 





 





 





 





 



             ( 




3762




 





 





 





 





 





 



                 'ENGINE' => sub { 




3763




2





 





 




  
2
  




 





12



                     return parse_table_option1($lx, $r, 'ENGINE', \&parse_engine); 




3764




 





 





 





 





 





 



                 }, 




3765




 





 





 





 





 





 



          




3766




 





 





 





 





 





 



                 'CHARACTER SET' => 'DEFAULT CHARACTER SET', 




3767




 





 





 





 





 





 



                 'DEFAULT CHARACTER SET' => sub { 




3768




2





 





 




  
2
  




 





7



                     return parse_table_option1($lx, $r, 'DEFAULT CHARACTER SET', \&parse_charset); 




3769




 





 





 





 





 





 



                 }, 




3770




 





 





 





 





 





 



   




3771




 





 





 





 





 





 



                 'COLLATE' => 'DEFAULT COLLATE', 




3772




 





 





 





 





 





 



                 'DEFAULT COLLATE' => sub { 




3773




0





 





 




  
0
  




 





0



                     return parse_table_option1($lx, $r, 'DEFAULT COLLATE', \&parse_collate); 




3774




 





 





 





 





 





 



                 }, 




3775




 





 





 





 





 





 



   




3776




 





 





 





 





 





 



                 'AUTO_INCREMENT' => sub { 




3777




0





 





 




  
0
  




 





0



                     return parse_table_option1($lx, $r, 'AUTO_INCREMENT', \&parse_expr); 




3778




 





 





 





 





 





 



                 }, 




3779




 





 





 





 





 





 



   




3780




 





 





 





 





 





 



                 'COMMENT' => sub { 




3781




1





 





 




  
1
  




 





5



                     return parse_table_option1($lx, $r, 'COMMENT', \&parse_expr); 




3782




 





 





 





 





 





 



                 }, 




3783




 





 





 





 





 





 



             ) 




3784




 





 





 





 





 





 



         :   () 




3785




 





 





 





 





 





 



         ), 




3786




 





 





 





 





 





 



   




3787




 





 





 





 





 





 



         'ON COMMIT' => sub { 




3788




1





 





 




  
1
  




 





2



             return parse_table_option1($lx, $r, 'ON COMMIT', \&parse_on_commit_action); 




3789




 





 





 





 





 





 



         }, 




3790




 





 





 





 





 





 



   




3791




 





 





 





 





 





 



         'interpolTableOption' => 'interpol', 




3792




 





 





 





 





 





 



         'interpol' => sub { 




3793




2





 





 




  
2
  




 





13



             $r->{type}= 'interpol'; 




3794




2





 





 





 





 





6



             $r->{token}= $lx->{token}; 




3795




2





 





 





 





 





7



             lexer_shift($lx); 




3796




2





 





 





 





 





7



             while (looking_at($lx, ',', SHIFT)) {} # optional , 




3797




2





 





 





 





 





6



             return $r; 




3798




 





 





 





 





 





 



         }, 




3799




12




  
 50
  




 





 





 





196



     ); 




3800




12




  
100
  




 





 





 





254



     return unless $r; 




3801




8




  
 50
  




 





 





 





23



     return if $lx->{error}; 




3802




8





 





 





 





 





28



     lock_hash %$r; 




3803




8





 





 





 





 





156



     return $r; 




3804




 





 





 





 





 





 



 } 




3805




 





 





 





 





 





 



   




3806




 





 





 





 





 





 



 sub parse_column_def($) 




3807




 





 





 





 





 





 



 { 




3808




6





 





 




  
6
  



  
0
  




13



     my ($lx)= @_; 




3809




6





 





 





 





 





16



     my $r= create($lx, 'ColumnDef', qw(name column_spec)); 




3810




 





 





 





 





 





 



     return unless 




3811




6




  
 50
  



  
 33
  




 





 





19



         $r->{name}=        parse_column_name($lx) 




3812




 





 





 





 





 





 



     and $r->{column_spec}= parse_column_spec($lx); 




3813




6





 





 





 





 





26



     lock_hash %$r; 




3814




6





 





 





 





 





121



     return $r; 




3815




 





 





 





 





 





 



 } 




3816




 





 





 





 





 





 



   




3817




 





 





 





 





 





 



 sub parse_column_def_or_option($) 




3818




 





 





 





 





 





 



 { 




3819




6





 





 




  
6
  



  
0
  




10



     my ($lx)= @_; 




3820




 





 





 





 





 





 



     return parse_choice($lx, 




3821




 





 





 





 





 





 



         'interpol' => 'ident', 




3822




 





 





 





 





 





 



         'ident' => sub { 




3823




4





 





 




  
4
  




 





11



             return parse_column_def($lx); 




3824




 





 





 





 





 





 



         }, 




3825




 





 





 





 





 





 



         -default => sub { 




3826




2





 





 




  
2
  




 





7



             return parse_table_constraint($lx); 




3827




 





 





 





 





 





 



         }, 




3828




6





 





 





 





 





45



     ); 




3829




 





 





 





 





 





 



 } 




3830




 





 





 





 





 





 



   




3831




 





 





 





 





 





 



 sub parse_create_table($) 




3832




 





 





 





 





 





 



 { 




3833




2





 





 




  
2
  



  
0
  




4



     my ($lx)= @_; 




3834




 





 





 





 





 





 



     return unless 




3835




2




  
 50
  




 





 





 





10



         expect($lx, \@CREATE_TABLE_INITIAL); 




3836




 





 





 





 





 





 



   




3837




2





 





 





 





 





11



     my $r= create($lx, ['Stmt','CreateTable'], 




3838




 





 





 





 





 





 



                   qw(subtype if_not_exists table column_def tabconstr tableopt select)); 




3839




2





 





 





 





 





9



     $r->{subtype}= lexer_shift($lx); 




3840




 





 





 





 





 





 



   




3841




2




  
100
  



  
 66
  




 





 





19



     if ($read_dialect{mysql} && 




3842




 





 





 





 





 





 



         looking_at($lx, 'IF NOT EXISTS', SHIFT)) 




3843




 





 





 





 





 





 



     { 




3844




1





 





 





 





 





2



         $r->{if_not_exists}= 1; 




3845




 





 





 





 





 





 



     } 




3846




 





 





 





 





 





 



   




3847




 





 





 





 





 





 



     return unless 




3848




2




  
 50
  




 





 





 





8



         $r->{table}= parse_table($lx); 




3849




 





 





 





 





 





 



   




3850




2





 





 





 





 





5



     $r->{column_def}= []; 




3851




2





 





 





 





 





5



     $r->{tabconstr}=  []; 




3852




2




  
 50
  




 





 





 





7



     if (looking_at($lx, '(')) { 




3853




 





 





 





 





 





 



         return unless 




3854




2




  
 50
  




 





 





 





8



             my $spec= parse_list_delim($lx, \&parse_column_def_or_option); 




3855




 





 





 





 





 





 



   




3856




2





 





 





 





 





6



         $r->{column_def}= [ grep { $_->{kind} eq 'ColumnDef' } @$spec ]; 




 




6





 





 





 





 





24



   




3857




2





 





 





 





 





7



         $r->{tabconstr}=  [ grep { $_->{kind} ne 'ColumnDef' } @$spec ]; 




 




6





 





 





 





 





18



   




3858




 





 





 





 





 





 



     } 




3859




 





 





 





 





 





 



   




3860




 





 





 





 





 





 



     return unless 




3861




2




  
 50
  




 





 





 





15



         $r->{tableopt}= parse_try_list([], $lx, \&parse_table_option); 




3862




 





 





 





 





 





 



   




3863




2




  
100
  



  
 66
  




 





 





9



     if (looking_at($lx, 'AS', SHIFT) || 




3864




 





 





 





 





 





 



         looking_at($lx, \@SELECT_INITIAL)) 




3865




 





 





 





 





 





 



     { 




3866




 





 





 





 





 





 



         return unless 




3867




1




  
 50
  




 





 





 





5



             $r->{select}= parse_select($lx); 




3868




 





 





 





 





 





 



     } 




3869




 





 





 





 





 





 



   




3870




2




  
 50
  



  
 33
  




 





 





4



     unless (scalar(@{ $r->{column_def} }) || $r->{select}) { 




 




2





 





 





 





 





13



   




3871




0





 





 





 





 





0



         $lx->{error}= 'Either query or at least one column expected'; 




3872




0





 





 





 





 





0



         return; 




3873




 





 





 





 





 





 



     } 




3874




 





 





 





 





 





 



   




3875




2





 





 





 





 





10



     lock_hash %$r; 




3876




2





 





 





 





 





54



     return $r; 




3877




 





 





 





 





 





 



 } 




3878




 





 





 





 





 





 



   




3879




 





 





 





 





 





 



 sub parse_drop_table($) 




3880




 





 





 





 





 





 



 { 




3881




1





 





 




  
1
  



  
0
  




3



     my ($lx)= @_; 




3882




 





 





 





 





 





 



     return unless 




3883




1




  
 50
  




 





 





 





4



         expect($lx, \@DROP_TABLE_INITIAL); 




3884




 





 





 





 





 





 



   




3885




1





 





 





 





 





6



     my $r= create($lx, ['Stmt','DropTable'], 




3886




 





 





 





 





 





 



                   qw(subtype if_exists table cascade)); 




3887




1





 





 





 





 





4



     $r->{subtype}= lexer_shift($lx); 




3888




 





 





 





 





 





 



   




3889




1




  
 50
  



  
 33
  




 





 





10



     if ($read_dialect{mysql} && 




3890




 





 





 





 





 





 



         looking_at($lx, 'IF EXISTS', SHIFT)) 




3891




 





 





 





 





 





 



     { 




3892




1





 





 





 





 





2



         $r->{if_exists}= 1; 




3893




 





 





 





 





 





 



     } 




3894




 





 





 





 





 





 



   




3895




 





 





 





 





 





 



     return unless 




3896




1




  
 50
  




 





 





 





6



         $r->{table}= parse_list([], $lx, \&parse_table, ','); 




3897




 





 





 





 





 





 



   




3898




1





 





 





 





 





4



     $r->{cascade}= looking_at($lx, ['RESTRICT','CASCADE'], SHIFT); 




3899




 





 





 





 





 





 



   




3900




1





 





 





 





 





6



     lock_hash %$r; 




3901




1





 





 





 





 





20



     return $r; 




3902




 





 





 





 





 





 



 } 




3903




 





 





 





 





 





 



   




3904




 





 





 





 





 





 



 sub parse_column_pos_perhaps($) 




3905




 





 





 





 





 





 



 { 




3906




3





 





 




  
3
  



  
0
  




6



     my ($lx)= @_; 




3907




 





 





 





 





 





 



     return parse_choice($lx, 




3908




 





 





 





 





 





 



         -default => sub { 




3909




1





 





 




  
1
  




 





6



             return; 




3910




 





 





 





 





 





 



         }, 




3911




 





 





 





 





 





 



         'FIRST' => sub { 




3912




1





 





 




  
1
  




 





3



             return lexer_shift($lx); 




3913




 





 





 





 





 





 



         }, 




3914




 





 





 





 





 





 



         'AFTER' => sub { 




3915




1





 





 




  
1
  




 





5



             lexer_shift($lx); 




3916




1





 





 





 





 





4



             return ('AFTER', parse_column_name($lx)); 




3917




 





 





 





 





 





 



         }, 




3918




3





 





 





 





 





24



     ); 




3919




 





 





 





 





 





 



 } 




3920




 





 





 





 





 





 



   




3921




 





 





 





 





 





 



 sub parse_alter_table($) 




3922




 





 





 





 





 





 



 { 




3923




20





 





 




  
20
  



  
0
  




24



     my ($lx)= @_; 




3924




 





 





 





 





 





 



     return unless 




3925




20




  
 50
  




 





 





 





42



         expect($lx, \@ALTER_TABLE_INITIAL); 




3926




 





 





 





 





 





 



   




3927




20





 





 





 





 





74



     my $r= create($lx, ['Stmt','AlterTable'], 




3928




 





 





 





 





 





 



                   qw(subtype functor subfunctor arg online ignore table only)); 




3929




20





 





 





 





 





59



     $r->{subtype}= lexer_shift($lx); 




3930




20





 





 





 





 





35



     $r->{arg}=     []; 




3931




 





 





 





 





 





 



   




3932




 





 





 





 





 





 



     return unless 




3933




20




  
 50
  




 





 





 





49



         $r->{table}= parse_table($lx); 




3934




 





 





 





 





 





 



   




3935




20





 





 





 





 





42



     $r->{only}= looking_at($lx, 'ONLY', SHIFT); 




3936




 





 





 





 





 





 



   




3937




 





 





 





 





 





 



     parse_choice($lx, 




3938




 





 





 





 





 





 



         'DROP CONSTRAINT' => sub { 




3939




1





 





 




  
1
  




 





3



             $r->{functor}= lexer_shift($lx); 




3940




 





 





 





 





 





 



             return unless 




3941




1




  
 50
  




 





 





 





6



                 my $constraint= parse_constraint($lx); 




3942




1





 





 





 





 





2



             push @{ $r->{arg} }, $constraint, looking_at($lx, ['RESTRICT','CASCADE'], SHIFT); 




 




1





 





 





 





 





5



   




3943




 





 





 





 





 





 



         }, 




3944




 





 





 





 





 





 



   




3945




 





 





 





 





 





 



         'DROP COLUMN' => sub { 




3946




3





 





 




  
3
  




 





8



             $r->{functor}= lexer_shift($lx); 




3947




 





 





 





 





 





 



             return unless 




3948




3




  
 50
  




 





 





 





7



                 my $column= parse_column_name($lx); 




3949




3





 





 





 





 





5



             push @{ $r->{arg} }, $column, looking_at($lx, ['RESTRICT','CASCADE'], SHIFT); 




 




3





 





 





 





 





11



   




3950




 





 





 





 





 





 



         }, 




3951




 





 





 





 





 





 



   




3952




 





 





 





 





 





 



         'RENAME COLUMN' => sub { 




3953




1





 





 




  
1
  




 





3



             $r->{functor}= lexer_shift($lx); 




3954




 





 





 





 





 





 



   




3955




 





 





 





 





 





 



             return unless 




3956




1




  
 50
  



  
 33
  




 





 





4



                 my $column= parse_column_name($lx) 




 




 





 




  
 33
  




 





 





 



   




3957




 





 





 





 





 





 



             and expect($lx, 'TO', SHIFT) 




3958




 





 





 





 





 





 



             and my $column2= parse_column_name($lx); 




3959




 





 





 





 





 





 



   




3960




1





 





 





 





 





3



             push @{ $r->{arg} }, $column, 'TO', $column2; 




 




1





 





 





 





 





4



   




3961




 





 





 





 





 





 



         }, 




3962




 





 





 





 





 





 



   




3963




 





 





 





 





 





 



         'DROP PRIMARY KEY' => sub { 




3964




1





 





 




  
1
  




 





4



             $r->{functor}= lexer_shift($lx); 




3965




 





 





 





 





 





 



         }, 




3966




 





 





 





 





 





 



   




3967




 





 





 





 





 





 



         'ALTER COLUMN' => sub { 




3968




6





 





 




  
6
  




 





10



             $r->{functor}= lexer_shift($lx); 




3969




6





 





 





 





 





9



             push @{ $r->{arg} }, parse_column_name($lx); 




 




6





 





 





 





 





20



   




3970




6




  
 50
  




 





 





 





18



             return if $lx->{error}; 




3971




 





 





 





 





 





 



   




3972




 





 





 





 





 





 



             parse_choice($lx, 




3973




 





 





 





 





 





 



                 'DROP DEFAULT'  => 'SET NOT NULL', 




3974




 





 





 





 





 





 



                 'DROP NOT NULL' => 'SET NOT NULL', 




3975




 





 





 





 





 





 



                 'SET NOT NULL'  => sub { 




3976




3





 





 





 





 





3



                     push @{ $r->{arg} }, lexer_shift($lx); 




 




3





 





 





 





 





10



   




3977




 





 





 





 





 





 



                 }, 




3978




 





 





 





 





 





 



   




3979




 





 





 





 





 





 



                 'SET DEFAULT' => sub { 




3980




1





 





 





 





 





2



                     push @{ $r->{arg} }, lexer_shift($lx); 




 




1





 





 





 





 





4



   




3981




1





 





 





 





 





2



                     push @{ $r->{arg} }, parse_expr($lx); 




 




1





 





 





 





 





3



   




3982




 





 





 





 





 





 



                 }, 




3983




 





 





 





 





 





 



   




3984




 





 





 





 





 





 



                 ($read_dialect{postgresql} ? 




3985




 





 





 





 





 





 



                     ( 




3986




 





 





 





 





 





 



                         'TYPE' => sub { 




3987




2





 





 





 





 





3



                             push @{ $r->{arg} }, lexer_shift($lx); 




 




2





 





 





 





 





6



   




3988




2





 





 





 





 





3



                             push @{ $r->{arg} }, parse_type($lx); 




 




2





 





 





 





 





7



   




3989




2




  
 50
  




 





 





 





7



                             return if $lx->{error}; 




3990




2




  
100
  




 





 





 





4



                             if (my $x= looking_at($lx, 'USING', SHIFT)) { 




3991




1





 





 





 





 





2



                                 push @{ $r->{arg} }, $x, parse_expr($lx); 




 




1





 





 





 





 





5



   




3992




 





 





 





 





 





 



                             } 




3993




 





 





 





 





 





 



                         } 




3994




 





 





 





 





 





 



                     ) 




3995




6




  
 50
  




 





 





 





48



                 :   () 




3996




 





 





 





 





 





 



                 ), 




3997




 





 





 





 





 





 



             ); 




3998




 





 





 





 





 





 



         }, 




3999




 





 





 





 





 





 



   




4000




 





 





 





 





 





 



         'RENAME TO' => sub { 




4001




1





 





 




  
1
  




 





4



             $r->{functor}= lexer_shift($lx); 




4002




1





 





 





 





 





2



             push @{ $r->{arg} }, parse_table($lx); 




 




1





 





 





 





 





4



   




4003




 





 





 





 





 





 



         }, 




4004




 





 





 





 





 





 



   




4005




 





 





 





 





 





 



         'ADD COLUMN' => sub { 




4006




2





 





 




  
2
  




 





5



             $r->{functor}= lexer_shift($lx); 




4007




2




  
100
  




 





 





 





5



             if (looking_at($lx, '(', SHIFT)) { 




4008




1





 





 





 





 





2



                 push @{ $r->{arg} }, parse_list([], $lx, \&parse_column_def, ','); 




 




1





 





 





 





 





5



   




4009




1




  
 50
  




 





 





 





7



                 return if $lx->{error}; 




4010




1





 





 





 





 





4



                 expect($lx, ')', SHIFT); 




4011




 





 





 





 





 





 



             } 




4012




 





 





 





 





 





 



             else { 




4013




 





 





 





 





 





 



                 return unless 




4014




1




  
 50
  



  
 33
  




 





 





5



                     my $col1= parse_column_name($lx) 




4015




 





 





 





 





 





 



                 and my $spec= parse_column_spec($lx); 




4016




1





 





 





 





 





2



                 push @{ $r->{arg} }, $col1, $spec, parse_column_pos_perhaps($lx); 




 




1





 





 





 





 





6



   




4017




 





 





 





 





 





 



             } 




4018




 





 





 





 





 





 



         }, 




4019




 





 





 





 





 





 



   




4020




 





 





 





 





 





 



         'ADD' => sub { 




4021




1





 





 




  
1
  




 





4



             $r->{functor}= lexer_shift($lx); 




4022




1





 





 





 





 





2



             push @{ $r->{arg} }, parse_table_constraint($lx); 




 




1





 





 





 





 





4



   




4023




 





 





 





 





 





 



         }, 




4024




 





 





 





 





 





 



   




4025




 





 





 





 





 





 



         ($read_dialect{mysql} ? 




4026




 





 





 





 





 





 



             ( 




4027




 





 





 





 





 





 



                 'MODIFY COLUMN' => sub { 




4028




1





 





 




  
1
  




 





3



                     $r->{functor}= lexer_shift($lx); 




4029




 





 





 





 





 





 



                     return unless 




4030




1




  
 50
  



  
 33
  




 





 





4



                         my $col1= parse_column_name($lx) 




4031




 





 





 





 





 





 



                     and my $spec= parse_column_spec($lx); 




4032




1





 





 





 





 





4



                     push @{ $r->{arg} }, $col1, $spec, parse_column_pos_perhaps($lx); 




 




1





 





 





 





 





6



   




4033




 





 





 





 





 





 



                 }, 




4034




 





 





 





 





 





 



                 'CHANGE COLUMN' => sub { 




4035




1





 





 




  
1
  




 





3



                     $r->{functor}= lexer_shift($lx); 




4036




 





 





 





 





 





 



                     return unless 




4037




1




  
 50
  



  
 33
  




 





 





3



                         my $col1= parse_column_name($lx) 




 




 





 




  
 33
  




 





 





 



   




4038




 





 





 





 





 





 



                     and my $col2= parse_column_name($lx) 




4039




 





 





 





 





 





 



                     and my $spec= parse_column_spec($lx); 




4040




1





 





 





 





 





3



                     push @{ $r->{arg} }, $col1, $col2, $spec, parse_column_pos_perhaps($lx); 




 




1





 





 





 





 





4



   




4041




 





 





 





 





 





 



                 }, 




4042




 





 





 





 





 





 



                 'DROP FOREIGN KEY' => sub { # standard SQL: DROP CONSTRAINT 




4043




1





 





 




  
1
  




 





4



                     $r->{functor}= lexer_shift($lx); 




4044




 





 





 





 





 





 



                     return unless 




4045




1




  
 50
  




 





 





 





4



                         my $constraint= parse_constraint($lx); 




4046




1





 





 





 





 





3



                     push @{ $r->{arg} }, $constraint; 




 




1





 





 





 





 





5



   




4047




 





 





 





 





 





 



                 }, 




4048




 





 





 





 





 





 



                 'DROP INDEX' => sub { 




4049




1





 





 




  
1
  




 





4



                     $r->{functor}= lexer_shift($lx); 




4050




 





 





 





 





 





 



                     return unless 




4051




1




  
 50
  




 





 





 





6



                         my $index= parse_index($lx); 




4052




1





 





 





 





 





3



                     push @{ $r->{arg} }, $index; 




 




1





 





 





 





 





6



   




4053




 





 





 





 





 





 



                 }, 




4054




 





 





 





 





 





 



             ) 




4055




20




  
 50
  




 





 





 





412



         :   () 




4056




 





 





 





 





 





 



         ), 




4057




 





 





 





 





 





 



     ); 




4058




20




  
 50
  




 





 





 





857



     return if $lx->{error}; 




4059




 





 





 





 





 





 



   




4060




20





 





 





 





 





56



     lock_hash %$r; 




4061




20





 





 





 





 





497



     return $r; 




4062




 





 





 





 





 





 



 } 




4063




 





 





 





 





 





 



   




4064




 





 





 





 





 





 



 sub parse_stmt_interpol($) 




4065




 





 





 





 





 





 



 { 




4066




3





 





 




  
3
  



  
0
  




8



     my ($lx)= @_; 




4067




 





 





 





 





 





 



   




4068




 





 





 





 





 





 



     # Some interpols will never be good statements, so issue an error as early 




4069




 





 





 





 





 





 



     # as possible (i.e., at compile time instead of at runtime): 




4070




3




  
 50
  



  
 33
  




 





 





32



     if ($lx->{token}{type} eq 'num' || 




4071




 





 





 





 





 





 



         $lx->{token}{type} eq 'string') 




4072




 





 





 





 





 





 



     { 




4073




0





 





 





 





 





0



         $lx->{error}= "Expected 'Stmt', but found $lx->{token}{type}"; 




4074




0





 





 





 





 





0



         return; 




4075




 





 





 





 





 





 



     } 




4076




 





 





 





 





 





 



   




4077




3




  
 50
  




 





 





 





14



     if (! $lx->{token}{type}) { 




4078




0





 





 





 





 





0



         $lx->{error}= "Expected 'Stmt', but found $lx->{token}{kind}"; 




4079




0





 





 





 





 





0



         return; 




4080




 





 





 





 





 





 



     } 




4081




 





 





 





 





 





 



   




4082




3




  
 50
  




 





 





 





13



     if ($lx->{token}{perltype} eq 'hash') { 




4083




0





 





 





 





 





0



         $lx->{error}= "Expected scalar or array, but found $lx->{token}{perltype}."; 




4084




0





 





 





 





 





0



         return; 




4085




 





 





 





 





 





 



     } 




4086




 





 





 





 





 





 



   




4087




 





 





 





 





 





 



     # But some may be: 




4088




3





 





 





 





 





16



     my $r= create ($lx, ['Stmt','Interpol'], qw(token)); 




4089




3





 





 





 





 





11



     $r->{token}= $lx->{token}; 




4090




3





 





 





 





 





11



     lexer_shift($lx); 




4091




 





 





 





 





 





 



   




4092




3





 





 





 





 





17



     lock_hash %$r; 




4093




3





 





 





 





 





82



     return $r; 




4094




 





 





 





 





 





 



 } 




4095




 





 





 





 





 





 



   




4096




 





 





 





 





 





 



 sub parse_select_stmt($) 




4097




 





 





 





 





 





 



 { 




4098




6





 





 




  
6
  



  
0
  




15



     my ($lx)= @_; 




4099




 





 





 





 





 





 



     return parse_choice($lx, 




4100




6





 





 




  
6
  




 





25



         'SELECT'   => sub { parse_select ($lx) }, 




4101




 





 





 





 





 





 



   




4102




 





 





 





 





 





 



         'interpolStmt' => 'interpol', 




4103




0





 





 




  
0
  




 





0



         'interpol' => sub { parse_stmt_interpol ($lx) }, 




4104




6





 





 





 





 





45



     ); 




4105




 





 





 





 





 





 



 } 




4106




 





 





 





 





 





 



   




4107




 





 





 





 





 





 



 sub parse_stmt($) 




4108




 





 





 





 





 





 



 { 




4109




225





 





 




  
225
  



  
0
  




432



     my ($lx)= @_; 




4110




 





 





 





 





 





 



     return parse_choice($lx, 




4111




173





 





 




  
173
  




 





560



         'SELECT'   => sub { parse_select ($lx) }, 




4112




13





 





 




  
13
  




 





43



         'INSERT'   => sub { parse_insert ($lx) }, 




4113




9





 





 




  
9
  




 





33



         'UPDATE'   => sub { parse_update ($lx) }, 




4114




4





 





 




  
4
  




 





20



         'DELETE'   => sub { parse_delete ($lx) }, 




4115




 





 





 





 





 





 



   




4116




1350





 





 





 





 





2757



         (map { $_ => 'CREATE TABLE' } @CREATE_TABLE_INITIAL), 




4117




2





 





 




  
2
  




 





9



         'CREATE TABLE' => sub { parse_create_table($lx) }, 




4118




 





 





 





 





 





 



   




4119




450





 





 





 





 





1360



         (map { $_ => 'DROP TABLE' } @DROP_TABLE_INITIAL), 




4120




1





 





 




  
1
  




 





6



         'DROP TABLE' => sub { parse_drop_table($lx) }, 




4121




 





 





 





 





 





 



   




4122




1350





 





 





 





 





3327



         (map { $_ => 'ALTER TABLE' } @ALTER_TABLE_INITIAL), 




4123




20





 





 




  
20
  




 





46



         'ALTER TABLE' => sub { parse_alter_table($lx) }, 




4124




 





 





 





 





 





 



   




4125




 





 





 





 





 





 



         'interpolStmt' => 'interpol', 




4126




3





 





 




  
3
  




 





15



         'interpol' => sub { parse_stmt_interpol ($lx) }, 




4127




225





 





 





 





 





2135



     ); 




4128




 





 





 





 





 





 



 } 




4129




 





 





 





 





 





 



   




4130




 





 





 





 





 





 



 ###################################################################### 




4131




 





 





 





 





 





 



 # Perl generation: 




4132




 





 





 





 





 





 



   




4133




 





 





 





 





 





 



   




4134




 





 





 





 





 





 



 ## First: creating a list of strings. 




4135




 





 





 





 





 





 



 # 




4136




 





 





 





 





 





 



 # The str_ family implements a simple concatenator for strings.  The goal 




4137




 





 





 





 





 





 



 # is to generate a list of literal strings and Perl code generating strings, 




4138




 





 





 





 





 





 



 # separated by commas.  For appending such things to the list, there is 




4139




 





 





 





 





 





 



 # str_append_str() and str_append_perl(), resp.  E.g.: 




4140




 





 





 





 





 





 



 # 




4141




 





 





 





 





 





 



 #    my $s= str_new(); 




4142




 





 





 





 





 





 



 #    str_append_str  ($s, "a"); 




4143




 





 





 





 





 





 



 #    str_append_perl ($s, "b"); 




4144




 





 





 





 





 





 



 # 




4145




 





 





 





 





 





 



 # This would result in the following string: 




4146




 





 





 





 





 





 



 # 




4147




 





 





 





 





 





 



 #    'a',b 




4148




 





 





 





 





 





 



 # 




4149




 





 





 





 





 





 



 # Appending the comma separator is done automatically. 




4150




 





 





 





 





 





 



 # 




4151




 





 





 





 





 





 



 # Further, we need to keep track of the line number.  So there is a function 




4152




 





 





 





 





 





 



 # str_target_line() for setting the target line number for the next string 




4153




 





 





 





 





 





 



 # or raw perl code that is appended.  Appending the necessary newline 




4154




 





 





 





 





 





 



 # characters is done automatically by the str_ functions. 




4155




 





 





 





 





 





 



 # 




4156




 





 





 





 





 





 



 # Finally, we need to generate substrings by joining them.  This is done 




4157




 





 





 





 





 





 



 # with the str_append_join() and str_append_end() functions.  E.g. 




4158




 





 





 





 





 





 



 # 




4159




 





 





 





 





 





 



 #    my $s= str_new(); 




4160




 





 





 





 





 





 



 #    str_append_str  ($s, 'a'); 




4161




 





 





 





 





 





 



 #    str_append_join ($s, sep => ':'); 




4162




 





 





 





 





 





 



 #    str_append_perl ($s, 'b'); 




4163




 





 





 





 





 





 



 #    str_target_line ($s, 2); 




4164




 





 





 





 





 





 



 #    str_append_str  ($s, 'c'); 




4165




 





 





 





 





 





 



 #    str_append_end  ($s); 




4166




 





 





 





 





 





 



 #    str_append_perl ($s, 'd'); 




4167




 





 





 





 





 





 



 # 




4168




 





 





 





 





 





 



 # This results in the following string in $s: 




4169




 





 





 





 





 





 



 # 




4170




 





 





 





 





 





 



 #    'a',join(':',b, 




4171




 





 





 





 





 





 



 #    'c'),d 




4172




 





 





 





 





 





 



 # 




4173




 





 





 





 





 





 



 # Another possible sub-list structure is a map, which can be added with 




4174




 





 





 





 





 





 



 # str_append_map() ... str_append_en() functions.  E.g.: 




4175




 





 





 





 





 





 



 # 




4176




 





 





 





 





 





 



 #    str_append_str  ($s, 'a'); 




4177




 





 





 





 





 





 



 #    str_append_map  ($s, '$_." DESC"'); 




4178




 





 





 





 





 





 



 #    str_append_perl ($s, 'b'); 




4179




 





 





 





 





 





 



 #    str_append_str  ($s, 'c'); 




4180




 





 





 





 





 





 



 #    str_append_end  ($s); 




4181




 





 





 





 





 





 



 #    str_append_perl ($s, 'd'); 




4182




 





 





 





 





 





 



 # 




4183




 





 





 





 





 





 



 # This results in: 




4184




 





 





 





 





 





 



 # 




4185




 





 





 





 





 





 



 #    'a',(map{$_." DESC"} b,'c'),d 




4186




 





 





 





 





 





 



 # 




4187




 





 





 





 





 





 



 # A str_append_min1() ... str_append_end() block checks that there 




4188




 





 





 





 





 





 



 # is at least one result in the enclosed list.  This, together with 




4189




 





 





 





 





 





 



 # _max1_if_scalar, are slightly inefficient and should later be eliminated 




4190




 





 





 





 





 





 



 # if possible. 




4191




 





 





 





 





 





 



 # 




4192




 





 





 





 





 





 



 # str_get_string() returns the current string as composed so far.  If the 




4193




 





 





 





 





 





 



 # string is empty, an empty list () is returned instead, because the 




4194




 





 





 





 





 





 



 # empty string is not a valid syntactic empty list in Perl, so it causes 




4195




 





 





 





 





 





 



 # problems, e.g. after map: 




4196




 





 





 





 





 





 



 # 




4197




 





 





 





 





 





 



 #     (map {...} -->HERE<--) 




4198




 





 





 





 





 





 



 # 




4199




 





 





 





 





 





 



 # If we insert an empty string -->HERE<--, then we get a syntax error. 




4200




 





 





 





 





 





 



 # 




4201




 





 





 





 





 





 



 # The implementation of the str_ family is very straightforward: we have a 




4202




 





 





 





 





 





 



 # current state that is updated and a string that is appended to accordingly. 




4203




 





 





 





 





 





 



 sub str_new($) 




4204




 





 





 





 





 





 



 { 




4205




278





 





 




  
278
  



  
0
  




731



     my ($line_start)= @_; 




4206




278





 





 





 





 





488



     my $text= []; 




4207




278





 





 





 





 





1674



     my $s= { 




4208




 





 





 





 





 





 



         buff        => '', 




4209




 





 





 





 





 





 



         need_comma  => 0, 




4210




 





 





 





 





 





 



         line_is     => 1, 




4211




 





 





 





 





 





 



         line_target => 1, 




4212




 





 





 





 





 





 



         line_start  => $line_start, 




4213




 





 





 





 





 





 



         end_str     => [],  # final str to push, if defined 




4214




 





 





 





 





 





 



     }; 




4215




278





 





 





 





 





1022



     lock_keys %$s; # poor-man's bless() 




4216




278





 





 





 





 





2271



     return $s; 




4217




 





 





 





 





 





 



 } 




4218




 





 





 





 





 





 



   




4219




 





 





 





 





 





 



 sub str_append_raw($$) 




4220




 





 





 





 





 





 



 { 




4221




11636





 





 




  
11636
  



  
0
  




15267



     my ($s, $text)= @_; 




4222




11636





 





 





 





 





19313



     $s->{buff}.= $text; 




4223




11636





 





 





 





 





21349



     $s->{line_is}+= ($text =~ tr/\n//); 




4224




 





 





 





 





 





 



 } 




4225




 





 





 





 





 





 



   




4226




 





 





 





 





 





 



 sub str_sync_line($) 




4227




 





 





 





 





 





 



 { 




4228




5808





 





 




  
5808
  



  
0
  




7738



     my ($s)= @_; 




4229




5808





 





 





 





 





16016



     while ($s->{line_is} < $s->{line_target}) { 




4230




309





 





 





 





 





648



         str_append_raw ($s, "\n"); 




4231




 





 





 





 





 





 



     } 




4232




 





 





 





 





 





 



 } 




4233




 





 





 





 





 





 



 sub str_target_line($$) 




4234




 





 





 





 





 





 



 { 




4235




2834





 





 




  
2834
  



  
0
  




3499



     my ($s, $n)= @_; 




4236




2834




  
 50
  




 





 





 





5060



     my_confess "undefined line number" unless defined $n; 




4237




2834





 





 





 





 





13555



     $s->{line_target}= $n; 




4238




 





 





 





 





 





 



 } 




4239




 





 





 





 





 





 



   




4240




 





 





 





 





 





 



 sub str_append_comma($) 




4241




 





 





 





 





 





 



 { 




4242




7388





 





 




  
7388
  



  
0
  




12950



     my ($s)= @_; 




4243




7388




  
100
  




 





 





 





17137



     if ($s->{need_comma}) { 




4244




3792





 





 





 





 





6858



         str_append_raw ($s, COMMA_STR); 




4245




3792





 





 





 





 





6713



         $s->{need_comma}= 0; 




4246




 





 





 





 





 





 



     } 




4247




 





 





 





 





 





 



 } 




4248




 





 





 





 





 





 



   




4249




 





 





 





 





 





 



 sub str_append_perl($$) 




4250




 





 





 





 





 





 



 { 




4251




4347





 





 




  
4347
  



  
0
  




6157



     my ($s, $perl)= @_; 




4252




4347




  
 50
  




 





 





 





9760



     if ($perl ne '') { 




4253




4347





 





 





 





 





6762



         str_append_comma($s); 




4254




4347





 





 





 





 





7204



         str_sync_line ($s); 




4255




4347





 





 





 





 





7472



         str_append_raw ($s, $perl); 




4256




4347





 





 





 





 





79193



         $s->{need_comma}= 1; 




4257




 





 





 





 





 





 



     } 




4258




 





 





 





 





 





 



 } 




4259




 





 





 





 





 





 



   




4260




 





 





 





 





 





 



 sub str_append_str($$) 




4261




 





 





 





 





 





 



 { 




4262




2628





 





 




  
2628
  



  
0
  




3678



     my ($s, $contents)= @_; 




4263




2628





 





 





 





 





4746



     str_append_perl ($s, quote_perl($contents)); 




4264




 





 





 





 





 





 



 } 




4265




 





 





 





 





 





 



   




4266




 





 





 





 





 





 



 sub str_append_join($%) 




4267




 





 





 





 





 





 



 { 




4268




764





 





 




  
764
  



  
0
  




2975



     my ($s, %opt)= @_; 




4269




764





 




  
100
  




 





 





8464



     $opt{prefix}||=  ''; 




4270




764





 




  
100
  




 





 





2883



     $opt{suffix}||=  ''; 




4271




764





 




  
100
  




 





 





2163



     $opt{sep}||=     ''; 




4272




 





 





 





 





 





 



   




4273




764





 





 





 





 





1370



     str_append_comma($s); 




4274




764





 





 





 





 





1454



     str_sync_line  ($s); 




4275




764




  
100
  



  
 66
  




 





 





5586



     if ($opt{joinfunc}) { 




 




 




  
100
  



  
 66
  




 





 





 



   




 




 




  
100
  



  
 66
  




 





 





 



   




 




 





 




  
 66
  




 





 





 



   




 




 





 




  
 66
  




 





 





 



   




4276




 





 





 





 





 





 



         # special case: ignore all other settings 




4277




94





 





 





 





 





444



         str_append_raw ($s, "$opt{joinfunc}("); 




4278




94





 





 





 





 





239



         $s->{need_comma}= 0; 




4279




94





 





 





 





 





125



         push @{ $s->{end_str} }, undef; 




 




94





 





 





 





 





306



   




4280




 





 





 





 





 





 



     } 




4281




 





 





 





 





 





 



     elsif ($opt{prefix} eq '' && 




4282




 





 





 





 





 





 



            $opt{suffix} eq '' && 




4283




 





 





 





 





 





 



            ( 




4284




 





 





 





 





 





 



                $opt{never_empty} || 




4285




 





 





 





 





 





 



                (defined $opt{result0} && $opt{result0} eq '') 




4286




 





 





 





 





 





 



            )) 




4287




 





 





 





 





 





 



     { 




4288




 





 





 





 





 





 



         # simple case 1 




4289




254





 





 





 





 





549



         str_append_raw ($s, 'join('); 




4290




254





 





 





 





 





675



         str_append_str ($s, $opt{sep}); 




4291




254





 





 





 





 





485



         $s->{need_comma}= 1; 




4292




254





 





 





 





 





324



         push @{ $s->{end_str} }, undef; 




 




254





 





 





 





 





828



   




4293




 





 





 





 





 





 



     } 




4294




 





 





 





 





 





 



     elsif ($opt{sep} eq '' && 




4295




 





 





 





 





 





 



            ( 




4296




 





 





 





 





 





 



                $opt{never_empty} || 




4297




 





 





 





 





 





 



                (defined $opt{result0} && $opt{result0} eq $opt{prefix}.$opt{suffix}) 




4298




 





 





 





 





 





 



            )) 




4299




 





 





 





 





 





 



     { 




4300




 





 





 





 





 





 



         # simple case 2 




4301




21





 





 





 





 





56



         str_append_raw ($s, 'join('); 




4302




21





 





 





 





 





47



         str_append_str ($s, ''); 




4303




 





 





 





 





 





 



   




4304




21




  
 50
  




 





 





 





70



         if($opt{prefix} ne '') { 




4305




21





 





 





 





 





55



             str_append_str ($s, $opt{prefix}); 




4306




 





 





 





 





 





 



         } 




4307




 





 





 





 





 





 



   




4308




21





 




  
100
  




 





 





38



         push @{ $s->{end_str} }, $opt{suffix} || undef; 




 




21





 





 





 





 





124



   




4309




 





 





 





 





 





 



     } 




4310




 





 





 





 





 





 



     else { 




4311




 





 





 





 





 





 



         # complex case: 




4312




395





 





 





 





 





1044



         str_append_raw ($s, __PACKAGE__.'::joinlist('); 




4313




395





 





 





 





 





1512



         str_append_perl ($s, $s->{line_target} + $s->{line_start}); 




4314




 





 





 





 





 





 



             # Unfortunately, Perl's caller() is often imprecise for the 




4315




 





 





 





 





 





 



             # generated code, and I couldn't find a cause for that to avoid 




4316




 





 





 





 





 





 



             # that.  So the original line number is passed long for 




4317




 





 





 





 





 





 



             # nicer error messages if necessary. 




4318




395





 





 





 





 





762



         str_append_comma($s); 




4319




395





 





 





 





 





921



         str_append_str ($s,  $opt{result0}); 




4320




395





 





 





 





 





968



         str_append_comma($s); 




4321




395





 





 





 





 





761



         str_append_str ($s,  $opt{prefix}); 




4322




395





 





 





 





 





877



         str_append_comma($s); 




4323




395





 





 





 





 





2622



         str_append_str ($s,  $opt{sep}); 




4324




395





 





 





 





 





780



         str_append_comma($s); 




4325




395





 





 





 





 





828



         str_append_str ($s,  $opt{suffix}); 




4326




395





 





 





 





 





684



         $s->{need_comma}= 1; 




4327




395





 





 





 





 





438



         push @{ $s->{end_str} }, undef; 




 




395





 





 





 





 





1302



   




4328




 





 





 





 





 





 



     } 




4329




 





 





 





 





 





 



 } 




4330




 





 





 





 





 





 



   




4331




 





 





 





 





 





 



 sub str_append_map($$) 




4332




 





 





 





 





 





 



 { 




4333




173





 





 




  
173
  



  
0
  




435



     my ($s,$code)= @_; 




4334




173





 





 





 





 





338



     str_append_comma($s); 




4335




173





 





 





 





 





348



     str_sync_line  ($s); 




4336




173





 





 





 





 





564



     str_append_raw ($s, "(map{ $code } "); 




4337




173





 





 





 





 





344



     $s->{need_comma}= 0; 




4338




173





 





 





 





 





6149



     push @{ $s->{end_str} }, undef; 




 




173





 





 





 





 





390



   




4339




 





 





 





 





 





 



 } 




4340




 





 





 





 





 





 



   




4341




 





 





 





 





 





 



 sub str_append_funcall_begin($$$) 




4342




 





 





 





 





 





 



 { 




4343




523





 





 




  
523
  



  
0
  




998



     my ($s, $func, $in_list)= @_; 




4344




523





 





 





 





 





1128



     str_append_comma($s); 




4345




523





 





 





 





 





1328



     str_sync_line  ($s); 




4346




523




  
100
  




 





 





 





984



     if ($in_list) { 




4347




277





 





 





 





 





1032



         str_append_raw ($s, "(map { $func("); 




4348




 





 





 





 





 





 



     } 




4349




 





 





 





 





 





 



     else { 




4350




246





 





 





 





 





737



         str_append_raw ($s, "$func("); 




4351




 





 





 





 





 





 



     } 




4352




523





 





 





 





 





1000



     $s->{need_comma}= 0; 




4353




523





 





 





 





 





633



     push @{ $s->{end_str} }, undef; 




 




523





 





 





 





 





1301



   




4354




 





 





 





 





 





 



 } 




4355




 





 





 





 





 





 



   




4356




 





 





 





 





 





 



 sub str_append_funcall_end($$) 




4357




 





 





 





 





 





 



 { 




4358




523





 





 




  
523
  



  
0
  




717



     my ($s, $in_list)= @_; 




4359




523




  
100
  




 





 





 





1265



     if ($in_list) { 




4360




277





 





 





 





 





669



         str_append_perl ($s, '$_'); 




4361




277





 





 





 





 





583



         str_append_raw ($s, ') }'); 




4362




277





 





 





 





 





987



         $s->{need_comma}= 0; 




4363




 





 





 





 





 





 



     } 




4364




 





 





 





 





 





 



 } 




4365




 





 





 





 





 





 



   




4366




 





 





 





 





 





 



 sub str_append_funcall($$$) 




4367




 





 





 





 





 





 



 { 




4368




445





 





 




  
445
  



  
0
  




867



     my ($s, $code, $in_list)= @_; 




4369




445





 





 





 





 





1276



     str_append_funcall_begin ($s, $code, $in_list); 




4370




445





 





 





 





 





1120



     str_append_funcall_end   ($s, $in_list); 




4371




 





 





 





 





 





 



 } 




4372




 





 





 





 





 





 



   




4373




 





 





 





 





 





 



 sub str_append_end($) 




4374




 





 





 





 





 





 



 # Terminator for: 




4375




 





 





 





 





 





 



 #   str_append_map 




4376




 





 





 





 





 





 



 #   str_append_funcall 




4377




 





 





 





 





 





 



 #   str_append_join 




4378




 





 





 





 





 





 



 { 




4379




1450





 





 




  
1450
  



  
0
  




2256



     my ($s)= @_; 




4380




1450





 





 





 





 





1852



     my $end_str= pop @{ $s->{end_str} }; 




 




1450





 





 





 





 





2954



   




4381




1450




  
100
  




 





 





 





3060



     if (defined $end_str) { 




4382




18





 





 





 





 





42



         str_append_str($s, $end_str); 




4383




 





 





 





 





 





 



     } 




4384




1450





 





 





 





 





2755



     str_append_raw ($s, ')'); 




4385




1450





 





 





 





 





76993



     $s->{need_comma}= 1; 




4386




 





 





 





 





 





 



 } 




4387




 





 





 





 





 





 



   




4388




 





 





 





 





 





 



 sub str_get_string($) 




4389




 





 





 





 





 





 



 { 




4390




275





 





 




  
275
  



  
0
  




596



     my ($s)= @_; 




4391




275




  
 50
  




 





 





 





836



     return '()' if $s->{buff} eq ''; 




4392




275





 





 





 





 





882



     return $s->{buff}; 




4393




 





 





 





 





 





 



 } 




4394




 





 





 





 





 





 



   




4395




 





 





 





 





 





 



 # Now start appending more complex things: 




4396




 





 





 





 





 





 



   




4397




 





 





 





 





 





 



 sub str_append_thing($$$$); 




4398




 





 





 





 





 





 



   




4399




 





 





 





 





 





 



 sub str_append_list($$$;%) 




4400




 





 





 





 





 





 



 # If you know the list is non-empty, please specify never_empty => 1 




4401




 





 





 





 





 





 



 # so str_append_join() can optimise. 




4402




 





 





 





 





 





 



 { 




4403




354





 





 




  
354
  



  
0
  




1080



     my ($str, $list, $parens, %opt)= @_; 




4404




354





 





 





 





 





1441



     local $SIG{__DIE__}= \&my_confess; 




4405




 





 





 





 





 





 



   




4406




 





 





 





 





 





 



     # set line to first element (if any): 




4407




354




  
 50
  




 





 





 





904



     if (scalar(@$list)) { 




4408




354





 





 





 





 





1079



         str_target_line ($str, $list->[0]{line}); 




4409




 





 





 





 





 





 



     } 




4410




 





 





 





 





 





 



   




4411




 





 





 





 





 





 



     # joining, delimiters, result if empty: 




4412




354




  
100
  




 





 





 





2198



     str_append_join($str, 




4413




 





 





 





 





 





 



         sep      => defined $opt{sep} ? $opt{sep} : COMMA_STR,  # waiting for Perl 5.10: // 




4414




 





 





 





 





 





 



         prefix   => $opt{prefix}, 




4415




 





 





 





 





 





 



         suffix   => $opt{suffix}, 




4416




 





 





 





 





 





 



         result0  => $opt{result0}, 




4417




 





 





 





 





 





 



     ); 




4418




 





 





 





 





 





 



   




4419




 





 





 





 





 





 



     # map? 




4420




354




  
100
  




 





 





 





1230



     if (my $x= $opt{map}) { 




4421




1





 





 





 





 





4



         str_append_comma ($str); 




4422




1





 





 





 





 





165



         str_sync_line    ($str); 




4423




1





 





 





 





 





4



         str_append_raw   ($str, "map{$x} "); 




4424




1





 





 





 





 





3



         $str->{need_comma}= 0; 




4425




 





 





 





 





 





 



     }; 




4426




 





 





 





 





 





 



   




4427




 





 





 





 





 





 



     # the list: 




4428




354





 





 





 





 





703



     for my $l (@$list) { 




4429




428





 





 





 





 





1015



         str_append_thing ($str, $l, IN_LIST, $parens); 




4430




 





 





 





 





 





 



     } 




4431




 





 





 





 





 





 



   




4432




 





 





 





 





 





 



     # end: 




4433




352





 





 





 





 





9528



     str_append_end($str); 




4434




 





 





 





 





 





 



 } 




4435




 





 





 





 





 





 



   




4436




 





 





 





 





 





 



 sub interpol_set_context ($$); 




4437




 





 





 





 





 





 



   




4438




 





 





 





 





 





 



 sub perl_val($$$) 




4439




 





 





 





 





 





 



 { 




4440




1056





 





 




  
1056
  



  
0
  




1779



     my ($token, $ctxt, $allow)= @_; 




4441




 





 





 





 





 





 



   




4442




96





 





 





 





 





307



     my_confess "Expected ".(english_or \"e_perl, $allow).", but found '$token->{kind}'" 




4443




 





 





 





 





 





 



         if $allow && 




4444




1056




  
 50
  



  
 66
  




 





 





2462



            scalar(grep { $token->{kind} eq $_ } flatten($allow)) == 0; 




4445




 





 





 





 





 





 



   




4446




 





 





 





 





 





 



     return switch($token->{kind}, 




4447




526





 





 




  
526
  




 





1238



         'ident'    => sub { quote_perl($token->{value}) }, 




4448




9





 





 




  
9
  




 





34



         '*'        => sub { __PACKAGE__.'::ASTERISK'    }, 




4449




2





 





 




  
2
  




 





9



         '?'        => sub { __PACKAGE__.'::QUESTION'    }, 




4450




2





 





 




  
2
  




 





6



         'NULL'     => sub { __PACKAGE__.'::NULL'        }, 




4451




1





 





 




  
1
  




 





6



         'TRUE'     => sub { __PACKAGE__.'::TRUE'        }, 




4452




0





 





 




  
0
  




 





0



         'FALSE'    => sub { __PACKAGE__.'::FALSE'       }, 




4453




0





 





 




  
0
  




 





0



         'UNKNOWN'  => sub { __PACKAGE__.'::UNKNOWN'     }, 




4454




1





 





 




  
1
  




 





6



         'DEFAULT'  => sub { __PACKAGE__.'::DEFAULT'     }, 




4455




 





 





 





 





 





 



         -default => sub { 




4456




515




  
 50
  




 




  
515
  




 





2301



             if ($token->{kind} =~ /^interpol/) { 




4457




515





 





 





 





 





1503



                 return interpol_set_context ($token->{value}, $ctxt); 




4458




 





 





 





 





 





 



             } 




4459




 





 





 





 





 





 



             else { 




4460




0





 





 





 





 





0



                 my_confess "No idea how to print thing in Perl: ".token_describe($token); 




4461




 





 





 





 





 





 



             } 




4462




 





 





 





 





 





 



         } 




4463




1056





 





 





 





 





15921



     ); 




4464




 





 





 





 





 





 



 } 




4465




 





 





 





 





 





 



   




4466




 





 





 





 





 





 



 sub perl_val_list($$$) 




4467




 





 





 





 





 





 



 { 




4468




43





 





 




  
43
  



  
0
  




78



     my ($token, $ctxt, $allow)= @_; 




4469




43





 





 





 





 





105



     my $s= perl_val($token, $ctxt, $allow); 




4470




 





 





 





 





 





 



   




4471




43




  
100
  




 





 





 





613



     if ($token->{perltype} eq 'hash') { 




4472




9





 





 





 





 





43



         return "sort keys $s"; 




4473




 





 





 





 





 





 



     } 




4474




 





 





 





 





 





 



     else { 




4475




34





 





 





 





 





245



         return $s; 




4476




 





 





 





 





 





 



     } 




4477




 





 





 





 





 





 



 } 




4478




 





 





 





 





 





 



   




4479




 





 





 





 





 





 



 sub token_pos($) 




4480




 





 





 





 





 





 



 { 




4481




3





 





 




  
3
  



  
0
  




5



     my ($token)= @_; 




4482




3





 





 





 





 





36



     return "$token->{lx}{file}:".($token->{line} + $token->{lx}{line_start}); 




4483




 





 





 





 





 





 



 } 




4484




 





 





 





 





 





 



   




4485




 





 





 





 





 





 



 sub lx_pos($) 




4486




 





 





 





 





 





 



 { 




4487




2





 





 




  
2
  



  
0
  




4



     my ($lx)= @_; 




4488




2





 





 





 





 





38



     return "$lx->{file}:".($lx->{line} + $lx->{line_start}); 




4489




 





 





 





 





 





 



 } 




4490




 





 





 





 





 





 



   




4491




 





 





 





 





 





 



 sub croak_unless_scalar($) 




4492




 





 





 





 





 





 



 { 




4493




861





 





 




  
861
  



  
0
  




1220



     my ($token)= @_; 




4494




861




  
100
  



  
 66
  




 





 





5080



     die token_pos($token).": ". 




4495




 





 





 





 





 





 



         "Error: Scalar context, embedded Perl must not be syntactic array or hash.\n" 




4496




 





 





 





 





 





 



         if $token->{perltype} eq 'array' || $token->{perltype} eq 'hash'; 




4497




 





 





 





 





 





 



 } 




4498




 





 





 





 





 





 



   




4499




 





 





 





 





 





 



 sub str_append_typed($$$$$%) 




4500




 





 





 





 





 





 



 { 




4501




474





 





 




  
474
  



  
0
  




1415



     my ($str, $callback, $ctxt, $thing, $in_list, %opt)= @_; 




4502




474





 





 





 





 





1335



     my $q_val= perl_val ($thing->{token}, $ctxt, undef); 




4503




 





 





 





 





 





 



   




4504




474




  
100
  



  
100
  




 





 





7290



     if (!$in_list || 




 




 




  
100
  




 





 





 





 



   




4505




 





 





 





 





 





 



         $thing->{token}{perltype} eq 'scalar') 




4506




 





 





 





 





 





 



     { 




4507




358





 





 





 





 





992



         croak_unless_scalar ($thing->{token}); 




4508




356





 





 





 





 





1339



         str_append_perl ($str, __PACKAGE__."::${callback}($q_val)"); 




4509




 





 





 





 





 





 



     } 




4510




 





 





 





 





 





 



     elsif ($thing->{token}{perltype} eq 'hash') { 




4511




19




  
100
  




 





 





 





67



         if ($opt{hash}) { 




 




 




  
 50
  




 





 





 





 



   




4512




16





 





 





 





 





70



             str_append_perl ($str, __PACKAGE__."::${callback}_hash($q_val)"); 




4513




 





 





 





 





 





 



         } 




4514




 





 





 





 





 





 



         elsif ($opt{hashkeys}) { 




4515




3





 





 





 





 





16



             str_append_map  ($str, __PACKAGE__."::${callback}(\$_)"); 




4516




3





 





 





 





 





12



             str_append_perl ($str, "sort keys $q_val"); 




4517




3





 





 





 





 





7



             str_append_end  ($str); 




4518




 





 





 





 





 





 



         } 




4519




 





 





 





 





 





 



         else { 




4520




0





 





 





 





 





0



             die token_pos($thing->{token}).": Error: Hashes are not allowed here.\n"; 




4521




 





 





 





 





 





 



         } 




4522




 





 





 





 





 





 



     } 




4523




 





 





 





 





 





 



     else { 




4524




97





 





 





 





 





444



         str_append_map  ($str, __PACKAGE__."::${callback}(\$_)"); 




4525




97





 





 





 





 





221



         str_append_perl ($str, $q_val); 




4526




97





 





 





 





 





215



         str_append_end  ($str); 




4527




 





 





 





 





 





 



     } 




4528




 





 





 





 





 





 



 } 




4529




 





 





 





 





 





 



   




4530




 





 





 





 





 





 



 sub is_multicol($); 




4531




 





 





 





 





 





 



 sub is_multicol($) 




4532




 





 





 





 





 





 



 { 




4533




510





 





 




  
510
  



  
0
  




891



     my ($thing) = @_; 




4534




 





 





 





 





 





 



     return switch ($thing->{kind}, 




4535




 





 





 





 





 





 



         'ExprAs' => sub{ 




4536




165





 





 




  
165
  




 





496



             return is_multicol($thing->{expr}); 




4537




 





 





 





 





 





 



         }, 




4538




 





 





 





 





 





 



         'Expr' => sub { 




4539




165




  
100
  




 




  
165
  




 





656



             if ($thing->{type} eq 'column') { 




4540




90





 





 





 





 





388



                 return is_multicol($thing->{arg}); 




4541




 





 





 





 





 





 



             } 




4542




75





 





 





 





 





1093



             return 0; 




4543




 





 





 





 





 





 



         }, 




4544




 





 





 





 





 





 



         'Column' => sub { 




4545




90





 





 




  
90
  




 





325



             return is_multicol($thing->{ident_chain}[-1]); 




4546




 





 





 





 





 





 



         }, 




4547




 





 





 





 





 





 



         '*' => sub { 




4548




4





 





 




  
4
  




 





152



             return 1; 




4549




 





 





 





 





 





 



         }, 




4550




 





 





 





 





 





 



         'interpol' => sub { 




4551




21





 





 




  
21
  




 





634



             return $thing->{perltype} ne 'scalar'; 




4552




 





 





 





 





 





 



         }, 




4553




 





 





 





 





 





 



         -default => sub { 




4554




65





 





 




  
65
  




 





2207



             return 0; 




4555




 





 





 





 





 





 



         }, 




4556




510





 





 





 





 





6901



     ); 




4557




 





 





 





 





 





 



 } 




4558




 





 





 





 





 





 



   




4559




 





 





 





 





 





 



 # Contexts for the different sql{...} interpolation blocks: 




4560




 





 





 





 





 





 



 my %ident_context= ( 




4561




 





 





 





 





 





 



     'Column' => { 




4562




 





 





 





 





 





 



         1 => [ 'Column' ], 




4563




 





 





 





 





 





 



         2 => [ 'Table', 'none' ], 




4564




 





 





 





 





 





 



     }, 




4565




 





 





 





 





 





 



 ); 




4566




 





 





 





 





 





 



   




4567




 





 





 





 





 





 



 sub str_append_ident_chain($$$@) 




4568




 





 





 





 





 





 



 { 




4569




509





 





 




  
509
  



  
0
  




1235



     my ($str, $in_list, $family, @token)= @_; 




4570




509





 





 





 





 





1256



     my $func= lc($family); 




4571




 





 





 





 





 





 



   




4572




509





 




  
 66
  




 





 





2674



     my $ctxt= $ident_context{$family}{scalar @token} || 




4573




 





 





 





 





 





 



               (scalar(@token) == 1 ? 




4574




 





 





 





 





 





 



                   [ $family ] 




4575




 





 





 





 





 





 



               :   [ map 'none', 1..scalar(@token) ] 




4576




 





 





 





 





 





 



               ); 




4577




 





 





 





 





 





 



   




4578




509





 





 





 





 





932



     my $n= scalar(@token); 




4579




509





 





 





 





 





1399



     my @non_scalar_i= grep { $token[$_]{perltype} ne 'scalar' } 0..$n-1; 




 




551





 





 





 





 





2274



   




4580




 





 





 





 





 





 



   




4581




509




  
100
  



  
100
  




 





 





2051



     if (!$in_list || 




 




 




  
100
  




 





 





 





 



   




4582




 





 





 





 





 





 



         scalar(@non_scalar_i) == 0) 




4583




 





 





 





 





 





 



     { 




4584




470





 





 





 





 





851



         for my $a (@token) { croak_unless_scalar ($a); } 




 




503





 





 





 





 





1571



   




4585




502





 





 





 





 





1361



         my $q_vals= join(",", 




4586




 





 





 





 





 





 



                         map 




4587




469





 





 





 





 





1104



                         { perl_val($token[$_], $ctxt->[$_], undef) } 




4588




 





 





 





 





 





 



                         0..$n-1 




4589




 





 





 





 





 





 



                     ); 




4590




469





 





 





 





 





1977



         str_append_perl ($str, __PACKAGE__."::${func}${n}($q_vals)"); 




4591




 





 





 





 





 





 



     } 




4592




 





 





 





 





 





 



     elsif (scalar(@non_scalar_i) == 1) { 




4593




40




  
100
  




 





 





 





258



         str_append_map ($str, 




4594




 





 





 





 





 





 



             __PACKAGE__."::${func}${n}(". 




4595




 





 





 





 





 





 



                 join(",", 




4596




 





 





 





 





 





 



                     map { 




4597




35





 





 





 





 





151



                         ($token[$_]{perltype} eq 'scalar' ? 




4598




 





 





 





 





 





 



                             perl_val($token[$_], $ctxt->[$_], undef) 




4599




 





 





 





 





 





 



                         :   '$_' 




4600




 





 





 





 





 





 



                         ) 




4601




 





 





 





 





 





 



                     } 




4602




 





 





 





 





 





 



                     0..$n-1 




4603




 





 





 





 





 





 



                 ). 




4604




 





 





 





 





 





 



             ")" 




4605




 





 





 





 





 





 



         ); 




4606




35





 





 





 





 





76



         my ($i)= @non_scalar_i; 




4607




35





 





 





 





 





119



         str_append_perl ($str, perl_val_list($token[$i], $ctxt->[$i], undef)); 




4608




35





 





 





 





 





162



         str_append_end  ($str); 




4609




 





 





 





 





 





 



     } 




4610




 





 





 





 





 





 



     else { 




4611




4




  
 50
  




 





 





 





17



         my $f_ident= "${func}${n}_".join('', map{ $_->{perltype} eq 'scalar' ? 1 : 'n' } @token); 




 




8





 





 





 





 





36



   




4612




8




  
 50
  




 





 





 





43



         str_append_perl ($str, 




4613




 





 





 





 





 





 



             __PACKAGE__."::$f_ident(". 




4614




 





 





 





 





 





 



                 join(",", 




4615




 





 





 





 





 





 



                     map { 




4616




4





 





 





 





 





21



                         ($token[$_]{perltype} eq 'scalar' ? 




4617




 





 





 





 





 





 



                             perl_val($token[$_], $ctxt->[$_], undef) 




4618




 





 





 





 





 





 



                         :   '['.perl_val_list($token[$_], $ctxt->[$_], undef).']' 




4619




 





 





 





 





 





 



                         ) 




4620




 





 





 





 





 





 



                     } 




4621




 





 





 





 





 





 



                     0..$n-1 




4622




 





 





 





 





 





 



                 ). 




4623




 





 





 





 





 





 



             ")" 




4624




 





 





 





 





 





 



         ); 




4625




 





 





 





 





 





 



     } 




4626




 





 





 





 





 





 



 } 




4627




 





 





 





 





 





 



   




4628




 





 





 





 





 





 



 sub str_append_limit ($$$) 




4629




 





 





 





 





 





 



 { 




4630




106





 





 




  
106
  



  
0
  




225



     my ($str, $limit_cnt, $limit_offset)= @_; 




4631




 





 





 





 





 





 



   




4632




106




  
100
  



  
 66
  




 





 





633



     if (defined $limit_cnt || defined $limit_offset) { 




4633




5





 





 





 





 





13



         my $limit_cnt_str= 'undef'; 




4634




5




  
 50
  




 





 





 





13



         if ($limit_cnt) { 




4635




5





 





 





 





 





24



             $limit_cnt_str= perl_val($limit_cnt, 'Expr', ['interpol', 'interpolExpr', '?']); 




4636




 





 





 





 





 





 



         } 




4637




 





 





 





 





 





 



   




4638




5





 





 





 





 





52



         my $limit_offset_str= 'undef'; 




4639




5




  
100
  




 





 





 





53



         if ($limit_offset) { 




4640




3





 





 





 





 





13



             $limit_offset_str= perl_val($limit_offset, 'Expr', ['interpol', 'interpolExpr', '?']); 




4641




 





 





 





 





 





 



         } 




4642




 





 





 





 





 





 



   




4643




5





 





 





 





 





51



         str_append_perl ($str, __PACKAGE__."::limit($limit_cnt_str, $limit_offset_str)"); 




4644




 





 





 





 





 





 



     } 




4645




 





 





 





 





 





 



 } 




4646




 





 





 





 





 





 



   




4647




 





 





 





 





 





 



 sub str_append_parens($$$) 




4648




 





 





 





 





 





 



 { 




4649




18





 





 




  
18
  



  
0
  




37



     my ($str, $thing, $in_list)= @_; 




4650




18




  
 50
  




 





 





 





52



     if ($in_list) { 




4651




0





 





 





 





 





0



         str_append_map ($str, "\"(\$_)\""); 




4652




0





 





 





 





 





0



         str_append_thing ($str, $thing, $in_list, NO_PARENS); 




4653




0





 





 





 





 





0



         str_append_end ($str); 




4654




 





 





 





 





 





 



     } 




4655




 





 





 





 





 





 



     else { 




4656




18





 





 





 





 





65



         str_append_join  ($str, prefix => '(', suffix => ')', never_empty => 1); 




4657




18





 





 





 





 





56



         str_append_thing ($str, $thing, $in_list, NO_PARENS); 




4658




18





 





 





 





 





2408



         str_append_end   ($str); 




4659




 





 





 





 





 





 



     } 




4660




 





 





 





 





 





 



 } 




4661




 





 





 





 





 





 



   




4662




 





 





 





 





 





 



 sub str_append_table_key($$$) 




4663




 





 





 





 





 





 



 { 




4664




3





 





 




  
3
  



  
0
  




7



     my ($str, $thing, $type)= @_; 




4665




3





 





 





 





 





8



     str_append_join ($str, sep => ' '); 




4666




3




  
 50
  




 





 





 





14



     if (my $x= $thing->{constraint}) { 




4667




3





 





 





 





 





6



         str_append_str   ($str, 'CONSTRAINT'); 




4668




3





 





 





 





 





10



         str_append_thing ($str, $x, NOT_IN_LIST, NO_PARENS); 




4669




 





 





 





 





 





 



     } 




4670




3





 





 





 





 





151



     str_append_str  ($str, $type); 




4671




3




  
100
  




 





 





 





14



     if (my $x= $thing->{index_type}) { 




4672




1





 





 





 





 





5



         str_append_str ($str, "USING $x"); 




4673




 





 





 





 





 





 



     } 




4674




3





 





 





 





 





453



     str_append_list ($str, $thing->{column}, NO_PARENS, prefix=>'(', suffix=>')'); 




4675




3





 





 





 





 





5



     for my $o (@{ $thing->{index_option} }) { 




 




3





 





 





 





 





9



   




4676




0





 





 





 





 





0



         str_append_thing ($str, $o, IN_LIST, NO_PARENS); 




4677




 





 





 





 





 





 



     } 




4678




3




  
100
  




 





 





 





12



     if (my $x= $thing->{reference}) { 




4679




2





 





 





 





 





7



         str_append_thing ($str, $x, NOT_IN_LIST, NO_PARENS); 




4680




 





 





 





 





 





 



     } 




4681




3





 





 





 





 





95



     str_append_end ($str); 




4682




 





 





 





 





 





 



 } 




4683




 





 





 





 





 





 



   




4684




 





 





 





 





 





 



 # str_append_thing() converts a recursive representation of the parsed SQL 




4685




 





 





 





 





 





 



 # structure into a Perl string that generates a list of either string 




4686




 





 





 





 





 





 



 # representations of the SQL structure (in good SQL syntax), or blessed 




4687




 





 





 





 





 





 



 # objects of the correct type. 




4688




 





 





 





 





 





 



 # 




4689




 





 





 





 





 





 



 # The result of this function is then used to wrap and bless the string 




4690




 





 





 





 





 





 



 # or objects appropriately according to which kind of SQL structure the 




4691




 





 





 





 





 





 



 # string contains (statement, expressions, column, etc.). 




4692




 





 





 





 





 





 



 # 




4693




 





 





 





 





 





 



 # In detail, str_append_thing() appends pieces of Perl code to $str, that 




4694




 





 





 





 





 





 



 # each represent a small piece of the SQL command. 




4695




 





 





 





 





 





 



 # 




4696




 





 





 





 





 





 



 # Each invocation of str_append_thing appends code to $str that generates 




4697




 





 





 





 





 





 



 # exactly the amount of objects that are represented.  This might seem 




4698




 





 





 





 





 





 



 # obvious, but since $str is actually a comma separated list, this 




4699




 





 





 





 





 





 



 # requirement means that if multiple pieces are pushed for a single 




4700




 





 





 





 





 





 



 # thing, then a join(...) must enclose and group these.  E.g. 




4701




 





 





 





 





 





 



 # the code that generates a SELECT statement from scratch appends 




4702




 





 





 





 





 





 



 # several pieces of code to $str, and to make only one string, a 




4703




 





 





 





 





 





 



 # join() is generated. 




4704




 





 





 





 





 





 



 # 




4705




 





 





 





 





 





 



 sub str_append_thing($$$$) 




4706




 





 





 





 





 





 



 { 




4707




2820





 





 




  
2820
  



  
0
  




4819



     my ($str, $thing, $in_list, $parens)= @_; 




4708




2820





 





 





 





 





13742



     local $SIG{__DIE__}= \&my_confess; 




4709




 





 





 





 





 





 



   




4710




 





 





 





 





 





 



     # simple things to append: 




4711




2820




  
100
  




 





 





 





6247



     unless (defined $thing) { 




4712




16





 





 





 





 





40



         str_append_perl ($str, 'undef'); 




4713




16





 





 





 





 





54



         return; 




4714




 





 





 





 





 





 



     } 




4715




2804




  
100
  




 





 





 





6744



     unless (ref $thing) { 




4716




380





 





 





 





 





671



         str_append_str ($str, $thing); 




4717




380





 





 





 





 





1218



         return; 




4718




 





 





 





 





 





 



     } 




4719




2424




  
100
  




 





 





 





5636



     if (ref($thing) eq 'ARRAY') { 




4720




1





 





 





 





 





5



         str_append_list ($str, $thing, NO_PARENS, prefix => '(', suffix => ')'); 




4721




1





 





 





 





 





6



         return; 




4722




 





 





 





 





 





 



     } 




4723




 





 





 





 





 





 



   




4724




 





 





 





 





 





 



     # normal structure: 




4725




2423





 





 





 





 





5246



     str_target_line ($str, $thing->{line}); 




4726




 





 





 





 





 





 



   




4727




 





 





 





 





 





 



     switch($thing->{kind}, 




4728




 





 





 





 





 





 



         'Stmt' => sub { 




4729




 





 





 





 





 





 



             switch($thing->{type}, 




4730




 





 





 





 





 





 



                 'Select' => sub { 




4731




 





 





 





 





 





 



                     # find out type name depending on number of columns: 




4732




178





 





 





 





 





580



                     my $type_name = 'SelectStmt'; 




4733




178




  
100
  




 





 





 





235



                     if (scalar(@{ $thing->{expr_list} }) == 1) { 




 




178





 





 





 





 





832



   




4734




165




  
100
  




 





 





 





801



                         unless (is_multicol($thing->{expr_list}[0])) { 




4735




149





 





 





 





 





305



                             $type_name = 'SelectStmtSingle'; 




4736




 





 





 





 





 





 



                         } 




4737




 





 





 





 





 





 



                     } 




4738




 





 





 





 





 





 



   




4739




 





 





 





 





 





 



                     # generate: 




4740




178





 





 





 





 





1828



                     str_append_funcall ($str, __PACKAGE__.'::'.$type_name.'->obj', $in_list); 




4741




178





 





 





 





 





527



                     str_append_join ($str, never_empty => 1); 




4742




 





 





 





 





 





 



   




4743




178





 





 





 





 





969



                     str_append_list ($str, $thing->{expr_list}, NO_PARENS, 




4744




 





 





 





 





 





 



                         prefix => join(' ', 'SELECT', 




4745




178





 





 





 





 





405



                                             @{ $thing->{opt_front} } 




4746




 





 





 





 





 





 



                                   ).' ' 




4747




 





 





 





 





 





 



                     ); 




4748




 





 





 





 





 





 



   




4749




176




  
100
  




 





 





 





680



                     if (my $x= $thing->{from}) { 




4750




94





 





 





 





 





272



                         str_append_list ($str, $x, NO_PARENS, prefix => ' FROM '); 




4751




 





 





 





 





 





 



   




4752




94




  
 50
  




 





 





 





355



                         if (my $x= $thing->{join}) { 




4753




94




  
100
  




 





 





 





297



                             if (@$x) { 




4754




4





 





 





 





 





15



                                 str_append_map ($str, '" $_" '); 




4755




4





 





 





 





 





12



                                 for my $xi (@$x) { 




4756




5





 





 





 





 





17



                                     str_append_thing ($str, $xi, IN_LIST, NO_PARENS); 




4757




 





 





 





 





 





 



                                 } 




4758




4





 





 





 





 





14



                                 str_append_end ($str); 




4759




 





 





 





 





 





 



                             } 




4760




 





 





 





 





 





 



                         } 




4761




94




  
100
  




 





 





 





306



                         if (my $x= $thing->{where}) { 




4762




44





 





 





 





 





149



                             str_target_line ($str, $x->{line}); 




4763




44





 





 





 





 





114



                             str_append_str   ($str, ' WHERE '); 




4764




44





 





 





 





 





151



                             str_append_thing ($str, $x, NOT_IN_LIST, NO_PARENS); 




4765




 





 





 





 





 





 



                         } 




4766




93




  
100
  




 





 





 





4473



                         if (my $x= $thing->{group_by}) { 




4767




6





 





 





 





 





15



                             my $suffix= ''; 




4768




6




  
100
  




 





 





 





20



                             if ($thing->{group_by_with_rollup}) { 




4769




1





 





 





 





 





2



                                 $suffix= ' WITH ROLLUP'; 




4770




 





 





 





 





 





 



                             } 




4771




6





 





 





 





 





50



                             str_append_list ($str, $x, NO_PARENS, 




4772




 





 





 





 





 





 



                                 prefix  => ' GROUP BY ', 




4773




 





 





 





 





 





 



                                 suffix  => $suffix, 




4774




 





 





 





 





 





 



                                 result0 => '', 




4775




 





 





 





 





 





 



                             ); 




4776




 





 





 





 





 





 



                         } 




4777




93




  
100
  




 





 





 





339



                         if (my $x= $thing->{having}) { 




4778




1





 





 





 





 





6



                             str_target_line ($str, $x->{line}); 




4779




1





 





 





 





 





3



                             str_append_str   ($str, ' HAVING '); 




4780




1





 





 





 





 





3



                             str_append_thing ($str, $x, NOT_IN_LIST, NO_PARENS); 




4781




 





 





 





 





 





 



                         } 




4782




93




  
100
  




 





 





 





422



                         if (my $x= $thing->{order_by}) { 




4783




8





 





 





 





 





31



                             str_append_list ($str, $x, NO_PARENS, 




4784




 





 





 





 





 





 



                                 prefix  => ' ORDER BY ', 




4785




 





 





 





 





 





 



                                 result0 => '' 




4786




 





 





 





 





 





 



                             ); 




4787




 





 





 





 





 





 



                         } 




4788




93





 





 





 





 





409



                         str_append_limit ($str, $thing->{limit_cnt}, $thing->{limit_offset}); 




4789




 





 





 





 





 





 



   




4790




93





 





 





 





 





177



                         str_append_str ($str, join('', map " $_", @{ $thing->{opt_back} })); 




 




93





 





 





 





 





377



   




4791




 





 





 





 





 





 



                     } 




4792




 





 





 





 





 





 



   




4793




175





 





 





 





 





445



                     str_append_end ($str); 




4794




175





 





 





 





 





389



                     str_append_end ($str); 




4795




 





 





 





 





 





 



                 }, 




4796




 





 





 





 





 





 



                 'Delete' => sub { 




4797




4





 





 





 





 





18



                     str_append_funcall ($str, __PACKAGE__.'::Stmt->obj', $in_list); 




4798




4





 





 





 





 





11



                     str_append_join ($str, never_empty => 1); 




4799




 





 





 





 





 





 



   




4800




4





 





 





 





 





9



                     str_append_list ($str, $thing->{from}, NO_PARENS, 




4801




 





 





 





 





 





 



                         prefix => 




4802




 





 





 





 





 





 



                             join(' ', 




4803




 





 





 





 





 





 



                                 'DELETE', 




4804




4





 





 





 





 





20



                                 @{ $thing->{opt_front} }, 




4805




 





 





 





 





 





 



                                 'FROM', 




4806




4





 





 





 





 





11



                                 @{ $thing->{from_opt_front} }, 




4807




 





 





 





 





 





 



                             ).' ' 




4808




 





 





 





 





 





 



                     ); 




4809




 





 





 





 





 





 



   




4810




4




  
100
  




 





 





 





16



                     if (my $x= $thing->{using}) { 




4811




2





 





 





 





 





8



                         str_append_list ($str, $x, NO_PARENS, 




4812




 





 





 





 





 





 



                             prefix => ' USING ', 




4813




 





 





 





 





 





 



                             result0 => '' 




4814




 





 





 





 





 





 



                         ); 




4815




 





 





 





 





 





 



                     } 




4816




 





 





 





 





 





 



   




4817




4




  
 50
  




 





 





 





18



                     if (my $x= $thing->{join}) { 




4818




4




  
100
  




 





 





 





12



                         if (@$x) { 




4819




2





 





 





 





 





8



                             str_append_map ($str, '" $_" '); 




4820




2





 





 





 





 





5



                             for my $xi (@$x) { 




4821




3





 





 





 





 





9



                                 str_append_thing ($str, $xi, IN_LIST, NO_PARENS); 




4822




 





 





 





 





 





 



                             } 




4823




2





 





 





 





 





6



                             str_append_end ($str); 




4824




 





 





 





 





 





 



                         } 




4825




 





 





 





 





 





 



                     } 




4826




4




  
100
  




 





 





 





16



                     if (my $x= $thing->{where}) { 




4827




3





 





 





 





 





12



                         str_target_line ($str, $x->{line}); 




4828




3





 





 





 





 





9



                         str_append_str   ($str, ' WHERE '); 




4829




3





 





 





 





 





10



                         str_append_thing ($str, $x, NOT_IN_LIST, NO_PARENS); 




4830




 





 





 





 





 





 



                     } 




4831




4




  
 50
  




 





 





 





236



                     if (my $x= $thing->{order_by}) { 




4832




0





 





 





 





 





0



                         str_append_list ($str, $x, NO_PARENS, 




4833




 





 





 





 





 





 



                             prefix  => ' ORDER BY ', 




4834




 





 





 





 





 





 



                             result0 => '' 




4835




 





 





 





 





 





 



                         ); 




4836




 





 





 





 





 





 



                     } 




4837




4





 





 





 





 





17



                     str_append_limit ($str, $thing->{limit_cnt}, $thing->{limit_offset}); 




4838




 





 





 





 





 





 



   




4839




4





 





 





 





 





8



                     str_append_end ($str); 




4840




4





 





 





 





 





8



                     str_append_end ($str); 




4841




 





 





 





 





 





 



                 }, 




4842




 





 





 





 





 





 



                 'Insert' => sub { 




4843




13





 





 





 





 





46



                     str_append_funcall ($str, __PACKAGE__.'::Stmt->obj', $in_list); 




4844




13





 





 





 





 





39



                     str_append_join ($str, never_empty => 1); 




4845




 





 





 





 





 





 



   




4846




13





 





 





 





 





66



                     str_append_str ($str, 




4847




 





 





 





 





 





 



                         join(' ', 




4848




 





 





 





 





 





 



                             'INSERT', 




4849




13





 





 





 





 





23



                             @{ $thing->{opt_front} }, 




4850




 





 





 





 





 





 



                             'INTO', 




4851




 





 





 





 





 





 



                         ).' ' 




4852




 





 





 





 





 





 



                     ); 




4853




 





 





 





 





 





 



   




4854




13





 





 





 





 





45



                     str_append_thing ($str, $thing->{into}, NOT_IN_LIST, NO_PARENS); 




4855




 





 





 





 





 





 



   




4856




13




  
100
  




 





 





 





859



                     if (my $col= $thing->{column}) { 




4857




5





 





 





 





 





19



                         str_append_list ($str, $col, NO_PARENS, prefix => ' (', suffix => ')'); 




4858




 





 





 





 





 





 



                     } 




4859




 





 





 





 





 





 



                                                  




4860




13




  
100
  




 





 





 





55



                     if (my $val= $thing->{value}) { 




 




 




  
 50
  




 





 





 





 



   




 




 




  
  0
  




 





 





 





 



   




 




 




  
  0
  




 





 





 





 



   




4861




5





 





 





 





 





15



                         str_append_str  ($str, ' VALUES '); 




4862




5





 





 





 





 





17



                         str_append_list ($str, $val, NO_PARENS); 




4863




 





 





 





 





 





 



                     } 




4864




 





 





 





 





 





 



                     elsif (my $set= $thing->{set}) { 




4865




8





 





 





 





 





25



                         str_append_funcall ($str, __PACKAGE__."::set2values", NOT_IN_LIST); 




4866




8





 





 





 





 





17



                         for my $l (@$set) { 




4867




16





 





 





 





 





39



                             str_append_thing ($str, $l, IN_LIST, NO_PARENS); 




4868




 





 





 





 





 





 



                         } 




4869




8





 





 





 





 





19



                         str_append_end ($str); 




4870




 





 





 





 





 





 



                     } 




4871




 





 





 





 





 





 



                     elsif (my $sel= $thing->{select}) { 




4872




0





 





 





 





 





0



                         str_append_str   ($str, ' '); 




4873




0





 





 





 





 





0



                         str_append_thing ($str, $sel, NOT_IN_LIST, NO_PARENS); 




4874




 





 





 





 





 





 



                     } 




4875




 





 





 





 





 





 



                     elsif ($thing->{default_values}) { 




4876




0





 





 





 





 





0



                         str_append_str ($str, ' DEFAULT VALUES'); 




4877




 





 





 





 





 





 



                     } 




4878




 





 





 





 





 





 



                     else { 




4879




0





 





 





 





 





0



                         die; 




4880




 





 





 





 





 





 



                     } 




4881




 





 





 





 





 





 



   




4882




13




  
100
  




 





 





 





58



                     if (my $x= $thing->{duplicate_update}) { 




4883




1





 





 





 





 





4



                         str_append_str  ($str, ' ON DUPLICATE KEY UPDATE '); 




4884




1





 





 





 





 





4



                         str_append_list ($str, $x, NO_PARENS, map => __PACKAGE__.'::assign($_)'); 




4885




 





 





 





 





 





 



                     } 




4886




 





 





 





 





 





 



   




4887




13





 





 





 





 





29



                     str_append_end ($str); 




4888




13





 





 





 





 





31



                     str_append_end ($str); 




4889




 





 





 





 





 





 



                 }, 




4890




 





 





 





 





 





 



                 'Update' => sub { 




4891




9





 





 





 





 





42



                     str_append_funcall ($str, __PACKAGE__.'::Stmt->obj', $in_list); 




4892




9





 





 





 





 





33



                     str_append_join ($str, never_empty => 1); 




4893




 





 





 





 





 





 



   




4894




9





 





 





 





 





57



                     str_append_list ($str, $thing->{table}, NO_PARENS, 




4895




 





 





 





 





 





 



                         prefix => join(' ', 'UPDATE', 




4896




9





 





 





 





 





32



                                             @{ $thing->{opt_front} } 




4897




 





 





 





 





 





 



                                   ).' ' 




4898




 





 





 





 





 





 



                     ); 




4899




 





 





 





 





 





 



   




4900




9




  
100
  




 





 





 





116



                     if (my $x= $thing->{from}) { 




4901




1





 





 





 





 





3



                         str_append_list ($str, $x, NO_PARENS, 




4902




 





 





 





 





 





 



                             prefix => ' FROM ', 




4903




 





 





 





 





 





 



                             result0 => '' 




4904




 





 





 





 





 





 



                         ); 




4905




 





 





 





 





 





 



                     } 




4906




9




  
 50
  




 





 





 





36



                     if (my $x= $thing->{join}) { 




4907




9




  
 50
  




 





 





 





30



                         if (@$x) { 




4908




0





 





 





 





 





0



                             str_append_map ($str, '" $_" '); 




4909




0





 





 





 





 





0



                             for my $xi (@$x) { 




4910




0





 





 





 





 





0



                                 str_append_thing ($str, $xi, IN_LIST, NO_PARENS); 




4911




 





 





 





 





 





 



                             } 




4912




0





 





 





 





 





0



                             str_append_end ($str); 




4913




 





 





 





 





 





 



                         } 




4914




 





 





 





 





 





 



                     } 




4915




9




  
 50
  




 





 





 





35



                     if (my $x= $thing->{set}) { 




4916




9





 





 





 





 





39



                         str_append_list ($str, $x, NO_PARENS, 




4917




 





 





 





 





 





 



                             prefix => ' SET ', 




4918




 





 





 





 





 





 



                             result0 => ''  # this is an error. 




4919




 





 





 





 





 





 



                         ); 




4920




 





 





 





 





 





 



                     } 




4921




9




  
 50
  




 





 





 





49



                     if (my $x= $thing->{where}) { 




4922




9





 





 





 





 





48



                         str_target_line ($str, $x->{line}); 




4923




9





 





 





 





 





30



                         str_append_str   ($str, ' WHERE '); 




4924




9





 





 





 





 





30



                         str_append_thing ($str, $x, NOT_IN_LIST, NO_PARENS); 




4925




 





 





 





 





 





 



                     } 




4926




9




  
100
  




 





 





 





770



                     if (my $x= $thing->{order_by}) { 




4927




1





 





 





 





 





3



                         str_append_list ($str, $x, NO_PARENS, 




4928




 





 





 





 





 





 



                             prefix  => ' ORDER BY ', 




4929




 





 





 





 





 





 



                             result0 => '' 




4930




 





 





 





 





 





 



                         ); 




4931




 





 





 





 





 





 



                     } 




4932




9





 





 





 





 





52



                     str_append_limit ($str, $thing->{limit_cnt}, $thing->{limit_offset}); 




4933




 





 





 





 





 





 



   




4934




9





 





 





 





 





24



                     str_append_end ($str); 




4935




9





 





 





 





 





26



                     str_append_end ($str); 




4936




 





 





 





 





 





 



                 }, 




4937




 





 





 





 





 





 



                 'CreateTable' => sub { 




4938




2





 





 





 





 





11



                     str_append_funcall ($str, __PACKAGE__.'::Stmt->obj', $in_list); 




4939




2





 





 





 





 





8



                     str_append_join ($str, never_empty => 1); 




4940




 





 





 





 





 





 



   




4941




2





 





 





 





 





10



                     str_append_str ($str, "$thing->{subtype} "); 




4942




2




  
100
  




 





 





 





11



                     if ($thing->{if_not_exists}) { 




4943




1





 





 





 





 





3



                         str_append_str ($str, 'IF NOT EXISTS '); 




4944




 





 





 





 





 





 



                     } 




4945




2





 





 





 





 





9



                     str_append_thing ($str, $thing->{table}, NOT_IN_LIST, NO_PARENS); 




4946




 





 





 





 





 





 



   




4947




2





 





 





 





 





12



                     my @tabspec= ( 




4948




2





 





 





 





 





8



                         @{ $thing->{column_def} }, 




4949




2





 





 





 





 





134



                         @{ $thing->{tabconstr} } 




4950




 





 





 





 





 





 



                     ); 




4951




2





 





 





 





 





12



                     str_append_list ($str, \@tabspec, NO_PARENS, 




4952




 





 





 





 





 





 



                         result0 => '', 




4953




 





 





 





 





 





 



                         prefix  => ' (', 




4954




 





 





 





 





 





 



                         suffix  => ')' 




4955




 





 





 





 





 





 



                     ); 




4956




 





 





 





 





 





 



   




4957




2





 





 





 





 





12



                     str_append_list ($str, $thing->{tableopt}, NO_PARENS, 




4958




 





 





 





 





 





 



                         result0 => '', 




4959




 





 





 





 





 





 



                         prefix  => ' ', 




4960




 





 





 





 





 





 



                         sep     => ' ', 




4961




 





 





 





 





 





 



                     ); 




4962




 





 





 





 





 





 



   




4963




2




  
100
  




 





 





 





10



                     if (my $x= $thing->{select}) { 




4964




1





 





 





 





 





4



                         str_append_str   ($str, ' AS '); 




4965




1





 





 





 





 





4



                         str_append_thing ($str, $x, NOT_IN_LIST, NO_PARENS); 




4966




 





 





 





 





 





 



                     } 




4967




 





 





 





 





 





 



   




4968




2





 





 





 





 





146



                     str_append_end ($str); 




4969




2





 





 





 





 





6



                     str_append_end ($str); 




4970




 





 





 





 





 





 



                 }, 




4971




 





 





 





 





 





 



                 'DropTable' => sub { 




4972




1





 





 





 





 





4



                     str_append_funcall ($str, __PACKAGE__.'::Stmt->obj', $in_list); 




4973




1





 





 





 





 





3



                     str_append_join ($str, never_empty => 1); 




4974




 





 





 





 





 





 



   




4975




1





 





 





 





 





6



                     str_append_str ($str, "$thing->{subtype} "); 




4976




1




  
 50
  




 





 





 





5



                     if ($thing->{if_exists}) { 




4977




1





 





 





 





 





3



                         str_append_str ($str, 'IF EXISTS '); 




4978




 





 





 





 





 





 



                     } 




4979




1





 





 





 





 





5



                     str_append_list ($str, $thing->{table}, NO_PARENS); 




4980




 





 





 





 





 





 



   




4981




1




  
 50
  




 





 





 





5



                     if (my $x= $thing->{cascade}) { 




4982




1





 





 





 





 





5



                         str_append_str ($str, " $x"); 




4983




 





 





 





 





 





 



                     } 




4984




1





 





 





 





 





5



                     str_append_end ($str); 




4985




1





 





 





 





 





3



                     str_append_end ($str); 




4986




 





 





 





 





 





 



                 }, 




4987




 





 





 





 





 





 



                 'AlterTable' => sub { 




4988




20





 





 





 





 





55



                     str_append_funcall ($str, __PACKAGE__.'::Stmt->obj', $in_list); 




4989




20





 





 





 





 





87



                     str_append_join ($str, never_empty => 1); 




4990




 





 





 





 





 





 



   




4991




20





 





 





 





 





86



                     str_append_str ($str, "$thing->{subtype} "); 




4992




20




  
 50
  




 





 





 





67



                     if ($thing->{only}) { 




4993




0





 





 





 





 





0



                         str_append_str ($str, 'ONLY '); 




4994




 





 





 





 





 





 



                     } 




4995




20





 





 





 





 





49



                     str_append_thing ($str, $thing->{table}, NOT_IN_LIST, NO_PARENS); 




4996




 





 





 





 





 





 



   




4997




20





 





 





 





 





998



                     str_append_join ($str, sep => ' ', prefix => ' '); 




4998




20





 





 





 





 





35



                     for my $l ($thing->{functor}, @{ $thing->{arg} }) { 




 




20





 





 





 





 





54



   




4999




61





 





 





 





 





123



                         str_append_thing ($str, $l, NOT_IN_LIST, NO_PARENS); 




5000




 





 





 





 





 





 



                     } 




5001




20





 





 





 





 





156



                     str_append_end ($str); 




5002




 





 





 





 





 





 



   




5003




20





 





 





 





 





43



                     str_append_end ($str); 




5004




20





 





 





 





 





40



                     str_append_end ($str); 




5005




 





 





 





 





 





 



                 }, 




5006




 





 





 





 





 





 



                 'Interpol' => sub { 




5007




3





 





 





 





 





13



                     str_append_typed ($str, 'stmt', 'Stmt', $thing, $in_list); 




5008




 





 





 





 





 





 



                 }, 




5009




230





 





 




  
141
  




 





11239



             ); 




5010




 





 





 





 





 





 



         }, 




5011




 





 





 





 





 





 



   




5012




 





 





 





 





 





 



         'TableOption' => sub { 




5013




 





 





 





 





 





 



             switch ($thing->{type}, 




5014




 





 





 





 





 





 



                'interpol' => sub { 




5015




2





 





 





 





 





7



                     str_append_typed ($str, 'tableopt', 'TableOption', $thing, $in_list); 




5016




 





 





 





 





 





 



                }, 




5017




 





 





 





 





 





 



                'literal' => sub { 




5018




6





 





 





 





 





18



                     str_append_join  ($str, sep => ' '); 




5019




6





 





 





 





 





20



                     str_append_str   ($str, $thing->{name}); 




5020




6





 





 





 





 





19



                     str_append_thing ($str, $thing->{value}, NOT_IN_LIST, NO_PARENS); 




5021




6





 





 





 





 





435



                     str_append_end   ($str); 




5022




 





 





 





 





 





 



                } 




5023




8





 





 




  
3
  




 





52



             ); 




5024




 





 





 





 





 





 



         }, 




5025




 





 





 





 





 





 



   




5026




 





 





 





 





 





 



         'Keyword' => sub { 




5027




1





 





 




  
0
  




 





4



             str_append_str ($str, $thing->{keyword}); 




5028




 





 





 





 





 





 



         }, 




5029




 





 





 





 





 





 



   




5030




 





 





 





 





 





 



         'Join' => sub { 




5031




15




  
100
  




 




  
9
  




 





47



             if ($thing->{type} eq 'interpol') { 




5032




5





 





 





 





 





79



                 str_append_typed ($str, 'joinclause', 'Join', $thing, $in_list); 




5033




 





 





 





 





 





 



             } 




5034




 





 





 





 





 





 



             else { 




5035




10





 





 





 





 





25



                 str_append_join ($str, result0 => ''); 




5036




 





 





 





 





 





 



   




5037




10




  
100
  




 





 





 





27



                 if ($thing->{natural}) { 




5038




3




  
 50
  




 





 





 





10



                     if ($thing->{type} eq 'INNER') { 




5039




3





 





 





 





 





8



                         str_append_str ($str, "NATURAL JOIN "); 




5040




 





 





 





 





 





 



                     } 




5041




 





 





 





 





 





 



                     else { 




5042




0





 





 





 





 





0



                         str_append_str ($str, "NATURAL $thing->{type} JOIN "); 




5043




 





 





 





 





 





 



                     } 




5044




 





 





 





 





 





 



                 } 




5045




 





 





 





 





 





 



                 else { 




5046




7





 





 





 





 





23



                     str_append_str ($str, "$thing->{type} JOIN "); 




5047




 





 





 





 





 





 



                 } 




5048




 





 





 





 





 





 



   




5049




10





 





 





 





 





34



                 str_append_list ($str, $thing->{table}, NO_PARENS); 




5050




 





 





 





 





 





 



   




5051




10




  
100
  




 





 





 





44



                 if (my $on= $thing->{on}) { 




 




 




  
100
  




 





 





 





 



   




5052




3





 





 





 





 





7



                     str_append_str ($str, ' ON '); 




5053




3





 





 





 





 





10



                     str_append_thing ($str, $on, NOT_IN_LIST, NO_PARENS); 




5054




 





 





 





 





 





 



                 } 




5055




 





 





 





 





 





 



                 elsif (my $using= $thing->{using}) { 




5056




2





 





 





 





 





7



                     str_append_str  ($str, ' USING ('); 




5057




2





 





 





 





 





6



                     str_append_list ($str, $using, NO_PARENS); 




5058




2





 





 





 





 





6



                     str_append_str  ($str, ')'); 




5059




 





 





 





 





 





 



                 }; 




5060




 





 





 





 





 





 



   




5061




10





 





 





 





 





319



                 str_append_end ($str); 




5062




 





 





 





 





 





 



             } 




5063




 





 





 





 





 





 



         }, 




5064




 





 





 





 





 





 



   




5065




 





 





 





 





 





 



         'Table' => 'Column', 




5066




 





 





 





 





 





 



         'CharSet' => 'Column', 




5067




 





 





 





 





 





 



         'Collate' => 'Column', 




5068




 





 





 





 





 





 



         'Index' => 'Column', 




5069




 





 





 





 





 





 



         'Constraint' => 'Column', 




5070




 





 





 





 





 





 



         'Transliteration' => 'Column', 




5071




 





 





 





 





 





 



         'Transcoding' => 'Column', 




5072




 





 





 





 





 





 



         'Engine' => 'Column', 




5073




 





 





 





 





 





 



         'Column' => sub { 




5074




509





 





 




  
355
  




 





878



             str_append_ident_chain ($str, $in_list, $thing->{kind}, @{ $thing->{ident_chain} }); 




 




509





 





 





 





 





1772



   




5075




 





 





 





 





 





 



         }, 




5076




 





 





 





 





 





 



   




5077




 





 





 





 





 





 



         'TableAs' => sub { 




5078




122




  
100
  




 




  
102
  




 





467



             if (my $x= $thing->{as}) { 




5079




3





 





 





 





 





8



                 str_append_join  ($str, sep => ' AS ', never_empty => 1); 




5080




3





 





 





 





 





12



                 str_append_thing ($str, $thing->{table}, NOT_IN_LIST, NO_PARENS); 




5081




3





 





 





 





 





152



                 str_append_thing ($str, $x, NOT_IN_LIST, NO_PARENS); 




5082




3





 





 





 





 





151



                 str_append_end   ($str); 




5083




 





 





 





 





 





 



             } 




5084




 





 





 





 





 





 



             else { 




5085




119





 





 





 





 





307



                 str_append_thing ($str, $thing->{table}, $in_list, NO_PARENS); 




5086




 





 





 





 





 





 



             } 




5087




 





 





 





 





 





 



         }, 




5088




 





 





 





 





 





 



   




5089




 





 





 





 





 





 



         'ExprAs' => sub { 




5090




224




  
100
  




 




  
123
  




 





639



             if (my $x= $thing->{as}) { 




5091




4





 





 





 





 





15



                 str_append_join  ($str, sep => ' AS ', never_empty => 1); 




5092




4





 





 





 





 





16



                 str_append_thing ($str, $thing->{expr}, NOT_IN_LIST, NO_PARENS); 




5093




3





 





 





 





 





429



                 str_append_thing ($str, $x, NOT_IN_LIST, NO_PARENS); 




5094




3





 





 





 





 





132



                 str_append_end   ($str); 




5095




 





 





 





 





 





 



             } 




5096




 





 





 





 





 





 



             else { 




5097




220





 





 





 





 





967



                 str_append_thing ($str, $thing->{expr}, $in_list, $parens); 




5098




 





 





 





 





 





 



             } 




5099




 





 





 





 





 





 



         }, 




5100




 





 





 





 





 





 



         'Order' => sub { 




5101




 





 





 





 





 





 



             switch($thing->{type}, 




5102




 





 





 





 





 





 



                 'interpol' => sub { 




5103




18




  
100
  




 





 





 





53



                     if ($thing->{desc}) { 




5104




5





 





 





 





 





15



                         str_append_typed ($str, 'desc', 'Order', $thing, $in_list, hashkeys => 1); 




5105




 





 





 





 





 





 



                     } 




5106




 





 





 





 





 





 



                     else { 




5107




13





 





 





 





 





38



                         str_append_typed ($str, 'asc', 'Order', $thing, $in_list, hashkeys => 1); 




5108




 





 





 





 





 





 



                     } 




5109




 





 





 





 





 





 



                 }, 




5110




 





 





 





 





 





 



                 'expr' => sub { 




5111




17




  
100
  




 





 





 





41



                     if ($thing->{desc}) { 




5112




5





 





 





 





 





17



                         str_append_map   ($str, __PACKAGE__.'::desc($_)'); 




5113




5





 





 





 





 





16



                         str_append_thing ($str, $thing->{expr}, $in_list, NO_PARENS); 




5114




5





 





 





 





 





720



                         str_append_end   ($str); 




5115




 





 





 





 





 





 



                     } 




5116




 





 





 





 





 





 



                     else { 




5117




12





 





 





 





 





84



                         str_append_thing ($str, $thing->{expr}, $in_list, NO_PARENS); 




5118




 





 





 





 





 





 



                     } 




5119




 





 





 





 





 





 



                 }, 




5120




35





 





 




  
17
  




 





201



             ); 




5121




 





 





 





 





 





 



         }, 




5122




 





 





 





 





 





 



         'TypeList' => sub { 




5123




 





 





 





 





 





 



             switch($thing->{type}, 




5124




 





 





 





 





 





 



                 'interpol' => sub { 




5125




0





 





 





 





 





0



                     str_append_typed ($str, 'typelist', 'Type', $thing, $in_list); 




5126




 





 





 





 





 





 



                 }, 




5127




 





 





 





 





 





 



   




5128




 





 





 





 





 





 



                 'explicit' => sub { 




5129




1





 





 





 





 





5



                     str_append_list ($str, $thing->{arg}, NO_PARENS, prefix => '(', suffix => ')'); 




5130




 





 





 





 





 





 



                         # may not be empty! 




5131




 





 





 





 





 





 



                 }, 




5132




1





 





 




  
0
  




 





7



             ); 




5133




 





 





 





 





 





 



         }, 




5134




 





 





 





 





 





 



         'Type' => sub { 




5135




 





 





 





 





 





 



             switch ($thing->{type}, 




5136




 





 





 





 





 





 



                 'interpol' => sub { 




5137




8





 





 





 





 





24



                     str_append_typed ($str, 'type', 'Type', $thing, $in_list); 




5138




 





 





 





 





 





 



                 }, 




5139




 





 





 





 





 





 



                 'base' => sub { 




5140




22





 





 





 





 





62



                     str_append_perl ($str, __PACKAGE__.'::Type->new()'); 




5141




 





 





 





 





 





 



                 }, 




5142




30





 





 




  
15
  




 





168



             ); 




5143




 





 





 





 





 





 



         }, 




5144




 





 





 





 





 





 



         'TypePost' => sub { 




5145




56




  
 50
  




 




  
23
  




 





125



             return str_append_parens ($str, $thing, NOT_IN_LIST) 




5146




 





 





 





 





 





 



                 if $parens; 




5147




 





 





 





 





 





 



   




5148




56





 





 





 





 





226



             str_append_funcall_begin ($str, __PACKAGE__.'::type_'.$thing->{functor}, $in_list); 




5149




56





 





 





 





 





79



             for my $arg (@{ $thing->{arg} }) { 




 




56





 





 





 





 





119



   




5150




68





 





 





 





 





177



                 str_append_thing ($str, $arg, NOT_IN_LIST, NO_PARENS); 




5151




 





 





 





 





 





 



             } 




5152




56





 





 





 





 





172



             str_append_funcall_end ($str, $in_list); 




5153




56





 





 





 





 





136



             str_append_thing ($str, $thing->{base}, $in_list, NO_PARENS); 




5154




56





 





 





 





 





2841



             str_append_end ($str); 




5155




 





 





 





 





 





 



         }, 




5156




 





 





 





 





 





 



         'ColumnDef' => sub { 




5157




6





 





 




  
1
  




 





21



             str_append_join  ($str, sep => ' '); 




5158




6





 





 





 





 





23



             str_append_thing ($str, $thing->{name},        NOT_IN_LIST, NO_PARENS); 




5159




6





 





 





 





 





325



             str_append_thing ($str, $thing->{column_spec}, NOT_IN_LIST, NO_PARENS); 




5160




6





 





 





 





 





304



             str_append_end   ($str); 




5161




 





 





 





 





 





 



         }, 




5162




 





 





 





 





 





 



   




5163




 





 





 





 





 





 



         'ColumnSpec' => sub { 




5164




 





 





 





 





 





 



             switch ($thing->{type}, 




5165




 





 





 





 





 





 



                 'interpol' => sub { 




5166




7





 





 





 





 





21



                     str_append_typed ($str, 'colspec', 'ColumnSpec', $thing, $in_list); 




5167




 





 





 





 





 





 



                 }, 




5168




 





 





 





 





 





 



                 'base' => sub { 




5169




9





 





 





 





 





34



                     str_append_funcall ($str, __PACKAGE__.'::ColumnSpec->new', $in_list); 




5170




9





 





 





 





 





35



                     str_append_thing ($str, $thing->{datatype}, $in_list, NO_PARENS); 




5171




9





 





 





 





 





474



                     str_append_end ($str); 




5172




 





 





 





 





 





 



                 } 




5173




16





 





 




  
4
  




 





119



             ); 




5174




 





 





 





 





 





 



         }, 




5175




 





 





 





 





 





 



         'ColumnSpecPost' => sub { 




5176




22




  
 50
  




 




  
4
  




 





58



             return str_append_parens ($str, $thing, NOT_IN_LIST) 




5177




 





 





 





 





 





 



                 if $parens; 




5178




 





 





 





 





 





 



   




5179




22





 





 





 





 





90



             str_append_funcall_begin ($str, __PACKAGE__.'::colspec_'.$thing->{functor}, $in_list); 




5180




22





 





 





 





 





32



             for my $arg (@{ $thing->{arg} }) { 




 




22





 





 





 





 





55



   




5181




61





 





 





 





 





124



                 str_append_thing ($str, $arg, NOT_IN_LIST, NO_PARENS); 




5182




 





 





 





 





 





 



             } 




5183




22





 





 





 





 





59



             str_append_funcall_end ($str, $in_list); 




5184




22





 





 





 





 





57



             str_append_thing ($str, $thing->{base}, $in_list, NO_PARENS); 




5185




22





 





 





 





 





1051



             str_append_end ($str); 




5186




 





 





 





 





 





 



         }, 




5187




 





 





 





 





 





 



   




5188




 





 





 





 





 





 



         'TableConstraint' => sub { 




5189




 





 





 





 





 





 



             switch($thing->{type}, 




5190




 





 





 





 





 





 



                 'primary_key' => sub { 




5191




0





 





 





 





 





0



                     str_append_table_key ($str, $thing, 'PRIMARY KEY'); 




5192




 





 





 





 





 





 



                 }, 




5193




 





 





 





 





 





 



                 'unique' => sub { 




5194




1





 





 





 





 





4



                     str_append_table_key ($str, $thing, 'UNIQUE'); 




5195




 





 





 





 





 





 



                 }, 




5196




 





 





 





 





 





 



                 'fulltext' => sub { 




5197




0





 





 





 





 





0



                     str_append_table_key ($str, $thing, 'FULLTEXT'); 




5198




 





 





 





 





 





 



                 }, 




5199




 





 





 





 





 





 



                 'spatial' => sub { 




5200




0





 





 





 





 





0



                     str_append_table_key ($str, $thing, 'SPATIAL'); 




5201




 





 





 





 





 





 



                 }, 




5202




 





 





 





 





 





 



                 'index' => sub { 




5203




0





 





 





 





 





0



                     str_append_table_key ($str, $thing, 'INDEX'); 




5204




 





 





 





 





 





 



                 }, 




5205




 





 





 





 





 





 



                 'foreign_key' => sub { 




5206




2





 





 





 





 





8



                     str_append_table_key ($str, $thing, 'FOREIGN KEY'); 




5207




 





 





 





 





 





 



                 }, 




5208




3





 





 




  
0
  




 





31



             ); 




5209




 





 





 





 





 





 



         }, 




5210




 





 





 





 





 





 



   




5211




 





 





 





 





 





 



         'IndexOption' => sub { 




5212




 





 





 





 





 





 



             switch($thing->{type}, 




5213




 





 





 





 





 





 



                 'using' => sub { 




5214




0





 





 





 





 





0



                     str_append_str ($str, "USING $thing->{arg}"); 




5215




 





 





 





 





 





 



                 } 




5216




0





 





 




  
0
  




 





0



             ); 




5217




 





 





 





 





 





 



         }, 




5218




 





 





 





 





 





 



   




5219




 





 





 





 





 





 



         'References' => sub { 




5220




 





 





 





 





 





 



             # table column match on_delete on_update)); 




5221




4





 





 





 





 





11



             str_append_join  ($str, sep => ' ', 




5222




 





 





 





 





 





 



                 prefix => 'REFERENCES ', 




5223




 





 





 





 





 





 



                 suffix => 




5224




3




  
100
  




 




  
0
  




 





24



                     join('', map { " $_" } 




 




 




  
100
  




 





 





 





 



   




 




 




  
 50
  




 





 





 





 



   




5225




 





 





 





 





 





 



                         ($thing->{match} ? 




5226




 





 





 





 





 





 



                             ('MATCH', $thing->{match}) 




5227




 





 





 





 





 





 



                         :   () 




5228




 





 





 





 





 





 



                         ), 




5229




 





 





 





 





 





 



                         ($thing->{on_delete} ? 




5230




 





 





 





 





 





 



                             ('ON DELETE', $thing->{on_delete}) 




5231




 





 





 





 





 





 



                         :   () 




5232




 





 





 





 





 





 



                         ), 




5233




 





 





 





 





 





 



                         ($thing->{on_update} ? 




5234




 





 





 





 





 





 



                             ('ON UPDATE', $thing->{on_update}) 




5235




 





 





 





 





 





 



                         :   () 




5236




 





 





 





 





 





 



                         ), 




5237




 





 





 





 





 





 



                     ) 




5238




 





 





 





 





 





 



             ); 




5239




3





 





 





 





 





13



             str_append_thing ($str, $thing->{table}, NOT_IN_LIST, NO_PARENS); 




5240




3





 





 





 





 





146



             str_append_list  ($str, $thing->{column}, NO_PARENS, 




5241




 





 





 





 





 





 



                  prefix => '(', suffix => ')', result0 => ''); 




5242




3





 





 





 





 





10



             str_append_end   ($str); 




5243




 





 





 





 





 





 



         }, 




5244




 





 





 





 





 





 



   




5245




 





 





 





 





 





 



         'CharUnit' => sub { 




5246




1





 





 




  
0
  




 





3



             str_append_str ($str, $thing->{name}); 




5247




 





 





 





 





 





 



         }, 




5248




 





 





 





 





 





 



   




5249




 





 





 





 





 





 



         'ExprList' => sub { 




5250




 





 





 





 





 





 



             switch($thing->{type}, 




5251




 





 





 





 





 





 



                 'interpol' => sub { 




5252




5





 





 





 





 





55



                     str_append_typed ($str, 'exprlist', 'Expr', $thing, $in_list); 




5253




 





 





 





 





 





 



                 }, 




5254




 





 





 





 





 





 



   




5255




 





 





 





 





 





 



                 'explicit' => sub { 




5256




6





 





 





 





 





30



                     str_append_list ($str, $thing->{arg}, NO_PARENS, prefix => '(', suffix => ')'); 




5257




 





 





 





 





 





 



                         # may not be empty! 




5258




 





 





 





 





 





 



                 }, 




5259




11





 





 




  
8
  




 





73



             ); 




5260




 





 





 





 





 





 



         }, 




5261




 





 





 





 





 





 



         'ExprEmpty' => sub { 




5262




 





 





 





 





 





 



             # Append an empty string.  Must have an operand here, otherwise 




5263




 





 





 





 





 





 



             # parameters might get mixed up. 




5264




18





 





 




  
10
  




 





33



             str_append_str($str, ''); 




5265




 





 





 





 





 





 



         }, 




5266




 





 





 





 





 





 



         'Check' => sub { 




5267




9





 





 




  
9
  




 





26



             str_append_join  ($str, joinfunc => __PACKAGE__.'::Check->obj'); 




5268




9





 





 





 





 





31



             str_append_thing ($str, $thing->{expr}, NOT_IN_LIST, NO_PARENS); 




5269




9





 





 





 





 





1019



             str_append_end   ($str); 




5270




 





 





 





 





 





 



         }, 




5271




 





 





 





 





 





 



         'Expr' => sub { 




5272




 





 





 





 





 





 



             switch($thing->{type}, 




5273




 





 





 





 





 





 



                 'limit' => sub { 




5274




24





 





 





 





 





104



                     my $limit_cnt_str= perl_val($thing->{arg}, 'Expr', 




5275




 





 





 





 





 





 



                                              ['interpol', 'interpolExpr', '?']); 




5276




24





 





 





 





 





336



                     str_append_perl ($str, __PACKAGE__."::limit_number($limit_cnt_str)"); 




5277




 





 





 





 





 





 



                 }, 




5278




 





 





 





 





 





 



                 'interpol' => sub { 




5279




375




  
100
  



  
100
  




 





 





5438



                     my $func= $thing->{maybe_check} ? 




 




 




  
100
  




 





 





 





 



   




5280




 





 





 





 





 





 



                                    'expr_or_check' 




5281




 





 





 





 





 





 



                               : ($thing->{token}{type} eq 'num' || 




5282




 





 





 





 





 





 



                                  $thing->{token}{type} eq 'string' || 




5283




 





 





 





 





 





 



                                  !$parens) ? 




5284




 





 





 





 





 





 



                                    'expr' 




5285




 





 





 





 





 





 



                               :    'exprparen'; 




5286




375





 





 





 





 





953



                     str_append_typed ($str, $func, 'Expr', $thing, $in_list, hash => 1); 




5287




 





 





 





 





 





 



                 }, 




5288




 





 





 





 





 





 



                 'column' => sub { 




5289




314





 





 





 





 





1046



                     str_append_thing ($str, $thing->{arg}, $in_list, NO_PARENS); 




5290




 





 





 





 





 





 



                 }, 




5291




 





 





 





 





 





 



                 '()' => sub { 




5292




11





 





 





 





 





45



                     str_append_thing ($str, $thing->{arg}, $in_list, PARENS); 




5293




 





 





 





 





 





 



                 }, 




5294




 





 





 





 





 





 



                 'subquery' => sub { 




5295




6





 





 





 





 





21



                     str_append_funcall ($str, __PACKAGE__.'::subquery', $in_list); 




5296




6





 





 





 





 





21



                     str_append_thing ($str, $thing->{arg}, $in_list, NO_PARENS); 




5297




6





 





 





 





 





780



                     str_append_end   ($str); 




5298




 





 





 





 





 





 



                 }, 




5299




 





 





 





 





 





 



                 'prefix1' => sub { 




5300




2





 





 





 





 





4



                     $in_list= NOT_IN_LIST; # just to be sure 




5301




2




  
 50
  




 





 





 





12



                     return str_append_parens ($str, $thing, NOT_IN_LIST) 




5302




 





 





 





 





 





 



                         if $parens; 




5303




2




  
 50
  




 





 





 





4



                     die 'Expected exactly 1 argument' unless scalar(@{ $thing->{arg} }) == 1; 




 




2





 





 





 





 





9



   




5304




 





 





 





 





 





 



   




5305




2





 





 





 





 





14



                     str_append_join ($str, 




5306




 





 





 





 





 





 



                         prefix => "$thing->{functor}{value} ", 




5307




 





 





 





 





 





 



                         never_empty => 1 




5308




 





 





 





 





 





 



                     ); 




5309




2





 





 





 





 





9



                     str_append_thing ($str, $thing->{arg}[0], NOT_IN_LIST, PARENS); 




5310




1





 





 





 





 





80



                     str_append_end ($str); 




5311




 





 





 





 





 





 



                 }, 




5312




 





 





 





 





 





 



                 'prefixn' => sub { 




5313




1





 





 





 





 





3



                     $parens= NO_PARENS; # just to be sure 




5314




1




  
 50
  




 





 





 





3



                     die 'Expected exactly 1 argument' unless scalar(@{ $thing->{arg} }) == 1; 




 




1





 





 





 





 





5



   




5315




 





 





 





 





 





 



   




5316




1




  
 50
  




 





 





 





4



                     if ($in_list) { 




5317




0





 





 





 





 





0



                         str_append_map ($str, "'$thing->{functor}{value} '.(\$_)"); 




5318




 





 





 





 





 





 



                     } 




5319




 





 





 





 





 





 



                     else { 




5320




1





 





 





 





 





7



                         str_append_join ($str, 




5321




 





 





 





 





 





 



                             prefix => "$thing->{functor}{value} ", 




5322




 





 





 





 





 





 



                             never_empty => 1 




5323




 





 





 





 





 





 



                         ); 




5324




 





 





 





 





 





 



                     } 




5325




1





 





 





 





 





4



                     str_append_thing ($str, $thing->{arg}[0], $in_list, PARENS); 




5326




1





 





 





 





 





65



                     str_append_end ($str); 




5327




 





 





 





 





 





 



                 }, 




5328




 





 





 





 





 





 



   




5329




 





 





 





 





 





 



                 'infix2' => sub { 




5330




89





 





 





 





 





148



                     $in_list= NOT_IN_LIST; # just to be sure 




5331




89




  
100
  




 





 





 





287



                     return str_append_parens ($str, $thing, NOT_IN_LIST) 




5332




 





 





 





 





 





 



                         if $parens; 




5333




 





 





 





 





 





 



   




5334




85





 





 





 





 





152



                     my $f= $thing->{functor}; 




5335




85





 





 





 





 





277



                     str_append_join  ($str, joinfunc => __PACKAGE__.'::Infix->obj'); 




5336




85





 





 





 





 





503



                     str_append_str   ($str, $thing->{functor}{value}); 




5337




85





 





 





 





 





330



                     str_append_thing ($str, $thing->{arg}[0], NOT_IN_LIST, PARENS); 




5338




85





 





 





 





 





11596



                     str_append_thing ($str, $thing->{arg}[1], NOT_IN_LIST, PARENS); 




5339




85





 





 





 





 





8056



                     str_append_end   ($str); 




5340




 





 





 





 





 





 



                 }, 




5341




 





 





 





 





 





 



   




5342




 





 





 





 





 





 



                 'infix23' => 'infix3', 




5343




 





 





 





 





 





 



                 'infix3' => sub { 




5344




5





 





 





 





 





9



                     $in_list= NOT_IN_LIST; # just to be sure 




5345




5




  
100
  




 





 





 





17



                     return str_append_parens ($str, $thing, NOT_IN_LIST) 




5346




 





 





 





 





 





 



                         if $parens; 




5347




 





 





 





 





 





 



   




5348




4





 





 





 





 





12



                     my $f= $thing->{functor}; 




5349




4





 





 





 





 





16



                     str_append_join  ($str, never_empty => 1); 




5350




4





 





 





 





 





21



                     str_append_thing ($str, $thing->{arg}[0], NOT_IN_LIST, PARENS); 




5351




4





 





 





 





 





709



                     str_append_str   ($str, " $thing->{functor}{value} "); 




5352




4





 





 





 





 





70



                     str_append_thing ($str, $thing->{arg}[1], NOT_IN_LIST, PARENS); 




5353




4




  
100
  




 





 





 





372



                     if (scalar(@{ $thing->{arg} }) == 3) { 




 




4





 





 





 





 





19



   




5354




2





 





 





 





 





9



                         str_append_str   ($str, " $thing->{functor}{value2} "); 




5355




2





 





 





 





 





7



                         str_append_thing ($str, $thing->{arg}[2], NOT_IN_LIST, PARENS); 




5356




 





 





 





 





 





 



                     } 




5357




4





 





 





 





 





236



                     str_append_end   ($str); 




5358




 





 





 





 





 





 



                 }, 




5359




 





 





 





 





 





 



   




5360




 





 





 





 





 





 



                 # prefix and suffix allow bitwise application: 




5361




 





 





 





 





 





 



                 # Currently not supported via _prefix() and _suffix() helper 




5362




 





 





 





 





 





 



                 # functions, but may be later.  (Needs only a little rewrite 




5363




 





 





 





 





 





 



                 # here.  The helper functions don't need to be changed.) 




5364




 





 





 





 





 





 



                 'prefix()' => 'prefix', 




5365




 





 





 





 





 





 



                 'suffix' => 'prefix', 




5366




 





 





 





 





 





 



                 'prefix' => sub { 




5367




63




  
100
  




 





 





 





216



                     if ($thing->{type} eq 'prefix()') { # for AND() and OR() as functors 




5368




20





 





 





 





 





29



                         $in_list = NOT_IN_LIST; 




5369




 





 





 





 





 





 



                     } 




5370




63





 





 





 





 





133



                     my $f= $thing->{functor}; 




5371




63




  
 50
  



  
 50
  




 





 





323



                     my $fk= $functor_kind{$f->{type} || ''} 




5372




 





 





 





 





 





 



                             or die "Expected $thing->{type} to be mapped by \%functor_kind"; 




5373




63




  
100
  




 





 





 





130



                     if ($in_list) { 




5374




27





 





 





 





 





79



                         my $qt= quote_perl($f->{value}); 




5375




27




  
100
  




 





 





 





152



                         str_append_map ($str, __PACKAGE__."::_".$fk."($qt,".($parens?1:0).",\$_)"); 




5376




27





 





 





 





 





36



                         for my $l (@{ $thing->{arg} }) { 




 




27





 





 





 





 





66



   




5377




35





 





 





 





 





83



                             str_append_thing ($str, $l, IN_LIST, PARENS); 




5378




 





 





 





 





 





 



                         } 




5379




27





 





 





 





 





79



                         str_append_end ($str); 




5380




 





 





 





 





 





 



                     } 




5381




 





 





 





 





 





 



                     else { 




5382




36





 





 





 





 





130



                         str_append_funcall($str, __PACKAGE__."::_".$fk, NOT_IN_LIST); 




5383




36





 





 





 





 





127



                         str_append_thing ($str, $f->{value}, IN_LIST, NO_PARENS); 




5384




36




  
100
  




 





 





 





116



                         str_append_thing ($str, $parens?1:0, IN_LIST, NO_PARENS); 




5385




36





 





 





 





 





46



                         for my $l (@{ $thing->{arg} }) { 




 




36





 





 





 





 





98



   




5386




46





 





 





 





 





110



                             str_append_thing ($str, $l, IN_LIST, PARENS); 




5387




 





 





 





 





 





 



                         } 




5388




36





 





 





 





 





113



                         str_append_end ($str); 




5389




 





 





 





 





 





 



                     } 




5390




 





 





 





 





 





 



                 }, 




5391




 





 





 





 





 





 



   




5392




 





 





 





 





 





 



                 # funcall and infix use args inline if they are in list context. 




5393




 





 





 





 





 





 



                 # They are handled by _prefix() and _suffix() helper functions in order 




5394




 





 





 





 





 





 



                 # to allow dialect conversion: 




5395




 





 





 





 





 





 



                 'funcall' => 'infix()', 




5396




 





 





 





 





 





 



                 'infix()' => sub { 




5397




95





 





 





 





 





146



                     $in_list= NOT_IN_LIST; # just to be sure 




5398




95





 





 





 





 





198



                     my $f= $thing->{functor}; 




5399




95




  
 50
  



  
 50
  




 





 





526



                     my $fk= $functor_kind{$f->{type} || ''} 




5400




 





 





 





 





 





 



                             or die 'Expected $thing->{type} to be mapped by %functor_kind'; 




5401




 





 





 





 





 





 



   




5402




95





 





 





 





 





363



                     str_append_funcall($str, __PACKAGE__."::_".$fk, NOT_IN_LIST); 




5403




95





 





 





 





 





321



                     str_append_thing ($str, $f->{value}, IN_LIST, NO_PARENS); 




5404




95




  
100
  




 





 





 





298



                     str_append_thing ($str, $parens?1:0, IN_LIST, NO_PARENS); 




5405




95





 





 





 





 





139



                     for my $l (@{ $thing->{arg} }) { 




 




95





 





 





 





 





237



   




5406




185





 





 





 





 





429



                         str_append_thing ($str, $l, IN_LIST, PARENS); 




5407




 





 





 





 





 





 



                     } 




5408




95





 





 





 





 





256



                     str_append_end ($str); 




5409




 





 





 





 





 





 



                 }, 




5410




 





 





 





 





 





 



   




5411




 





 





 





 





 





 



                 'funcsep' => sub { 




5412




6





 





 





 





 





9



                     $in_list= NOT_IN_LIST; # just to be sure 




5413




6





 





 





 





 





15



                     str_append_join ($str, never_empty => 1, sep => ' '); 




5414




6





 





 





 





 





26



                     str_append_str  ($str, "$thing->{functor}{value}("); 




5415




6





 





 





 





 





11



                     for my $t (@{ $thing->{arg} }) { 




 




6





 





 





 





 





14



   




5416




27





 





 





 





 





49



                         str_append_thing ($str, $t, NOT_IN_LIST, NO_PARENS); 




5417




 





 





 





 





 





 



                     } 




5418




6





 





 





 





 





16



                     str_append_end  ($str); 




5419




 





 





 





 





 





 



                 }, 




5420




 





 





 





 





 





 



   




5421




 





 





 





 





 





 



                 'case' => sub { 




5422




47





 





 





 





 





69



                     $in_list= NOT_IN_LIST; # just to be sure 




5423




 





 





 





 





 





 



   




5424




 





 





 





 





 





 



                     # FIXME (maybe): we add parens here, so if there are no 




5425




 





 





 





 





 





 



                     # when-then pairs at all and only the else part is printed, 




5426




 





 





 





 





 





 



                     # it will get parens, too, no matter what.  That's ok, 




5427




 





 





 





 





 





 



                     # since it's a non-standard, marginal special case. 




5428




47




  
100
  




 





 





 





127



                     return str_append_parens ($str, $thing, NOT_IN_LIST) 




5429




 





 





 





 





 





 



                         if $parens; 




5430




 





 





 





 





 





 



   




5431




34





 





 





 





 





61



                     my $sw= $thing->{switchval}; 




5432




34




  
100
  




 





 





 





70



                     if ($sw) { 




5433




22





 





 





 





 





64



                         str_append_funcall ($str, __PACKAGE__."::caseswitch", NOT_IN_LIST); 




5434




22





 





 





 





 





54



                         str_append_thing ($str, $sw, NOT_IN_LIST, NO_PARENS); 




5435




 





 





 





 





 





 



                     } 




5436




 





 





 





 





 





 



                     else { 




5437




12





 





 





 





 





36



                         str_append_funcall ($str, __PACKAGE__."::casecond", NOT_IN_LIST); 




5438




 





 





 





 





 





 



                     } 




5439




 





 





 





 





 





 



   




5440




34




  
100
  




 





 





 





3087



                     if (my $e= $thing->{otherwise}) { 




5441




24





 





 





 





 





68



                         str_append_thing ($str, $e, NOT_IN_LIST, NO_PARENS); 




5442




 





 





 





 





 





 



                     } 




5443




 





 





 





 





 





 



                     else { 




5444




10





 





 





 





 





26



                         str_append_str ($str, 'NULL'); 




5445




 





 





 





 





 





 



                     } 




5446




 





 





 





 





 





 



   




5447




34





 





 





 





 





2022



                     for my $wh (@{ $thing->{arg} }) { 




 




34





 





 





 





 





111



   




5448




30




  
 50
  




 





 





 





101



                         if (ref($wh) eq 'ARRAY') { 




5449




30





 





 





 





 





65



                             my ($when,$expr)= @$wh; 




5450




30





 





 





 





 





80



                             str_append_funcall ($str, __PACKAGE__.'::whenthen', NOT_IN_LIST); 




5451




30





 





 





 





 





82



                             str_append_thing ($str, $when, NOT_IN_LIST, NO_PARENS); 




5452




30





 





 





 





 





2452



                             str_append_thing ($str, $expr, NOT_IN_LIST, NO_PARENS); 




5453




30





 





 





 





 





2518



                             str_append_end ($str); 




5454




 





 





 





 





 





 



                         } 




5455




 





 





 





 





 





 



                         else { 




5456




0





 





 





 





 





0



                             die 'expected array'; 




5457




 





 





 





 





 





 



                         } 




5458




 





 





 





 





 





 



                     } 




5459




 





 





 





 





 





 



   




5460




34





 





 





 





 





92



                     str_append_end ($str); 




5461




 





 





 





 





 





 



                 }, 




5462




1038





 





 




  
618
  




 





25656



             ); 




5463




 





 





 





 





 





 



         }, 




5464




 





 





 





 





 





 



   




5465




 





 





 





 





 





 



         'ColumnName' => sub { 




5466




 





 





 





 





 





 



             switch ($thing->{type}, 




5467




 





 





 





 





 





 



                 'interpol' => 'ident', 




5468




 





 





 





 





 





 



                 'ident' => sub { 




5469




48





 





 





 





 





134



                     str_append_typed ($str, 'colname', 'none', $thing, $in_list, hashkeys => 1); 




5470




 





 





 





 





 





 



                 } 




5471




48





 





 




  
11
  




 





236



             ); 




5472




 





 





 





 





 





 



         }, 




5473




 





 





 





 





 





 



   




5474




 





 





 





 





 





 



         'ColumnIndex' => sub { 




5475




2




  
 50
  



  
 66
  



  
0
  




 





14



             if (defined $thing->{length} || $thing->{desc}) { 




5476




2





 





 





 





 





5



                 str_append_join  ($str, sep => ' '); 




5477




2





 





 





 





 





7



                 str_append_thing ($str, $thing->{name}, NOT_IN_LIST, NO_PARENS); 




5478




2




  
100
  




 





 





 





109



                 if (defined $thing->{length}) { 




5479




1





 





 





 





 





3



                     str_append_join  ($str, prefix => '(', suffix => ')'); 




5480




1





 





 





 





 





5



                     str_append_thing ($str, $thing->{length}, NOT_IN_LIST, NO_PARENS); 




5481




1





 





 





 





 





99



                     str_append_end   ($str); 




5482




 





 





 





 





 





 



                 } 




5483




2




  
100
  




 





 





 





6



                 if ($thing->{desc}) { 




5484




1





 





 





 





 





5



                     str_append_str ($str, 'DESC'); 




5485




 





 





 





 





 





 



                 } 




5486




2





 





 





 





 





5



                 str_append_end   ($str); 




5487




 





 





 





 





 





 



             } 




5488




 





 





 





 





 





 



             else { 




5489




0





 





 





 





 





0



                 str_append_thing ($str, $thing->{name}, $in_list, $parens); 




5490




 





 





 





 





 





 



             } 




5491




 





 





 





 





 





 



         }, 




5492




 





 





 





 





 





 



   




5493




 





 





 





 





 





 



         'TableName' => sub { 




5494




 





 





 





 





 





 



             switch ($thing->{type}, 




5495




 





 





 





 





 





 



                 'interpol' => 'ident', 




5496




 





 





 





 





 





 



                 'ident' => sub { 




5497




3





 





 





 





 





13



                     str_append_typed ($str, 'tabname', 'none', $thing, $in_list, hashkeys => 1); 




5498




 





 





 





 





 





 



                 } 




5499




3





 





 




  
1
  




 





18



             ); 




5500




 





 





 





 





 





 



         }, 




5501




 





 





 





 





 





 



   




5502




 





 





 





 





 





 



         'Fetch' => 'Do', 




5503




 





 





 





 





 





 



         'Do' => sub { 




5504




12





 





 




  
12
  




 





47



             str_append_thing ($str, $thing->{stmt}, $in_list, $parens); 




5505




 





 





 





 





 





 



         }, 




5506




2423





 





 





 





 





109168



     ); 




5507




 





 





 





 





 





 



 } 




5508




 





 





 





 





 





 



   




5509




 





 





 





 





 





 



 sub to_perl($$\@) 




5510




 





 





 





 





 





 



 { 




5511




278





 





 




  
278
  



  
0
  




589



     my ($line_start, $kind, $things)= @_; 




5512




278





 





 





 





 





706



     my $str= str_new($line_start); 




5513




278





 





 





 





 





572



     for my $thing (@$things) { 




5514




383





 





 





 





 





1139



         str_append_thing ($str, $thing, IN_LIST, NO_PARENS); 




5515




 





 





 





 





 





 



     } 




5516




275





 





 





 





 





834



     my $text= str_get_string($str); 




5517




275





 





 





 





 





2219



     return "do{".__PACKAGE__."::_max1_if_scalar map{".__PACKAGE__."::${kind}->obj(\$_)} $text}", 




5518




 





 





 





 





 





 



 } 




5519




 





 





 





 





 





 



   




5520




 





 





 





 





 





 



 ###################################################################### 




5521




 





 





 





 





 





 



 # Top-level parser interface: 




5522




 





 





 





 





 





 



   




5523




 





 





 





 





 





 



 sub lx_die_perhaps($;$) 




5524




 





 





 





 





 





 



 { 




5525




559





 





 




  
559
  



  
0
  




891



     my $lx= shift; 




5526




 





 





 





 





 





 



   




5527




 





 





 





 





 





 



     # if a test value is given, check that it is defined: 




5528




559




  
100
  




 





 





 





1203



     if (scalar(@_)) { 




5529




280





 





 





 





 





406



         my ($check_val)= @_; 




5530




280




  
100
  




 





 





 





705



         unless (defined $check_val) { 




5531




1





 




  
 50
  




 





 





6



             $lx->{error}||= 'Unknown error'; 




5532




 





 





 





 





 





 



         } 




5533




 





 





 





 





 





 



     } 




5534




 





 





 





 





 





 



   




5535




 





 





 





 





 





 



     # if an error is set, then die: 




5536




559




  
100
  




 





 





 





1548



     if ($lx->{error}) { 




5537




2





 





 





 





 





9



         die lx_pos($lx).": Error: $lx->{error}\n"; 




5538




 





 





 





 





 





 



     } 




5539




 





 





 





 





 





 



 } 




5540




 





 





 





 





 





 



   




5541




 





 





 





 





 





 



   




5542




 





 





 





 





 





 



 sub parse_1_or_list($$$;$) 




5543




 





 





 





 





 





 



 { 




5544




273





 





 




  
273
  



  
0
  




518



     my ($lx, $parse_elem, $list_sep, $end)= @_; 




5545




273





 





 





 





 





877



     my $r= parse_list([], $lx, $parse_elem, $list_sep, $end); 




5546




273





 





 





 





 





865



     lx_die_perhaps($lx, $r); 




5547




272





 





 





 





 





942



     return @$r; 




5548




 





 





 





 





 





 



 } 




5549




 





 





 





 





 





 



   




5550




 





 





 





 





 





 



 sub parse_0_try_list($$) 




5551




 





 





 





 





 





 



 { 




5552




7





 





 




  
7
  



  
0
  




65



     my ($lx, $parse_elem)= @_; 




5553




7





 





 





 





 





29



     my $r= parse_try_list([], $lx, $parse_elem); 




5554




7





 





 





 





 





26



     lx_die_perhaps($lx, $r); 




5555




7





 





 





 





 





21



     return @$r; 




5556




 





 





 





 





 





 



 } 




5557




 





 





 





 





 





 



   




5558




 





 





 





 





 





 



 sub parse_stmt_list($) 




5559




 





 





 





 





 





 



 { 




5560




137





 





 




  
137
  



  
0
  




1115



     parse_1_or_list ($_[0], \&parse_stmt,  ';', ['}',')',']']); 




5561




 





 





 





 





 





 



 } 




5562




 





 





 





 





 





 



   




5563




 





 





 





 





 





 



 sub parse_do_stmt($) 




5564




 





 





 





 





 





 



 { 




5565




2





 





 




  
2
  



  
0
  




5



     my ($lx) = @_; 




5566




2





 





 





 





 





5



     map { 




5567




2





 





 





 





 





6



         my $stmt = $_; 




5568




2





 





 





 





 





6



         my $r = create($lx, 'Do', qw(stmt)); 




5569




2





 





 





 





 





5



         $r->{stmt} = $stmt; 




5570




2





 





 





 





 





9



         $r; 




5571




 





 





 





 





 





 



     } 




5572




 





 





 





 





 





 



     parse_stmt_list($lx); 




5573




 





 





 





 





 





 



 } 




5574




 





 





 





 





 





 



   




5575




 





 





 





 





 





 



 sub parse_fetch_stmt($) 




5576




 





 





 





 





 





 



 { 




5577




10





 





 




  
10
  



  
0
  




18



     my ($lx) = @_; 




5578




10





 





 





 





 





21



     map { 




5579




10





 





 





 





 





39



         my $stmt = $_; 




5580




10





 





 





 





 





29



         my $r = create($lx, 'Fetch', qw(stmt)); 




5581




10





 





 





 





 





23



         $r->{stmt} = $stmt; 




5582




10





 





 





 





 





46



         $r; 




5583




 





 





 





 





 





 



     } 




5584




 





 





 





 





 





 



     parse_stmt_list($lx); 




5585




 





 





 





 





 





 



 } 




5586




 





 





 





 





 





 



   




5587




 





 





 





 





 





 



 my %top_parse= ( 




5588




 





 





 





 





 





 



     # pure parse actions: 




5589




 





 





 





 





 





 



     'Stmt'            => \&parse_stmt_list, 




5590




 





 





 





 





 





 



   




5591




 





 





 





 





 





 



     'Join'            => sub { parse_0_try_list($_[0], \&parse_join)                 }, 




5592




 





 





 





 





 





 



     'TableOption'     => sub { parse_0_try_list($_[0], \&parse_table_option)         }, 




5593




 





 





 





 





 





 



   




5594




 





 





 





 





 





 



     'Expr'            => sub { parse_1_or_list ($_[0], \&parse_expr,            ',') }, 




5595




 





 





 





 





 





 



     'Check'           => sub { parse_1_or_list ($_[0], \&parse_check,           ',') }, 




5596




 





 





 





 





 





 



     'Type'            => sub { parse_1_or_list ($_[0], \&parse_type,            ',') }, 




5597




 





 





 





 





 





 



     'Column'          => sub { parse_1_or_list ($_[0], \&parse_column,          ',') }, 




5598




 





 





 





 





 





 



     'Table'           => sub { parse_1_or_list ($_[0], \&parse_table,           ',') }, 




5599




 





 





 





 





 





 



     'Index'           => sub { parse_1_or_list ($_[0], \&parse_index,           ',') }, 




5600




 





 





 





 





 





 



     'CharSet'         => sub { parse_1_or_list ($_[0], \&parse_charset,         ',') }, 




5601




 





 





 





 





 





 



     'Collate'         => sub { parse_1_or_list ($_[0], \&parse_collate,         ',') }, 




5602




 





 





 





 





 





 



     'Constraint'      => sub { parse_1_or_list ($_[0], \&parse_constraint,      ',') }, 




5603




 





 





 





 





 





 



     'Transliteration' => sub { parse_1_or_list ($_[0], \&parse_transliteration, ',') }, 




5604




 





 





 





 





 





 



     'Transcoding'     => sub { parse_1_or_list ($_[0], \&parse_transcoding,     ',') }, 




5605




 





 





 





 





 





 



     'Order'           => sub { parse_1_or_list ($_[0], \&parse_order,           ',') }, 




5606




 





 





 





 





 





 



     'ColumnSpec'      => sub { parse_1_or_list ($_[0], \&parse_column_spec,     ',') }, 




5607




 





 





 





 





 





 



   




5608




 





 





 





 





 





 



     # parse & execute actions: 




5609




 





 





 





 





 





 



     'Do'              => sub { parse_do_stmt   ($_[0]) }, 




5610




 





 





 





 





 





 



     'Fetch'           => sub { parse_fetch_stmt($_[0]) }, 




5611




 





 





 





 





 





 



 ); 




5612




 





 





 





 





 





 



 my $top_parse_re=  '(?:'.join('|', sort { length($b) <=> length($a) } '',     keys %top_parse).')'; 




5613




 





 





 





 





 





 



 my $top_parse_re2= '(?:'.join('|', sort { length($b) <=> length($a) } 'none', keys %top_parse).')'; 




5614




 





 





 





 





 





 



   




5615




 





 





 





 





 





 



 sub interpol_set_context ($$) 




5616




 





 





 





 





 





 



 { 




5617




515





 





 




  
515
  



  
0
  




1002



     my ($text, $ctxt)= @_; 




5618




515





 





 





 





 





765



     $text=~ s/(\Q${\SQL_MARK}\E$top_parse_re)(?::$top_parse_re2)?(\s*\{)/$1:$ctxt$2/gs; 




 




515





 





 





 





 





4118



   




5619




515





 





 





 





 





2461



     return $text; 




5620




 





 





 





 





 





 



 } 




5621




 





 





 





 





 





 



   




5622




 





 





 





 





 





 



 sub good_interpol_type($) 




5623




 





 





 





 





 





 



 { 




5624




8





 





 




  
8
  



  
0
  




16



     my ($type)= @_; 




5625




8





 





 





 





 





41



     return !!$top_parse{$type}; 




5626




 





 





 





 





 





 



 } 




5627




 





 





 





 





 





 



   




5628




 





 





 





 





 





 



 sub mark_sql() 




5629




 





 





 





 





 





 



 { 




5630




 





 





 





 





 





 



     # Step 1: 




5631




 





 





 





 





 





 



     # This function will get the text without comments, strings, etc., 




5632




 





 





 





 





 





 



     # and replace the initial SQL marking the start of SQL syntax by 




5633




 





 





 





 





 





 



     # our special SQL_MARK.  Then, the unprocessed text will be 




5634




 





 





 





 





 





 



     # processed by replace_sql(). 




5635




5





 





 




  
5
  



  
0
  




576



     s/\b\Q$sql_marker\E($top_parse_re\s*\{)/${\SQL_MARK}$1/gs; 




 




259





 





 





 





 





2135



   




5636




 





 





 





 





 





 



   




5637




 





 





 





 





 





 



     # Step 2: 




5638




 





 





 





 





 





 



     # Unmark false positives.  The above finds false matches in 




5639




 





 





 





 





 





 



     # variables: 




5640




 





 





 





 





 





 



     # 




5641




 





 





 





 





 





 



     #    $sql{...} 




5642




 





 





 





 





 





 



     # 




5643




 





 





 





 





 





 



     # We cannot(?) do this in one go, as we'd need a variable-width 




5644




 





 





 





 





 





 



     # negative look-behind regexp, which Perl does not have.  This 




5645




 





 





 





 





 





 



     # is because there can be arbitrary white space between $ and 




5646




 





 





 





 





 





 



     # a variable name. 




5647




5





 





 





 





 





13



     s/([\$\@\%]\s*)\Q${\SQL_MARK}\E/$1$sql_marker/gs; 




 




5





 





 





 





 





986



   




5648




 





 





 





 





 





 



   




5649




 





 





 





 





 





 



     # Note that there are still false positives, which are really hard 




5650




 





 





 





 





 





 



     # to find unless we start parsing Perl completely: 




5651




 





 





 





 





 





 



     # 




5652




 





 





 





 





 





 



     #   ${ sql{blah} } 




5653




 





 





 





 





 





 



 } 




5654




 





 





 





 





 





 



   




5655




 





 





 





 





 





 



 sub parse($$) 




5656




 





 





 





 





 





 



 { 




5657




22





 





 




  
22
  



  
0
  




22740



     my ($kind, $str)= @_; 




5658




22





 





 





 





 





104



     my $lx= lexer_new ($str, "", 0); 




5659




22





 





 





 





 





76



     my $func= $top_parse{$kind}; 




5660




22




  
 50
  




 





 





 





134



     return undef unless $func; 




5661




22




  
 50
  




 





 





 





84



     return () if looking_at($lx, ''); 




5662




22





 





 





 





 





86



     my @thing= $func->($lx); 




5663




21





 





 





 





 





95



     expect($lx, '', SHIFT); 




5664




21





 





 





 





 





78



     lx_die_perhaps ($lx); 




5665




20





 





 





 





 





94



     return to_perl(1, $kind, @thing); 




5666




 





 





 





 





 





 



 } 




5667




 





 





 





 





 





 



   




5668




 





 





 





 





 





 



 sub replace_sql() 




5669




 





 





 





 





 





 



 { 




5670




5





 





 




  
5
  



  
0
  




31445



     my ($module, $file, $line)= caller(4); # find our from where we were invoked 




5671




 





 





 





 





 





 



   




5672




5





 





 





 





 





275



     mark_sql(); 




5673




 





 





 





 





 





 



     #print STDERR "DEBUG: BEFORE: $_\n"; 




5674




 





 





 





 





 





 



   




5675




5





 





 





 





 





18



     pos($_)= 0; 




5676




5





 





 





 





 





14



     REPLACEMENT: while (/(\Q${\SQL_MARK}\E($top_parse_re)(?::($top_parse_re2))?\s*\{)/gs) { 




 




263





 





 





 





 





8836



   




5677




 





 





 





 





 





 



         # prepare lexer: 




5678




258





 




  
100
  




 





 





1496



         my $ctxt=     $3 || 'Stmt'; 




5679




258





 





 





 





 





697



         my $speckind= $2; 




5680




258





 




  
 66
  




 





 





872



         my $kind=     $speckind || $ctxt; 




5681




258





 





 





 





 





651



         my $start=    pos($_) - length($1); 




5682




258





 





 





 





 





4138



         my $prefix=   substr($_, 0, $start); 




5683




258





 





 





 





 





9916



         my $line_rel= ($prefix =~ tr/\n//); 




5684




258





 





 





 





 





874



         my $lx=       lexer_new ($_, $file, $line + $line_rel); 




5685




 





 





 





 





 





 



   




5686




 





 





 





 





 





 



         # select parser: 




5687




258





 





 





 





 





578



         my $func= $top_parse{$kind}; 




5688




258




  
 50
  




 





 





 





638



         unless ($func) { 




5689




0





 





 





 





 





0



             die "$file:".($line+$line_rel+1). 




5690




 





 





 





 





 





 



                   ": Error: Plain ${sql_marker}${speckind}{...} is illegal, because the ". 




5691




 





 





 





 





 





 



                   "surrounding block must not return an object.\n\tPlease use ". 




5692




 





 





 





 





 





 



                   (english_or map "${sql_marker}${_}{...}", keys %top_parse)." to disambiguate.\n"; 




5693




0





 





 





 





 





0



             last REPLACEMENT; 




5694




 





 





 





 





 





 



         } 




5695




 





 





 





 





 





 



   




5696




 





 





 





 





 





 



         # parse (including closing brace): 




5697




258





 





 





 





 





636



         my @thing= $func->($lx); 




5698




258





 





 





 





 





783



         expect ($lx, '}', SHIFT); 




5699




258





 





 





 





 





895



         lx_die_perhaps ($lx); 




5700




 





 





 





 





 





 



   




5701




258





 





 





 





 





681



         my $end= $lx->{token}{pos}; 




5702




258




  
 50
  



  
 33
  




 





 





1302



         my_confess unless defined $end && $start < $end; 




5703




 





 





 





 





 





 



   




5704




 





 





 





 





 





 



         # Make Perl code: 




5705




 





 





 





 





 





 



         # Represent the parse result as a list in Perl (if it's only 




5706




 





 





 





 





 





 



         # one element, the parens don't hurt).  Each thing is 




5707




 





 





 





 





 





 



         # handled individually by to_perl(): 




5708




258





 





 





 





 





880



         my $perl= to_perl($line + $line_rel, $kind, @thing); 




5709




 





 





 





 





 





 



   




5710




 





 





 





 





 





 



         # replace: 




5711




258




  
 50
  




 





 





 





773



         print STDERR "$file:".($line+$line_rel+1).': DEBUG: '.__PACKAGE__." replacement: $perl\n" 




5712




 





 





 





 





 





 



             if $debug; 




5713




 





 





 





 





 





 



   




5714




258





 





 





 





 





22290



         my $old_text= substr($_, $start, $end-$start, $perl); # extract and replace text 




5715




 





 





 





 





 





 



             # pos($_) is now undef, which is ok, we will 




5716




 





 





 





 





 





 



             # rescan the text anyway. 




5717




 





 





 





 





 





 



   




5718




 





 





 





 





 





 



         # Insert newlines at the end that have been dropped so that the line 




5719




 





 





 





 





 





 



         # count does not change and Perl's error messages are useful: 




5720




258





 





 





 





 





566



         my $line_cnt_old= ($old_text =~ tr/\n//); 




5721




258





 





 





 





 





646



         my $line_cnt_new= ($perl     =~ tr/\n//); 




5722




258




  
 50
  




 





 





 





747



         my_confess "More newlines than before" #.": \n###\n$old_text\n###$perl\n###\n" 




5723




 





 





 





 





 





 



             if $line_cnt_new > $line_cnt_old; 




5724




 





 





 





 





 





 



   




5725




258




  
100
  




 





 





 





815



         if (my $line_cnt_less= $line_cnt_old - $line_cnt_new) { 




5726




101





 





 





 





 





2403



             substr($_, $start + length($perl), 0, "\n" x $line_cnt_less); 




5727




 





 





 





 





 





 



         } 




5728




 





 





 





 





 





 



   




5729




 





 





 





 





 





 



         # rescan everything in order to recurse into embedded sql{...}: 




5730




258





 





 





 





 





7112



         pos($_)= 0; 




5731




 





 





 





 





 





 



     } 




5732




5





 





 





 





 





30



     pos($_)= undef; 




5733




 





 





 





 





 





 



   




5734




 





 





 





 





 





 



     #print STDERR "DEBUG: AFTER: $_\n"; 




5735




 





 





 





 





 





 



 }; 




5736




 





 





 





 





 





 



   




5737




 





 





 





 





 





 



 FILTER_ONLY 




5738




 





 





 





 





 





 



     # code_no_comments => \&mark_sql,    # This is way to slow. 




5739




 





 





 





 





 





 



     all  => \&replace_sql; 




5740




 





 





 





 





 





 



   




5741




 





 





 





 





 





 



 ###################################################################### 




5742




 





 





 





 





 





 



 # Functions used in generated code: 




5743




 





 





 





 





 





 



   




5744




 





 





 





 





 





 



 # Obj: 




5745




 





 





 





 





 





 



 { 




5746




 





 





 





 





 





 



     package SQL::Yapp::Obj; 




5747




 





 





 





 





 





 



   




5748




5





 





 




  
5
  




 





79



     use strict; 




 




5





 





 





 





 





18



   




 




5





 





 





 





 





251



   




5749




5





 





 




  
5
  




 





30



     use warnings; 




 




5





 





 





 





 





14



   




 




5





 





 





 





 





311



   




5750




5





 





 




  
5
  




 





30



     use Carp qw(croak); 




 




5





 





 





 





 





14



   




 




5





 





 





 





 





758



   




5751




 





 





 





 





 





 



   




5752




0





 





 




  
0
  




 





0



     sub op($) { return ''; } 




5753




 





 





 





 





 





 



   




5754




 





 





 





 





 





 



     ###################################################################### 




5755




 





 





 





 





 





 



     # stringify: simply return second entry in array, the string: 




5756




 





 





 





 





 





 



     use overload '""' => 'value', 




5757




5





 





 




  
5
  




 





28



                  cmp  => sub { "$_[0]" cmp "$_[1]" }; 




 




5





 





 




  
173
  




 





13



   




 




5





 





 





 





 





84



   




 




173





 





 





 





 





25841



   




5758




 





 





 





 





 





 



   




5759




 





 





 





 





 





 



     sub type_error($$) 




5760




 





 





 





 





 





 



     { 




5761




3





 





 




  
3
  




 





10



         my ($x, $want)= @_; 




5762




3





 





 





 





 





7



         my $r= ref($x); 




5763




3





 





 





 





 





19



         $r=~ s/^SQL::Yapp:://; 




5764




3





 





 





 





 





631



         croak "Error: Expected $want, but found ".$r; 




5765




 





 





 





 





 





 



     } 




5766




 





 





 





 





 





 



   




5767




0





 





 




  
0
  




 





0



     sub asc($)              { $_[0]->type_error('Asc');             } 




5768




0





 





 




  
0
  




 





0



     sub assign($)           { $_[0]->type_error('assignment');      } 




5769




0





 





 




  
0
  




 





0



     sub charset($)          { $_[0]->type_error('CharSet');         } 




5770




0





 





 




  
0
  




 





0



     sub constraint($)       { $_[0]->type_error('Constraint');      } 




5771




0





 





 




  
0
  




 





0



     sub charset1($)         { $_[0]->type_error('CharSet');         } 




5772




0





 





 




  
0
  




 





0



     sub collate1($)         { $_[0]->type_error('Collate');         } 




5773




0





 





 




  
0
  




 





0



     sub colname($)          { $_[0]->type_error('ColumnName');      } 




5774




0





 





 




  
0
  




 





0



     sub colspec($)          { $_[0]->type_error('ColumnSpec');      } 




5775




0





 





 




  
0
  




 





0



     sub column1($)          { $_[0]->type_error('Column');          } 




5776




1





 





 




  
1
  




 





8



     sub column1_single($)   { $_[0]->type_error('Column');          } 




5777




0





 





 




  
0
  




 





0



     sub constraint1($)      { $_[0]->type_error('Constraint');      } 




5778




0





 





 




  
0
  




 





0



     sub desc($)             { $_[0]->type_error('Desc');            } 




5779




0





 





 




  
0
  




 





0



     sub engine1($)          { $_[0]->type_error('Engine');          } 




5780




0





 





 




  
0
  




 





0



     sub expr($)             { $_[0]->type_error('Expr');            } 




5781




0





 





 




  
0
  




 





0



     sub expr_or_check($)    { $_[0]->type_error('Expr or Check');   } 




5782




0





 





 




  
0
  




 





0



     sub check($)            { $_[0]->type_error('Check');           } 




5783




1





 





 




  
1
  




 





8



     sub exprparen($)        { $_[0]->type_error('Expr');            } 




5784




0





 





 




  
0
  




 





0



     sub index1($)           { $_[0]->type_error('Index');           } 




5785




0





 





 




  
0
  




 





0



     sub joinclause($)       { $_[0]->type_error('JOIN clause');     } 




5786




0





 





 




  
0
  




 





0



     sub limit_number($)     { $_[0]->type_error('number or ?');     } 




5787




0





 





 




  
0
  




 





0



     sub stmt($)             { $_[0]->type_error('Stmt');            } 




5788




0





 





 




  
0
  




 





0



     sub subquery($)         { $_[0]->type_error('subquery');        } 




5789




0





 





 




  
0
  




 





0



     sub table1($)           { $_[0]->type_error('Table');           } 




5790




0





 





 




  
0
  




 





0



     sub tabname($)          { $_[0]->type_error('TableName');       } 




5791




0





 





 




  
0
  




 





0



     sub tableopt($)         { $_[0]->type_error('TableOption');     } 




5792




0





 





 




  
0
  




 





0



     sub transcoding($)      { $_[0]->type_error('Transcoding');     } 




5793




0





 





 




  
0
  




 





0



     sub transliteration1($) { $_[0]->type_error('Transliteration'); } 




5794




0





 





 




  
0
  




 





0



     sub type($)             { $_[0]->type_error('Type');            } 




5795




 





 





 





 





 





 



   




5796




0





 





 




  
0
  




 





0



     sub do($)               { $_[0]->type_error('Do');              } 




5797




0





 





 




  
0
  




 





0



     sub fetch($)            { $_[0]->type_error('Fetch');           } 




5798




 





 





 





 





 





 



 } 




5799




 





 





 





 





 





 



   




5800




 





 





 





 





 





 



 # Obj1: 




5801




 





 





 





 





 





 



 { 




5802




 





 





 





 





 





 



     package SQL::Yapp::Obj1; 




5803




 





 





 





 





 





 



   




5804




5





 





 




  
5
  




 





6540



     use strict; 




 




5





 





 





 





 





11



   




 




5





 





 





 





 





166



   




5805




5





 





 




  
5
  




 





31



     use warnings; 




 




5





 





 





 





 





103



   




 




5





 





 





 





 





170



   




5806




5





 





 




  
5
  




 





26



     use base qw(SQL::Yapp::Obj); 




 




5





 





 





 





 





9



   




 




5





 





 





 





 





3217



   




5807




5





 





 




  
5
  




 





29



     use Scalar::Util qw(blessed); 




 




5





 





 





 





 





18



   




 




5





 





 





 





 





925



   




5808




 





 





 





 





 





 



   




5809




 





 





 





 





 





 



     sub obj($$) 




5810




 





 





 





 





 





 



     { 




5811




890





 





 




  
890
  




 





5995



         my ($class,$x)= @_; 




5812




890




  
100
  



  
 66
  




 





 





4138



         return $x 




5813




 





 





 





 





 





 



             if blessed($x) && $x->isa(__PACKAGE__); 




5814




731





 





 





 





 





4270



         return bless([$x], $class); 




5815




 





 





 





 





 





 



     } 




5816




 





 





 





 





 





 



   




5817




817





 





 




  
817
  




 





5290



     sub value($) { return $_[0][0]; } 




5818




 





 





 





 





 





 



 } 




5819




 





 





 





 





 





 



   




5820




 





 





 





 





 





 



 ############### 




5821




 





 





 





 





 





 



 # Asterisk: 




5822




 





 





 





 





 





 



 { 




5823




 





 





 





 





 





 



     package SQL::Yapp::Asterisk; 




5824




 





 





 





 





 





 



   




5825




5





 





 




  
5
  




 





30



     use strict; 




 




5





 





 





 





 





8



   




 




5





 





 





 





 





156



   




5826




5





 





 




  
5
  




 





23



     use warnings; 




 




5





 





 





 





 





30



   




 




5





 





 





 





 





161



   




5827




5





 





 




  
5
  




 





29



     use base qw(SQL::Yapp::Obj); 




 




5





 





 





 





 





10



   




 




5





 





 





 





 





5651



   




5828




 





 





 





 





 





 



   




5829




 





 





 





 





 





 



     sub obj($) 




5830




 





 





 





 





 





 



     { 




5831




2





 





 




  
2
  




 





6



         my ($class)= @_; 




5832




2





 





 





 





 





11



         return bless([], $class); 




5833




 





 





 





 





 





 



     } 




5834




 





 





 





 





 





 



   




5835




2





 





 




  
2
  




 





19



     sub value($)          { return '*'; } 




5836




 





 





 





 





 





 



   




5837




2





 





 




  
2
  




 





12



     sub column1($)        { return $_[0]; } 




5838




0





 





 




  
0
  




 





0



     sub column1_single($) { return $_[0]; } 




5839




0





 





 




  
0
  




 





0



     sub expr($)           { return $_[0]; } 




5840




0





 





 




  
0
  




 





0



     sub expr_or_check($)  { return $_[0]; } 




5841




 





 





 





 





 





 



   




5842




0





 





 




  
0
  




 





0



     sub asterisk($)       { return $_[0]; } 




5843




 





 





 





 





 





 



 } 




5844




 





 





 





 





 





 



   




5845




 





 





 





 





 





 



 # Question: 




5846




 





 





 





 





 





 



 { 




5847




 





 





 





 





 





 



     package SQL::Yapp::Question; 




5848




 





 





 





 





 





 



   




5849




5





 





 




  
5
  




 





29



     use strict; 




 




5





 





 





 





 





9



   




 




5





 





 





 





 





3751



   




5850




5





 





 




  
5
  




 





27



     use warnings; 




 




5





 





 





 





 





7



   




 




5





 





 





 





 





175



   




5851




5





 





 




  
5
  




 





24



     use base qw(SQL::Yapp::Obj); 




 




5





 





 





 





 





7



   




 




5





 





 





 





 





3466



   




5852




 





 





 





 





 





 



   




5853




 





 





 





 





 





 



     sub obj($) 




5854




 





 





 





 





 





 



     { 




5855




1





 





 




  
1
  




 





4



         my ($class)= @_; 




5856




1





 





 





 





 





6



         return bless([], $class); 




5857




 





 





 





 





 





 



     } 




5858




 





 





 





 





 





 



   




5859




1





 





 




  
1
  




 





7



     sub value($)         { return '?' } 




5860




 





 





 





 





 





 



   




5861




0





 





 




  
0
  




 





0



     sub limit_number($)  { return $_[0]; } 




5862




1





 





 




  
1
  




 





7



     sub exprparen($)     { return $_[0]; } 




5863




0





 





 




  
0
  




 





0



     sub expr($)          { return $_[0]; } 




5864




0





 





 




  
0
  




 





0



     sub expr_or_check($) { return $_[0]; } 




5865




0





 





 




  
0
  




 





0



     sub asc($)           { return $_[0]; } 




5866




0





 





 




  
0
  




 





0



     sub desc($)          { return SQL::Yapp::Desc->obj($_[0]); } 




5867




 





 





 





 





 





 



 } 




5868




 





 





 





 





 





 



   




5869




 





 





 





 





 





 



 # ExprSpecial: 




5870




 





 





 





 





 





 



 { 




5871




 





 





 





 





 





 



     package SQL::Yapp::ExprSpecial; 




5872




 





 





 





 





 





 



   




5873




5





 





 




  
5
  




 





30



     use strict; 




 




5





 





 





 





 





7



   




 




5





 





 





 





 





176



   




5874




5





 





 




  
5
  




 





21



     use warnings; 




 




5





 





 





 





 





7



   




 




5





 





 





 





 





144



   




5875




5





 





 




  
5
  




 





24



     use base qw(SQL::Yapp::Obj1); 




 




5





 





 





 





 





23



   




 




5





 





 





 





 





3507



   




5876




 





 





 





 





 





 



   




5877




0





 





 




  
0
  




 





0



     sub exprparen($)     { return $_[0]; } 




5878




0





 





 




  
0
  




 





0



     sub expr($)          { return $_[0]; } 




5879




0





 





 




  
0
  




 





0



     sub expr_or_check($) { return $_[0]; } 




5880




0





 





 




  
0
  




 





0



     sub asc($)           { return $_[0]; } 




5881




0





 





 




  
0
  




 





0



     sub desc($)          { return SQL::Yapp::Desc->obj($_[0]); } 




5882




 





 





 





 





 





 



 } 




5883




 





 





 





 





 





 



   




5884




 





 





 





 





 





 



 # Stmt: 




5885




 





 





 





 





 





 



 { 




5886




 





 





 





 





 





 



     package SQL::Yapp::Stmt; 




5887




 





 





 





 





 





 



   




5888




5





 





 




  
5
  




 





29



     use strict; 




 




5





 





 





 





 





8



   




 




5





 





 





 





 





151



   




5889




5





 





 




  
5
  




 





21



     use warnings; 




 




5





 





 





 





 





1299



   




 




5





 





 





 





 





158



   




5890




5





 





 




  
5
  




 





30



     use Carp qw(croak); 




 




5





 





 





 





 





7



   




 




5





 





 





 





 





359



   




5891




5





 





 




  
5
  




 





22



     use base qw(SQL::Yapp::Obj1); 




 




5





 





 





 





 





7



   




 




5





 





 





 





 





3376



   




5892




 





 





 





 





 





 



   




5893




1





 





 




  
1
  




 





15



     sub subquery($)      { $_[0]->type_error('SELECT statement'); } 




5894




0





 





 




  
0
  




 





0



     sub exprparen($)     { $_[0]->subquery(); } 




5895




2





 





 




  
2
  




 





19



     sub expr($)          { $_[0]->subquery(); } 




5896




0





 





 




  
0
  




 





0



     sub expr_or_check($) { $_[0]->subquery(); } 




5897




 





 





 





 





 





 



   




5898




3





 





 




  
3
  




 





9



     sub stmt($)          { return $_[0]; } 




5899




 





 





 





 





 





 



   




5900




 





 





 





 





 





 



     sub do($) 




5901




 





 





 





 





 





 



     { 




5902




0





 





 




  
0
  




 





0



         my ($stmt) = @_; 




5903




0





 





 





 





 





0



         my $dbh = SQL::Yapp::get_dbh(); 




5904




0





 





 





 





 





0



         $dbh->do($stmt); 




5905




0





 





 





 





 





0



         return; # return no statements so that _max1_if_scalar is ok with void context 




5906




 





 





 





 





 





 



     } 




5907




 





 





 





 





 





 



 } 




5908




 





 





 





 





 





 



   




5909




 





 





 





 





 





 



 # SelectStmt: 




5910




 





 





 





 





 





 



 { 




5911




 





 





 





 





 





 



     package SQL::Yapp::SelectStmt; 




5912




 





 





 





 





 





 



   




5913




5





 





 




  
5
  




 





29



     use strict; 




 




5





 





 





 





 





10



   




 




5





 





 





 





 





154



   




5914




5





 





 




  
5
  




 





23



     use warnings; 




 




5





 





 





 





 





7



   




 




5





 





 





 





 





147



   




5915




5





 





 




  
5
  




 





21



     use Carp qw(croak); 




 




5





 





 





 





 





16



   




 




5





 





 





 





 





237



   




5916




5





 





 




  
5
  




 





24



     use base qw(SQL::Yapp::Stmt); 




 




5





 





 





 





 





10



   




 




5





 





 





 





 





3305



   




5917




 





 





 





 





 





 



   




5918




2





 





 




  
2
  




 





21



     sub subquery($)      { return '('.($_[0]->value).')'; } 




5919




 





 





 





 





 





 



   




5920




 





 





 





 





 





 



     sub fetch($) 




5921




 





 





 





 





 





 



     { 




5922




0





 





 




  
0
  




 





0



         my ($stmt) = @_; 




5923




0





 





 





 





 





0



         my $dbh = SQL::Yapp::get_dbh(); 




5924




0





 





 





 





 





0



         my $sth = $dbh->prepare($stmt); 




5925




0





 





 





 





 





0



         my $aref = $dbh->selectall_arrayref($sth, { Slice => {} }); 




5926




0




  
  0
  




 





 





 





0



         return unless $aref; 




5927




0





 





 





 





 





0



         return @$aref; 




5928




 





 





 





 





 





 



     } 




5929




 





 





 





 





 





 



 } 




5930




 





 





 





 





 





 



   




5931




 





 





 





 





 





 



 # SelectStmtSingle: 




5932




 





 





 





 





 





 



 { 




5933




 





 





 





 





 





 



     package SQL::Yapp::SelectStmtSingle; 




5934




 





 





 





 





 





 



   




5935




5





 





 




  
5
  




 





39



     use strict; 




 




5





 





 





 





 





14



   




 




5





 





 





 





 





157



   




5936




5





 





 




  
5
  




 





22



     use warnings; 




 




5





 





 





 





 





9



   




 




5





 





 





 





 





161



   




5937




5





 





 




  
5
  




 





22



     use Carp qw(croak); 




 




5





 





 





 





 





10



   




 




5





 





 





 





 





244



   




5938




5





 





 




  
5
  




 





25



     use base qw(SQL::Yapp::SelectStmt); 




 




5





 





 





 





 





19



   




 




5





 





 





 





 





9167



   




5939




 





 





 





 





 





 



   




5940




 





 





 





 





 





 



     sub fetch($) 




5941




 





 





 





 





 





 



     { 




5942




0





 





 




  
0
  




 





0



         my ($stmt) = @_; 




5943




0





 





 





 





 





0



         my $dbh = SQL::Yapp::get_dbh(); 




5944




0





 





 





 





 





0



         my $sth = $dbh->prepare($stmt); 




5945




0




  
  0
  




 





 





 





0



         return unless $sth->execute; 




5946




0





 





 





 





 





0



         my @r= (); 




5947




0





 





 





 





 





0



         while (my $a= $sth->fetchrow_arrayref) { 




5948




0




  
  0
  




 





 





 





0



             die unless scalar(@$a) == 1; 




5949




0





 





 





 





 





0



             push @r, $a->[0]; 




5950




 





 





 





 





 





 



         } 




5951




0





 





 





 





 





0



         return @r; 




5952




 





 





 





 





 





 



     } 




5953




 





 





 





 





 





 



 } 




5954




 





 





 





 





 





 



   




5955




 





 





 





 





 





 



 # Do: 




5956




 





 





 





 





 





 



 # This is a bit different, since the obj() method will actually execute the statement. 




5957




 





 





 





 





 





 



 { 




5958




 





 





 





 





 





 



     package SQL::Yapp::Do; 




5959




 





 





 





 





 





 



   




5960




5





 





 




  
5
  




 





537



     use strict; 




 




5





 





 





 





 





7



   




 




5





 





 





 





 





153



   




5961




5





 





 




  
5
  




 





22



     use warnings; 




 




5





 





 





 





 





9



   




 




5





 





 





 





 





198



   




5962




5





 





 




  
5
  




 





25



     use Carp qw(confess); 




 




5





 





 





 





 





7



   




 




5





 





 





 





 





583



   




5963




 





 





 





 





 





 



   




5964




 





 





 





 





 





 



     sub obj($$) 




5965




 





 





 





 





 





 



     { 




5966




0





 





 




  
0
  




 





0



         my ($class, $stmt) = @_; 




5967




0





 





 





 





 





0



         return $stmt->do; 




5968




 





 





 





 





 





 



     } 




5969




 





 





 





 





 





 



 } 




5970




 





 





 





 





 





 



   




5971




 





 





 





 





 





 



 # Fetch: 




5972




 





 





 





 





 





 



 # This is a bit different, since the obj() method will actually execute the statement. 




5973




 





 





 





 





 





 



 { 




5974




 





 





 





 





 





 



     package SQL::Yapp::Fetch; 




5975




 





 





 





 





 





 



   




5976




5





 





 




  
5
  




 





22



     use strict; 




 




5





 





 





 





 





13



   




 




5





 





 





 





 





245



   




5977




5





 





 




  
5
  




 





25



     use warnings; 




 




5





 





 





 





 





17



   




 




5





 





 





 





 





423



   




5978




 





 





 





 





 





 



   




5979




 





 





 





 





 





 



     sub obj($$) 




5980




 





 





 





 





 





 



     { 




5981




0





 





 




  
0
  




 





0



         my ($class, $stmt) = @_; 




5982




0





 





 





 





 





0



         return $stmt->fetch; 




5983




 





 





 





 





 





 



     } 




5984




 





 





 





 





 





 



 } 




5985




 





 





 





 





 





 



   




5986




 





 





 





 





 





 



 # ColumnName: 




5987




 





 





 





 





 





 



 { 




5988




 





 





 





 





 





 



     package SQL::Yapp::ColumnName; 




5989




 





 





 





 





 





 



   




5990




5





 





 




  
5
  




 





22



     use strict; 




 




5





 





 





 





 





17



   




 




5





 





 





 





 





139



   




5991




5





 





 




  
5
  




 





23



     use warnings; 




 




5





 





 





 





 





8



   




 




5





 





 





 





 





140



   




5992




5





 





 




  
5
  




 





21



     use base qw(SQL::Yapp::Obj1); 




 




5





 





 





 





 





9



   




 




5





 





 





 





 





3036



   




5993




 





 





 





 





 





 



   




5994




0





 





 




  
0
  




 





0



     sub colname($) { return $_[0]; } 




5995




 





 





 





 





 





 



 } 




5996




 





 





 





 





 





 



   




5997




 





 





 





 





 





 



 # TableName: 




5998




 





 





 





 





 





 



 { 




5999




 





 





 





 





 





 



     package SQL::Yapp::TableName; 




6000




 





 





 





 





 





 



   




6001




5





 





 




  
5
  




 





31



     use strict; 




 




5





 





 





 





 





8



   




 




5





 





 





 





 





189



   




6002




5





 





 




  
5
  




 





37



     use warnings; 




 




5





 





 





 





 





21



   




 




5





 





 





 





 





166



   




6003




5





 





 




  
5
  




 





22



     use base qw(SQL::Yapp::Obj1); 




 




5





 





 





 





 





8



   




 




5





 





 





 





 





3999



   




6004




 





 





 





 





 





 



   




6005




0





 





 




  
0
  




 





0



     sub tabname($) { return $_[0]; } 




6006




 





 





 





 





 





 



 } 




6007




 





 





 





 





 





 



   




6008




 





 





 





 





 





 



 # Column: 




6009




 





 





 





 





 





 



 { 




6010




 





 





 





 





 





 



     package SQL::Yapp::Column; 




6011




 





 





 





 





 





 



   




6012




5





 





 




  
5
  




 





28



     use strict; 




 




5





 





 





 





 





9



   




 




5





 





 





 





 





163



   




6013




5





 





 




  
5
  




 





30



     use warnings; 




 




5





 





 





 





 





9



   




 




5





 





 





 





 





159



   




6014




5





 





 




  
5
  




 





25



     use base qw(SQL::Yapp::Obj1); 




 




5





 





 





 





 





7



   




 




5





 





 





 





 





4312



   




6015




 





 





 





 





 





 



   




6016




2





 





 




  
2
  




 





15



     sub column1($)       { return $_[0]; } 




6017




3





 





 




  
3
  




 





13



     sub exprparen($)     { return $_[0]; } 




6018




1





 





 




  
1
  




 





5



     sub expr($)          { return $_[0]; } 




6019




0





 





 




  
0
  




 





0



     sub expr_or_check($) { return $_[0]; } 




6020




2





 





 




  
2
  




 





9



     sub asc($)           { return $_[0]; } 




6021




5





 





 




  
5
  




 





18



     sub desc($)          { return SQL::Yapp::Desc->obj($_[0]); } 




6022




 





 





 





 





 





 



 } 




6023




 





 





 





 





 





 



   




6024




 





 





 





 





 





 



 # Table: 




6025




 





 





 





 





 





 



 { 




6026




 





 





 





 





 





 



     package SQL::Yapp::Table; 




6027




5





 





 




  
5
  




 





36



     use strict; 




 




5





 





 





 





 





21



   




 




5





 





 





 





 





172



   




6028




5





 





 




  
5
  




 





23



     use warnings; 




 




5





 





 





 





 





8



   




 




5





 





 





 





 





157



   




6029




5





 





 




  
5
  




 





24



     use base qw(SQL::Yapp::Obj1); 




 




5





 





 





 





 





7



   




 




5





 





 





 





 





2393



   




6030




5





 





 




  
5
  




 





18



     sub table1($) { return $_[0]; } 




6031




 





 





 





 





 





 



 } 




6032




 





 





 





 





 





 



   




6033




 





 





 





 





 





 



 # CharSet: 




6034




 





 





 





 





 





 



 { 




6035




 





 





 





 





 





 



     package SQL::Yapp::CharSet; 




6036




5





 





 




  
5
  




 





26



     use strict; 




 




5





 





 





 





 





14



   




 




5





 





 





 





 





217



   




6037




5





 





 




  
5
  




 





30



     use warnings; 




 




5





 





 





 





 





9



   




 




5





 





 





 





 





163



   




6038




5





 





 




  
5
  




 





189



     use base qw(SQL::Yapp::Obj1); 




 




5





 





 





 





 





10



   




 




5





 





 





 





 





6878



   




6039




0





 





 




  
0
  




 





0



     sub charset1($) { return $_[0]; } 




6040




 





 





 





 





 





 



 } 




6041




 





 





 





 





 





 



   




6042




 





 





 





 





 





 



 # Collate: 




6043




 





 





 





 





 





 



 { 




6044




 





 





 





 





 





 



     package SQL::Yapp::Collate; 




6045




5





 





 




  
5
  




 





29



     use strict; 




 




5





 





 





 





 





7



   




 




5





 





 





 





 





1319



   




6046




5





 





 




  
5
  




 





22



     use warnings; 




 




5





 





 





 





 





8



   




 




5





 





 





 





 





598



   




6047




5





 





 




  
5
  




 





31



     use base qw(SQL::Yapp::Obj1); 




 




5





 





 





 





 





6



   




 




5





 





 





 





 





2671



   




6048




0





 





 




  
0
  




 





0



     sub collate1($) { return $_[0]; } 




6049




 





 





 





 





 





 



 } 




6050




 





 





 





 





 





 



   




6051




 





 





 





 





 





 



 # Constraint: 




6052




 





 





 





 





 





 



 { 




6053




 





 





 





 





 





 



     package SQL::Yapp::Constraint; 




6054




5





 





 




  
5
  




 





69



     use strict; 




 




5





 





 





 





 





10



   




 




5





 





 





 





 





157



   




6055




5





 





 




  
5
  




 





29



     use warnings; 




 




5





 





 





 





 





19



   




 




5





 





 





 





 





154



   




6056




5





 





 




  
5
  




 





22



     use base qw(SQL::Yapp::Obj1); 




 




5





 





 





 





 





8



   




 




5





 





 





 





 





2480



   




6057




0





 





 




  
0
  




 





0



     sub constraint1($) { return $_[0]; } 




6058




 





 





 





 





 





 



 } 




6059




 





 





 





 





 





 



   




6060




 





 





 





 





 





 



 # Index: 




6061




 





 





 





 





 





 



 { 




6062




 





 





 





 





 





 



     package SQL::Yapp::Index; 




6063




5





 





 




  
5
  




 





29



     use strict; 




 




5





 





 





 





 





7



   




 




5





 





 





 





 





157



   




6064




5





 





 




  
5
  




 





23



     use warnings; 




 




5





 





 





 





 





7



   




 




5





 





 





 





 





159



   




6065




5





 





 




  
5
  




 





22



     use base qw(SQL::Yapp::Obj1); 




 




5





 





 





 





 





9



   




 




5





 





 





 





 





2585



   




6066




0





 





 




  
0
  




 





0



     sub index1($) { return $_[0]; } 




6067




 





 





 





 





 





 



 } 




6068




 





 





 





 





 





 



   




6069




 





 





 





 





 





 



 # Transliteration: 




6070




 





 





 





 





 





 



 { 




6071




 





 





 





 





 





 



     package SQL::Yapp::Transliteration; 




6072




5





 





 




  
5
  




 





27



     use strict; 




 




5





 





 





 





 





7



   




 




5





 





 





 





 





139



   




6073




5





 





 




  
5
  




 





29



     use warnings; 




 




5





 





 





 





 





8



   




 




5





 





 





 





 





145



   




6074




5





 





 




  
5
  




 





21



     use base qw(SQL::Yapp::Obj1); 




 




5





 





 





 





 





10



   




 




5





 





 





 





 





2573



   




6075




0





 





 




  
0
  




 





0



     sub transliteration($) { return $_[0]; } 




6076




 





 





 





 





 





 



 } 




6077




 





 





 





 





 





 



   




6078




 





 





 





 





 





 



 # Transcoding: 




6079




 





 





 





 





 





 



 { 




6080




 





 





 





 





 





 



     package SQL::Yapp::Transcoding; 




6081




5





 





 




  
5
  




 





28



     use strict; 




 




5





 





 





 





 





7



   




 




5





 





 





 





 





142



   




6082




5





 





 




  
5
  




 





36



     use warnings; 




 




5





 





 





 





 





8



   




 




5





 





 





 





 





174



   




6083




5





 





 




  
5
  




 





24



     use base qw(SQL::Yapp::Obj1); 




 




5





 





 





 





 





10



   




 




5





 





 





 





 





2643



   




6084




0





 





 




  
0
  




 





0



     sub transcoding($) { return $_[0]; } 




6085




 





 





 





 





 





 



 } 




6086




 





 





 





 





 





 



   




6087




 





 





 





 





 





 



 # TableOption: 




6088




 





 





 





 





 





 



 { 




6089




 





 





 





 





 





 



     package SQL::Yapp::TableOption; 




6090




5





 





 




  
5
  




 





46



     use strict; 




 




5





 





 





 





 





14



   




 




5





 





 





 





 





161



   




6091




5





 





 




  
5
  




 





24



     use warnings; 




 




5





 





 





 





 





9



   




 




5





 





 





 





 





151



   




6092




5





 





 




  
5
  




 





24



     use base qw(SQL::Yapp::Obj1); 




 




5





 





 





 





 





9



   




 




5





 





 





 





 





2451



   




6093




2





 





 




  
2
  




 





7



     sub tableopt($) { return $_[0]; } 




6094




 





 





 





 





 





 



 } 




6095




 





 





 





 





 





 



   




6096




 





 





 





 





 





 



 # Engine: 




6097




 





 





 





 





 





 



 { 




6098




 





 





 





 





 





 



     package SQL::Yapp::Engine; 




6099




5





 





 




  
5
  




 





28



     use strict; 




 




5





 





 





 





 





8



   




 




5





 





 





 





 





164



   




6100




5





 





 




  
5
  




 





24



     use warnings; 




 




5





 





 





 





 





16



   




 




5





 





 





 





 





147



   




6101




5





 





 




  
5
  




 





27



     use base qw(SQL::Yapp::Obj1); 




 




5





 





 





 





 





8



   




 




5





 





 





 





 





2403



   




6102




0





 





 




  
0
  




 





0



     sub engine1($) { return $_[0]; } 




6103




 





 





 





 





 





 



 } 




6104




 





 





 





 





 





 



   




6105




 





 





 





 





 





 



   




6106




 





 





 





 





 





 



 # Join: 




6107




 





 





 





 





 





 



 { 




6108




 





 





 





 





 





 



     package SQL::Yapp::Join; 




6109




 





 





 





 





 





 



   




6110




5





 





 




  
5
  




 





24



     use strict; 




 




5





 





 





 





 





7



   




 




5





 





 





 





 





143



   




6111




5





 





 




  
5
  




 





21



     use warnings; 




 




5





 





 





 





 





9



   




 




5





 





 





 





 





183



   




6112




5





 





 




  
5
  




 





21



     use base qw(SQL::Yapp::Obj1); 




 




5





 





 





 





 





8



   




 




5





 





 





 





 





2358



   




6113




 





 





 





 





 





 



   




6114




4





 





 




  
4
  




 





12



     sub joinclause($) { return $_[0]; } 




6115




 





 





 





 





 





 



 } 




6116




 





 





 





 





 





 



   




6117




 





 





 





 





 





 



 # Check: 




6118




 





 





 





 





 





 



 { 




6119




 





 





 





 





 





 



     package SQL::Yapp::Check; 




6120




 





 





 





 





 





 



   




6121




5





 





 




  
5
  




 





28



     use strict; 




 




5





 





 





 





 





14



   




 




5





 





 





 





 





134



   




6122




5





 





 




  
5
  




 





22



     use warnings; 




 




5





 





 





 





 





5



   




 




5





 





 





 





 





149



   




6123




5





 





 




  
5
  




 





22



     use base qw(SQL::Yapp::Obj1); 




 




5





 





 





 





 





9



   




 




5





 





 





 





 





2851



   




6124




 





 





 





 





 





 



   




6125




3





 





 




  
3
  




 





35



     sub check($)         { return $_[0]; } 




6126




3





 





 




  
3
  




 





12



     sub expr_or_check($) { return $_[0]; } 




6127




 





 





 





 





 





 



   




6128




 





 





 





 





 





 



     sub obj($$) 




6129




 





 





 





 





 





 



     { 




6130




18




  
100
  




 




  
18
  




 





79



         if (ref($_[1]) eq $_[0]) { 




 




 




  
100
  




 





 





 





 



   




6131




9





 





 





 





 





86



             return $_[1]; 




6132




 





 





 





 





 





 



         } 




6133




 





 





 





 





 





 



         elsif (ref($_[1])) { 




6134




7





 





 





 





 





26



             bless($_[1], $_[0]); 




6135




 





 





 





 





 





 



         } 




6136




 





 





 





 





 





 



         else { 




6137




2





 





 





 





 





12



             $_[0]->SUPER::obj($_[1]); 




6138




 





 





 





 





 





 



         } 




6139




 





 





 





 





 





 



     } 




6140




 





 





 





 





 





 



 } 




6141




 





 





 





 





 





 



   




6142




 





 





 





 





 





 



 # Expr: 




6143




 





 





 





 





 





 



 { 




6144




 





 





 





 





 





 



     package SQL::Yapp::Expr; 




6145




 





 





 





 





 





 



   




6146




5





 





 




  
5
  




 





23



     use strict; 




 




5





 





 





 





 





9



   




 




5





 





 





 





 





140



   




6147




5





 





 




  
5
  




 





21



     use warnings; 




 




5





 





 





 





 





9



   




 




5





 





 





 





 





158



   




6148




5





 





 




  
5
  




 





35



     use base qw(SQL::Yapp::Obj1); 




 




5





 





 





 





 





13



   




 




5





 





 





 





 





2876



   




6149




 





 





 





 





 





 



   




6150




0





 





 




  
0
  




 





0



     sub exprparen($)     { return '('.($_[0]->value).')'; } 




6151




18





 





 




  
18
  




 





82



     sub expr($)          { return $_[0]; } 




6152




0





 





 




  
0
  




 





0



     sub expr_or_check($) { return $_[0]; } 




6153




0





 





 




  
0
  




 





0



     sub asc($)           { return $_[0]; } 




6154




0





 





 




  
0
  




 





0



     sub desc($)          { return SQL::Yapp::Desc->obj($_[0]); } 




6155




 





 





 





 





 





 



 } 




6156




 





 





 





 





 





 



   




6157




 





 





 





 





 





 



 # Infix: 




6158




 





 





 





 





 





 



 { 




6159




 





 





 





 





 





 



     package SQL::Yapp::Infix; 




6160




 





 





 





 





 





 



   




6161




5





 





 




  
5
  




 





26



     use strict; 




 




5





 





 





 





 





15



   




 




5





 





 





 





 





138



   




6162




5





 





 




  
5
  




 





21



     use warnings; 




 




5





 





 





 





 





9



   




 




5





 





 





 





 





151



   




6163




5





 





 




  
5
  




 





20



     use base qw(SQL::Yapp::Expr); 




 




5





 





 





 





 





9



   




 




5





 





 





 





 





2336



   




6164




5





 





 




  
5
  




 





27



     use Carp qw(croak); 




 




5





 





 





 





 





25



   




 




5





 





 





 





 





1568



   




6165




 





 





 





 





 





 



   




6166




 





 





 





 





 





 



     sub obj($$$$) 




6167




 





 





 





 





 





 



     { 




6168




56





 





 




  
56
  




 





121



         my ($class, $op, $a1, $a2)= @_; 




6169




56





 





 





 





 





642



         return bless(["$a1 $op $a2", $op, $a1, $a2], $class); 




6170




 





 





 





 





 





 



     } 




6171




 





 





 





 





 





 



   




6172




14





 





 




  
14
  




 





49



     sub op($)     { return $_[0][1]; } 




6173




14





 





 




  
14
  




 





54



     sub arg1($)   { return $_[0][2]; } 




6174




14





 





 




  
14
  




 





37



     sub arg2($)   { return $_[0][3]; } 




6175




 





 





 





 





 





 



   




6176




 





 





 





 





 





 



     sub assign($) 




6177




 





 





 





 





 





 



     { 




6178




14





 





 




  
14
  




 





19



         my ($self)= @_; 




6179




14




  
 50
  




 





 





 





32



         if ($self->op() eq '=') { # we're not checking everything, just whether it's an assignment 




6180




14





 





 





 





 





44



             return $self; 




6181




 





 





 





 





 





 



         } 




6182




0





 





 





 





 





0



         croak "Assignment expected, but found top-level operator '".($self->op)."'."; 




6183




 





 





 





 





 





 



     } 




6184




 





 





 





 





 





 



 } 




6185




 





 





 





 





 





 



   




6186




 





 





 





 





 





 



 # Order: 




6187




 





 





 





 





 





 



 { 




6188




 





 





 





 





 





 



     package SQL::Yapp::Order; 




6189




 





 





 





 





 





 



   




6190




5





 





 




  
5
  




 





27



     use strict; 




 




5





 





 





 





 





11



   




 




5





 





 





 





 





145



   




6191




5





 





 




  
5
  




 





27



     use warnings; 




 




5





 





 





 





 





9



   




 




5





 





 





 





 





4739



   




6192




5





 





 




  
5
  




 





197



     use base qw(SQL::Yapp::Obj1); 




 




5





 





 





 





 





9



   




 




5





 





 





 





 





8907



   




6193




5





 





 




  
5
  




 





34



     use Scalar::Util qw(blessed); 




 




5





 





 





 





 





207



   




 




5





 





 





 





 





2241



   




6194




 





 





 





 





 





 



   




6195




 





 





 





 





 





 



     sub obj($$) 




6196




 





 





 





 





 





 



     { 




6197




7





 





 




  
7
  




 





37



         my ($class,$x)= @_; 




6198




7




  
 50
  



  
 33
  




 





 





85



         return $x 




6199




 





 





 





 





 





 



             if blessed($x) && $x->isa('SQL::Yapp::Obj'); 




6200




0





 





 





 





 





0



         return bless([$x], 'SQL::Yapp::Asc'); # not Order, but Asc. 




6201




 





 





 





 





 





 



     } 




6202




 





 





 





 





 





 



 } 




6203




 





 





 





 





 





 



   




6204




 





 





 





 





 





 



 # Asc: 




6205




 





 





 





 





 





 



 { 




6206




 





 





 





 





 





 



     package SQL::Yapp::Asc; 




6207




 





 





 





 





 





 



   




6208




5





 





 




  
5
  




 





37



     use strict; 




 




5





 





 





 





 





12



   




 




5





 





 





 





 





180



   




6209




5





 





 




  
5
  




 





24



     use warnings; 




 




5





 





 





 





 





7



   




 




5





 





 





 





 





161



   




6210




5





 





 




  
5
  




 





24



     use base qw(SQL::Yapp::Order); 




 




5





 





 





 





 





9



   




 




5





 





 





 





 





3190



   




6211




 





 





 





 





 





 



   




6212




0





 





 




  
0
  




 





0



     sub asc($)  { return $_[0]; } 




6213




0





 





 




  
0
  




 





0



     sub desc($) { return SQL::Yapp::Desc->obj($_[0]); } 




6214




 





 





 





 





 





 



 } 




6215




 





 





 





 





 





 



   




6216




 





 





 





 





 





 



 # Desc: 




6217




 





 





 





 





 





 



 { 




6218




 





 





 





 





 





 



     package SQL::Yapp::Desc; 




6219




 





 





 





 





 





 



   




6220




5





 





 




  
5
  




 





35



     use strict; 




 




5





 





 





 





 





10



   




 




5





 





 





 





 





153



   




6221




5





 





 




  
5
  




 





26



     use warnings; 




 




5





 





 





 





 





8



   




 




5





 





 





 





 





166



   




6222




5





 





 




  
5
  




 





24



     use base qw(SQL::Yapp::Order); 




 




5





 





 





 





 





9



   




 




5





 





 





 





 





3084



   




6223




 





 





 





 





 





 



   




6224




 





 





 





 





 





 



     sub obj($$) 




6225




 





 





 





 





 





 



     { 




6226




9





 





 




  
9
  




 





16



         my ($class, $orig)= @_; 




6227




9





 





 





 





 





25



         return bless(["$orig DESC",$orig],$class); 




6228




 





 





 





 





 





 



     } 




6229




 





 





 





 





 





 



   




6230




1





 





 




  
1
  




 





6



     sub orig($) { return $_[0][1]; } 




6231




 





 





 





 





 





 



   




6232




2





 





 




  
2
  




 





8



     sub asc($)  { return $_[0]; } 




6233




1





 





 




  
1
  




 





5



     sub desc($) { return &orig; } 




6234




 





 





 





 





 





 



 } 




6235




 





 





 





 





 





 



   




6236




 





 





 





 





 





 



 # Type: 




6237




 





 





 





 





 





 



 { 




6238




 





 





 





 





 





 



     package SQL::Yapp::Type; 




6239




 





 





 





 





 





 



   




6240




5





 





 




  
5
  




 





28



     use strict; 




 




5





 





 





 





 





10



   




 




5





 





 





 





 





151



   




6241




5





 





 




  
5
  




 





24



     use warnings; 




 




5





 





 





 





 





14



   




 




5





 





 





 





 





213



   




6242




5





 





 




  
5
  




 





25



     use base qw(SQL::Yapp::Obj); 




 




5





 





 





 





 





11



   




 




5





 





 





 





 





2442



   




6243




5





 





 




  
5
  




 





30



     use Hash::Util qw(lock_keys); 




 




5





 





 





 





 





11



   




 




5





 





 





 





 





64



   




6244




5





 





 




  
5
  




 





432



     use Carp qw(croak); 




 




5





 





 





 





 





12



   




 




5





 





 





 





 





4994



   




6245




 





 





 





 





 





 



   




6246




 





 





 





 





 





 



     sub set_base($$$) 




6247




 





 





 





 





 





 



     { 




6248




11





 





 




  
11
  




 





22



         my ($self, $base, $spec)= @_; 




6249




 





 





 





 





 





 



   




6250




 





 





 





 





 





 



         # set new spec: 




6251




11





 





 





 





 





23



         $self->{base}= $base; 




6252




11





 





 





 





 





26



         $self->{spec}= $spec; 




6253




 





 





 





 





 





 



   




6254




 





 





 





 





 





 



         # filter options by new spec: 




6255




11





 





 





 





 





21



         for my $o (keys %{ $self->{option} }) { 




 




11





 





 





 





 





46



   




6256




3




  
100
  




 





 





 





13



             unless ($spec->{$o}) { 




6257




1





 





 





 





 





4



                 delete $self->{option}{$o}; 




6258




 





 





 





 





 





 



             } 




6259




 





 





 





 





 





 



         } 




6260




 





 





 





 





 





 



   




6261




11





 





 





 





 





157



         return $self; 




6262




 





 





 





 





 





 



     } 




6263




 





 





 





 





 





 



   




6264




 





 





 





 





 





 



     sub set_property($$$) 




6265




 





 





 





 





 





 



     { 




6266




13





 





 




  
13
  




 





22



         my ($self, $key, $value)= @_; 




6267




13





 





 





 





 





296



         my %a= %$self; 




6268




13




  
 50
  




 





 





 





51



         croak "No $key for $self->{base} allowed." unless $self->{spec}{$key}; 




6269




13





 





 





 





 





31



         $self->{option}{$key}= $value; 




6270




13





 





 





 





 





30



         return $self; 




6271




 





 





 





 





 





 



     } 




6272




 





 





 





 





 





 



   




6273




 





 





 





 





 





 



     sub new($) 




6274




 





 





 





 





 





 



     { 




6275




9





 





 




  
9
  




 





3041



         my $r= bless({ base => undef, spec => undef, option => {} }, $_[0]); 




6276




9





 





 





 





 





245



         lock_keys %$r; 




6277




9





 





 





 





 





142



         return $r; 




6278




 





 





 





 





 





 



     } 




6279




 





 





 





 





 





 



   




6280




 





 





 





 





 





 



     sub obj($$) 




6281




 





 





 





 





 





 



     { 




6282




13





 





 




  
13
  




 





71



         return $_[1]; 




6283




 





 





 





 





 





 



     } 




6284




 





 





 





 





 





 



   




6285




 





 





 





 





 





 



     sub clone($) 




6286




 





 





 





 





 





 



     { 




6287




11





 





 




  
11
  




 





23



         my ($self)= @_; 




6288




11





 





 





 





 





93



         my $r= bless({ 




6289




 





 





 





 





 





 



                    %$self, 




6290




 





 





 





 





 





 



                    # no need to make a deep copy of 'spec', because it is never changed. 




6291




11





 





 





 





 





34



                    option => { %{ $self->{option} } }, 




6292




 





 





 





 





 





 



                }, __PACKAGE__); 




6293




11





 





 





 





 





46



         lock_keys %$r; 




6294




11





 





 





 





 





138



         return $r; 




6295




 





 





 





 





 





 



     } 




6296




 





 





 





 





 





 



   




6297




 





 





 





 





 





 



     sub type($) 




6298




 





 





 





 





 





 



     { 




6299




7





 





 




  
7
  




 





17



         return $_[0]->clone(); # make a copy before trying to modify this 




6300




 





 





 





 





 





 



     } 




6301




 





 





 





 





 





 



   




6302




 





 





 





 





 





 



     sub colspec($) 




6303




 





 





 





 





 





 



     { 




6304




1





 





 




  
1
  




 





11



         return SQL::Yapp::ColumnSpec->new($_[0]); # make a copy producing a ColumnSpec 




6305




 





 





 





 





 





 



     } 




6306




 





 





 





 





 





 



   




6307




 





 





 





 





 





 



     sub value($) 




6308




 





 





 





 





 





 



     { 




6309




38





 





 




  
38
  




 





68



         my ($self)= @_; 




6310




38




  
100
  




 





 





 





153



         return '' unless $self->{base}; 




6311




20





 





 





 





 





47



         my @r= ($self->{base}); 




6312




20




  
100
  



  
 66
  




 





 





220



         if ($self->{spec}{prec1} && defined $self->{option}{prec1}) { 




6313




19





 





 





 





 





27



             my $len_str= ''; 




6314




19





 





 





 





 





39



             $len_str.= $self->{option}{prec1}; 




6315




19




  
 50
  



  
 66
  




 





 





61



             if ($self->{spec}{prec2} && defined $self->{option}{prec2}) { 




6316




0





 





 





 





 





0



                 $len_str.= ', '.$self->{option}{prec2}; 




6317




 





 





 





 





 





 



             } 




6318




 





 





 





 





 





 



             else { 




6319




19




  
 50
  



  
 33
  




 





 





73



                 if ($self->{spec}{prec_mul} && $self->{option}{prec_mul}) { 




6320




0





 





 





 





 





0



                     $len_str.= ' '.$self->{option}{prec_mul}; 




6321




 





 





 





 





 





 



                 } 




6322




19




  
 50
  



  
 33
  




 





 





54



                 if ($self->{spec}{prec_unit} && $self->{option}{prec_unit}) { 




6323




0





 





 





 





 





0



                     $len_str.= ' '.$self->{option}{prec_unit}; 




6324




 





 





 





 





 





 



                 } 




6325




 





 





 





 





 





 



             } 




6326




19





 





 





 





 





45



             push @r, '('.$len_str.')'; 




6327




 





 





 





 





 





 



         } 




6328




20




  
 50
  



  
 33
  




 





 





86



         if (my $value_list= $self->{spec}{value_list} && $self->{option}{value_list}) { 




6329




0





 





 





 





 





0



             push @r, '('.join(', ',@$value_list).')'; 




6330




 





 





 





 





 





 



         } 




6331




20




  
100
  



  
100
  




 





 





101



         if (my $x= $self->{spec}{charset} && $self->{option}{charset}) { 




6332




3





 





 





 





 





56



             push @r, 'CHARACTER SET', $x; 




6333




 





 





 





 





 





 



         } 




6334




20




  
 50
  



  
 66
  




 





 





93



         if (my $x= $self->{spec}{collate} && $self->{option}{collate}) { 




6335




0





 





 





 





 





0



             push @r, 'COLLATE', $x; 




6336




 





 





 





 





 





 



         } 




6337




20





 





 





 





 





36



         for my $key ('sign', 'zerofill', 'timezone') { 




6338




60




  
 50
  



  
 66
  




 





 





230



             if (my $x= $self->{spec}{$key} && $self->{option}{$key}) { 




6339




0





 





 





 





 





0



                 push @r, $x; 




6340




 





 





 





 





 





 



             } 




6341




 





 





 





 





 





 



         } 




6342




 





 





 





 





 





 



   




6343




20





 





 





 





 





141



         return join(' ', @r); 




6344




 





 





 





 





 





 



     } 




6345




 





 





 





 





 





 



 } 




6346




 





 





 





 





 





 



   




6347




 





 





 





 





 





 



   




6348




 





 





 





 





 





 



 # ColumnSpec: 




6349




 





 





 





 





 





 



 { 




6350




 





 





 





 





 





 



     package SQL::Yapp::ColumnSpec; 




6351




 





 





 





 





 





 



   




6352




5





 





 




  
5
  




 





40



     use strict; 




 




5





 





 





 





 





23



   




 




5





 





 





 





 





208



   




6353




5





 





 




  
5
  




 





28



     use warnings; 




 




5





 





 





 





 





12



   




 




5





 





 





 





 





176



   




6354




5





 





 




  
5
  




 





26



     use base qw(SQL::Yapp::Obj); 




 




5





 





 





 





 





10



   




 




5





 





 





 





 





2645



   




6355




5





 





 




  
5
  




 





30



     use Hash::Util qw(lock_keys); 




 




5





 





 





 





 





10



   




 




5





 





 





 





 





25



   




6356




5





 





 




  
5
  




 





333



     use Carp qw(croak); 




 




5





 





 





 





 





9



   




 




5





 





 





 





 





61197



   




6357




 





 





 





 





 





 



   




6358




 





 





 





 





 





 



     sub new($$) 




6359




 





 





 





 





 





 



     { 




6360




3





 





 




  
3
  




 





18



         my ($class, $type)= @_; 




6361




3





 





 





 





 





13



         my $r= bless({ datatype => $type->clone(), name => {}, option => {} }, $class); 




6362




3





 





 





 





 





93



         lock_keys %$r; 




6363




3





 





 





 





 





178



         return $r; 




6364




 





 





 





 





 





 



     } 




6365




 





 





 





 





 





 



   




6366




 





 





 





 





 





 



     sub obj($$) 




6367




 





 





 





 





 





 



     { 




6368




3





 





 




  
3
  




 





29



         return $_[1]; 




6369




 





 





 





 





 





 



     } 




6370




 





 





 





 





 





 



   




6371




 





 





 





 





 





 



     sub clone($) 




6372




 





 





 





 





 





 



     { 




6373




1





 





 




  
1
  




 





3



         my ($self)= @_; 




6374




1





 





 





 





 





5



         my $r= bless({ 




6375




 





 





 





 





 





 



                    datatype => $self->{datatype}->clone(), 




6376




1





 





 





 





 





7



                    name   => { %{ $self->{name}   } }, 




6377




1





 





 





 





 





5



                    option => { %{ $self->{option} } }, 




6378




 





 





 





 





 





 



                }, __PACKAGE__); 




6379




1





 





 





 





 





36



         lock_keys %$r; 




6380




1





 





 





 





 





11



         return $r; 




6381




 





 





 





 





 





 



     } 




6382




 





 





 





 





 





 



   




6383




 





 





 





 





 





 



     sub colspec($) 




6384




 





 





 





 





 





 



     { 




6385




1





 





 




  
1
  




 





4



         return $_[0]->clone(); # make a copy before trying to modify this 




6386




 





 





 





 





 





 



     } 




6387




 





 





 





 





 





 



   




6388




 





 





 





 





 





 



     sub name($$) 




6389




 





 





 





 





 





 



     { 




6390




6





 





 




  
6
  




 





9



         my ($self, $key)= @_; 




6391




6




  
 50
  




 





 





 





19



         if (my $x= $self->{name}{$key}) { 




6392




0





 





 





 





 





0



             return ('CONSTRAINT', $x); 




6393




 





 





 





 





 





 



         } 




6394




6





 





 





 





 





18



         return; 




6395




 





 





 





 





 





 



     } 




6396




 





 





 





 





 





 



   




6397




 





 





 





 





 





 



     sub value($) 




6398




 





 





 





 





 





 



     { 




6399




4





 





 




  
4
  




 





9



         my ($self)= @_; 




6400




4





 





 





 





 





11



         my @r= ($self->{datatype}); 




6401




 





 





 





 





 





 



   




6402




4





 





 





 





 





10



         for my $key ('notnull', 'autoinc', 'unique', 'primary', 'key') { 




6403




20




  
100
  




 





 





 





58



             if (my $x= $self->{option}{$key}) { 




6404




4





 





 





 





 





13



                 push @r, $self->name($key), $x; 




6405




 





 





 





 





 





 



             } 




6406




 





 





 





 





 





 



         } 




6407




 





 





 





 





 





 



   




6408




4





 





 





 





 





6



         for my $key ('default', 'column_format', 'storage') { 




6409




12




  
100
  




 





 





 





34



             if (my $x= $self->{option}{$key}) { 




6410




2





 





 





 





 





8



                 push @r, $self->name($key), uc($key), $x; 




6411




 





 





 





 





 





 



             } 




6412




 





 





 





 





 





 



         } 




6413




 





 





 





 





 





 



   




6414




4





 





 





 





 





8



         for my $key ('check') { 




6415




4




  
 50
  




 





 





 





32



             if (my $x= $self->{option}{$key}) { 




6416




0





 





 





 





 





0



                 push @r, $self->name($key), uc($key), '('.$x.')'; 




6417




 





 





 





 





 





 



             } 




6418




 





 





 





 





 





 



         } 




6419




 





 





 





 





 





 



   




6420




4





 





 





 





 





6



         for my $key ('references') { 




6421




4




  
 50
  




 





 





 





16



             if (my $x= $self->{option}{$key}) { 




6422




0





 





 





 





 





0



                 push @r, $self->name($key), $x; 




6423




 





 





 





 





 





 



             } 




6424




 





 





 





 





 





 



         } 




6425




 





 





 





 





 





 



   




6426




4





 





 





 





 





11



         return join(' ', @r); 




6427




 





 





 





 





 





 



     } 




6428




 





 





 





 





 





 



 } 




6429




 





 





 





 





 





 



   




6430




 





 





 





 





 





 



   




6431




 





 





 





 





 





 



 # Special Constants: 




6432




2





 





 




  
2
  



  
0
  




515



 sub ASTERISK { SQL::Yapp::Asterisk->obj(); } 




6433




1





 





 




  
1
  



  
0
  




10



 sub QUESTION { SQL::Yapp::Question->obj(); } 




6434




0





 





 




  
0
  



  
0
  




0



 sub NULL     { SQL::Yapp::ExprSpecial->obj('NULL'); } 




6435




0





 





 




  
0
  



  
0
  




0



 sub TRUE     { SQL::Yapp::ExprSpecial->obj('TRUE'); } 




6436




0





 





 




  
0
  



  
0
  




0



 sub FALSE    { SQL::Yapp::ExprSpecial->obj('FALSE'); } 




6437




0





 





 




  
0
  



  
0
  




0



 sub UNKNOWN  { SQL::Yapp::ExprSpecial->obj('UNKNOWN'); } 




6438




0





 





 




  
0
  



  
0
  




0



 sub DEFAULT  { SQL::Yapp::ExprSpecial->obj('DEFAULT'); } 




6439




 





 





 





 





 





 



   




6440




 





 





 





 





 





 



   




6441




 





 





 





 





 





 



 # Wrapped DBI methods: 




6442




 





 





 





 





 





 



 sub croak_no_ref($) 




6443




 





 





 





 





 





 



 { 




6444




1





 





 




  
1
  



  
0
  




2



     my ($self)= @_; 




6445




1





 





 





 





 





4



     croak "Error: Wrong type argument from interpolated code:\n". 




6446




 





 





 





 





 





 



         "\tExpected scalar, but found ".my_dumper($self); 




6447




 





 





 





 





 





 



 } 




6448




 





 





 





 





 





 



   




6449




 





 





 





 





 





 



 ######################################## 




6450




 





 





 





 





 





 



 # Generators: 




6451




 





 





 





 





 





 



   




6452




 





 





 





 





 





 



 # These functions are used to typecheck interpolated Perl code's 




6453




 





 





 





 





 





 



 # result values and to generate objects on the fly if that's possible. 




6454




 





 





 





 





 





 



 # Usually on-the-fly generation coerces basic Perl types to a blessed 




6455




 





 





 





 





 





 



 # object, but it would also be feasible to coerce objects to objects. 




6456




 





 





 





 





 





 



 # Some 'generator' functions don't generate at all, but simply type 




6457




 





 





 





 





 





 



 # check. 




6458




 





 





 





 





 





 



 # 




6459




 





 





 





 





 





 



 # Note: often these functions are invoked in string context, which 




6460




 





 





 





 





 





 



 # means that directly after their invocation, the string cast operator 




6461




 





 





 





 





 





 



 # is invoked.  However, there's no easy way to prevent object creation 




6462




 





 





 





 





 





 



 # in that case, because there is no such thing as 'wantstring' 




6463




 





 





 





 





 





 



 # (would-be analog to 'wantarray').  So these functions must always 




6464




 





 





 





 





 





 



 # return a blessed reference. 




6465




 





 





 





 





 





 



   




6466




 





 





 





 





 





 



 sub _functor($$@) 




6467




 





 





 





 





 





 



 { 




6468




106





 





 




  
106
  




 





235



     my ($functor, $parens, @arg)= @_; 




6469




 





 





 





 





 





 



   




6470




 





 





 





 





 





 



     # possibly translate the functor to a different SQL dialect: 




6471




106




  
100
  




 





 





 





319



     if (my $dialect= $functor->{dialect}) { 




6472




97




  
100
  




 





 





 





230



         if (my $f2= find_ref(%$dialect, $write_dialect)) { 




6473




28





 





 





 





 





51



             $functor= $f2; 




6474




 





 





 





 





 





 



         } 




6475




 





 





 





 





 





 



     } 




6476




 





 





 





 





 





 



   




6477




 





 





 





 





 





 



     # print it: 




6478




106





 





 





 





 





226



     my $name= $functor->{value}; 




6479




 





 





 





 





 





 



   




6480




 





 





 





 





 





 



     # prefix and suffix are not handled here, because they behave 




6481




 





 





 





 





 





 



     # differently: they assume exactly one argument are applied 




6482




 





 





 





 





 





 



     # point-wise.  They cannot be switched (ok, we might switch 




6483




 





 





 





 





 





 



     # between prefix and suffix, but that's not supported yet). 




6484




 





 





 





 





 





 



     my $s= switch ($functor->{type}, 




6485




 





 





 





 





 





 



         'infix()' => sub { 




6486




52




  
 50
  




 




  
52
  




 





421



             (scalar(@arg) ? 




 




 




  
100
  




 





 





 





 



   




6487




 





 





 





 





 





 



                join(" $name ", @arg) 




6488




 





 





 





 





 





 



             : defined($functor->{result0}) ? 




6489




 





 





 





 





 





 



                get_quote_val->($functor->{result0}) 




6490




 





 





 





 





 





 



             :  die "Error: Functor $functor->{value} used with 0 args, but requires at least one." 




6491




 





 





 





 





 





 



             ); 




6492




 





 





 





 





 





 



         }, 




6493




 





 





 





 





 





 



         'funcall' => sub { 




6494




21





 





 




  
21
  




 





29



             $parens= 0; 




6495




21





 





 





 





 





77



             "$name(".join(", ", @arg).")"; 




6496




 





 





 





 





 





 



         }, 




6497




 





 





 





 





 





 



         'prefix' => sub { 




6498




26




  
100
  




 




  
26
  




 





66



             die "Error: Exactly one argument expected for operator $functor->{value},\n". 




6499




 





 





 





 





 





 



                 "\tfound (".join(",", @arg).")" 




6500




 





 





 





 





 





 



                 unless scalar(@arg) == 1; 




6501




25





 





 





 





 





79



             "$name $arg[0]" 




6502




 





 





 





 





 





 



         }, 




6503




 





 





 





 





 





 



         'suffix' => sub { 




6504




7




  
 50
  




 




  
7
  




 





21



             die "Error: exactly one argument expected, found @arg" unless scalar(@arg) == 1; 




6505




7





 





 





 





 





22



             "$arg[0] $name" 




6506




 





 





 





 





 





 



         }, 




6507




106





 





 





 





 





1066



     ); 




6508




105




  
100
  




 





 





 





1504



     return $parens ? "($s)" : $s; 




6509




 





 





 





 





 





 



 } 




6510




 





 





 





 





 





 



   




6511




 





 





 





 





 





 



 sub _prefix($$@) 




6512




 





 





 





 





 





 



 { 




6513




67





 





 




  
67
  




 





207



     my ($name, $parens)= splice @_,0,2; 




6514




67





 




  
100
  




 





 





345



     return _functor($functor_prefix{$name} || { value => $name, type => 'funcall' } , $parens, @_); 




6515




 





 





 





 





 





 



 } 




6516




 





 





 





 





 





 



   




6517




 





 





 





 





 





 



 sub _suffix($$@) 




6518




 





 





 





 





 





 



 { 




6519




39





 





 




  
39
  




 





542



     my ($name, $parens)= splice @_,0,2; 




6520




39





 





 





 





 





150



     return _functor($functor_suffix{$name}, $parens, @_); 




6521




 





 





 





 





 





 



 } 




6522




 





 





 





 





 





 



   




6523




 





 





 





 





 





 



 sub _max1_if_scalar(@) 




6524




 





 





 





 





 





 



 { 




6525




 





 





 





 





 





 



     # void context: 




6526




219




  
100
  




 




  
219
  




 





517



     unless (defined wantarray) { 




6527




1




  
 50
  




 





 





 





5



         return if scalar(@_) == 0; # allow void context with no params (e.g. after Do) 




6528




1





 





 





 





 





211



         croak 'Error: NYI: void context is currently not supported for SQL blocks.'; 




6529




 





 





 





 





 





 



     } 




6530




 





 





 





 





 





 



   




6531




 





 





 





 





 





 



     # list context: 




6532




218




  
100
  




 





 





 





512



     return @_ if wantarray; 




6533




 





 





 





 





 





 



   




6534




 





 





 





 





 





 



     # scalar context: 




6535




191




  
100
  




 





 





 





706



     croak 'Error: Multiple results cannot be assigned to scalar' 




6536




 





 





 





 





 





 



         if scalar(@_) > 1; 




6537




190





 





 





 





 





612



     return $_[0]; 




6538




 





 





 





 





 





 



 } 




6539




 





 





 





 





 





 



   




6540




 





 





 





 





 





 



 sub min1(@) 




6541




 





 





 





 





 





 



 { 




6542




0




  
  0
  




 




  
0
  



  
0
  




0



     croak 'Error: Expected at least one element, but found an empty list' 




6543




 





 





 





 





 





 



         if scalar(@_) == 0; 




6544




0





 





 





 





 





0



     return @_; 




6545




 





 





 





 





 





 



 } 




6546




 





 





 





 





 





 



   




6547




 





 





 





 





 





 



 sub min1default($@) 




6548




 





 





 





 





 





 



 { 




6549




0




  
  0
  




 




  
0
  



  
0
  




0



     return @_ if scalar(@_) == 1; 




6550




0





 





 





 





 





0



     shift; 




6551




0





 





 





 





 





0



     return @_; 




6552




 





 





 





 





 





 



 } 




6553




 





 





 





 





 





 



   




6554




 





 





 





 





 





 



 sub joinlist($$$$$@) 




6555




 





 





 





 





 





 



 { 




6556




213




  
100
  




 




  
213
  



  
0
  




500



     if (scalar(@_) == 5) { 




6557




1




  
 50
  




 





 





 





6



         return $_[1] if defined $_[1]; 




6558




0





 





 





 





 





0



         my ($module, $file, $line)= caller; 




6559




0





 





 





 





 





0



         croak "$file:$_[0]: Error: Expected at least one element, but found an empty list"; 




6560




 





 





 





 





 





 



     } 




6561




212





 





 





 





 





1329



     return $_[2].join ($_[3], @_[5..$#_]).$_[4]; 




6562




 





 





 





 





 





 



 } 




6563




 





 





 





 





 





 



   




6564




 





 





 





 





 





 



 sub assign($) # check that the result is an assignment, i.e.:`a` =  




6565




 





 





 





 





 





 



 { 




6566




14





 





 




  
14
  



  
0
  




22



     my ($x)= @_; 




6567




14




  
 50
  




 





 





 





35



     if (ref($x)) { 




6568




14





 





 





 





 





33



         return $x->assign(); 




6569




 





 





 





 





 





 



     } 




6570




 





 





 





 





 





 



     else { 




6571




0





 





 





 





 





0



         croak "Assignment expected, but found non-reference."; 




6572




 





 





 





 





 





 



     } 




6573




 





 





 





 





 





 



 } 




6574




 





 





 





 





 





 



   




6575




 





 





 





 





 





 



 sub set2values(@) 




6576




 





 





 





 





 





 



 { 




6577




7




  
 50
  




 




  
7
  



  
0
  




25



     croak "At least one value expected" if scalar(@_) == 0; 




6578




 





 





 





 





 





 



     return 




6579




14





 





 





 





 





27



         ' ('. 




6580




14





 





 





 





 





34



         join(',', map { assign($_)->arg1() } @_). 




6581




 





 





 





 





 





 



         ') VALUES ('. 




6582




7





 





 





 





 





14



         join(',', map { $_->arg2() } @_). 




6583




 





 





 





 





 





 



         ')'; 




6584




 





 





 





 





 





 



 } 




6585




 





 





 





 





 





 



   




6586




 





 





 





 





 





 



 sub exprlist($) 




6587




 





 





 





 





 





 



 { 




6588




7





 





 




  
7
  



  
0
  




24



     my ($x)= @_; 




6589




7




  
 50
  




 





 





 





26



     croak "Array reference expected for expression list" 




6590




 





 





 





 





 





 



        unless ref($x) eq 'ARRAY'; 




6591




7




  
 50
  




 





 





 





19



     croak "At least one element expected in expression list" 




6592




 





 





 





 





 





 



        unless scalar(@$x) >= 1; 




6593




7





 





 





 





 





12



     return '('.join(', ', map { expr($_) } @$x).')'; 




 




14





 





 





 





 





27



   




6594




 





 





 





 





 





 



 } 




6595




 





 





 





 





 





 



   




6596




 





 





 





 





 





 



 #################### 




6597




 





 





 





 





 





 



 # Type 




6598




 





 





 





 





 





 



   




6599




 





 





 





 





 





 



 sub type($) 




6600




 





 





 





 





 





 



 { 




6601




7





 





 




  
7
  



  
0
  




2882



     my ($x)= @_; 




6602




7




  
 50
  




 





 





 





144



     if (ref($x)) { 




6603




7





 





 





 





 





20



         return $x->type(); 




6604




 





 





 





 





 





 



     } 




6605




 





 





 





 





 





 



     else { 




6606




0





 





 





 





 





0



         croak "Type expected, but found non-reference (user types are not supported yet)."; 




6607




 





 





 





 





 





 



     } 




6608




 





 





 





 





 





 



 } 




6609




 





 





 





 





 





 



   




6610




 





 





 





 





 





 



 # These have $self at the end because it's easier to generate code like that. 




6611




 





 





 





 





 





 



 sub type_base($$) 




6612




 





 





 





 





 





 



 { 




6613




11





 





 




  
11
  



  
0
  




49



     my $self= pop @_; 




6614




11





 





 





 





 





738



     my ($base)= @_; 




6615




11




  
 50
  




 





 





 





39



     croak "Unrecognised base type '$base'" unless 




6616




 





 





 





 





 





 



         my $spec= find_ref(%type_spec, $base); 




6617




11




  
 50
  




 





 





 





41



     die unless $self; 




6618




11





 





 





 





 





41



     return $self->set_base($base, $spec); 




6619




 





 





 





 





 





 



 } 




6620




 





 





 





 





 





 



   




6621




 





 





 





 





 





 



 sub type_basewlist($@) 




6622




 





 





 





 





 





 



 { 




6623




0





 





 




  
0
  



  
0
  




0



     my $self= pop @_; 




6624




0





 





 





 





 





0



     my ($base, @value)= @_; 




6625




0




  
  0
  




 





 





 





0



     croak "Unrecognised base type '$base'" unless 




6626




 





 





 





 





 





 



         my $spec= find_ref(%type_spec, $base); 




6627




0




  
  0
  




 





 





 





0



     die unless $self; 




6628




0





 





 





 





 





0



     $self->set_base($base, $spec); 




6629




0





 





 





 





 





0



     $self->set_property('value_list', \@value); 




6630




0





 





 





 





 





0



     return $self; 




6631




 





 





 





 





 





 



 } 




6632




 





 





 





 





 





 



   




6633




 





 





 





 





 





 



 sub type_length($$;$) 




6634




 





 





 





 





 





 



 { 




6635




11





 





 




  
11
  



  
0
  




30



     my $self= pop @_; 




6636




11





 





 





 





 





17



     my ($prec1, $prec2)= @_; 




6637




11





 





 





 





 





34



     $self->set_property('prec1', $prec1); 




6638




11




  
 50
  




 





 





 





30



     $self->set_property('prec2', $prec2) if defined $prec2; 




6639




11





 





 





 





 





56



     return $self; 




6640




 





 





 





 





 





 



 } 




6641




 





 





 





 





 





 



   




6642




 





 





 





 





 





 



 sub type_largelength($$$;$) 




6643




 





 





 





 





 





 



 { 




6644




0





 





 




  
0
  



  
0
  




0



     my $self= pop @_; 




6645




0





 





 





 





 





0



     my ($coeff, $mul, $unit)= @_; 




6646




0





 





 





 





 





0



     $self->set_property('prec1',      $coeff); 




6647




0




  
  0
  




 





 





 





0



     $self->set_property('prec_mul',   $mul)  if defined $mul; 




6648




0




  
  0
  




 





 





 





0



     $self->set_property('prec_unit',  $unit) if defined $unit; 




6649




0





 





 





 





 





0



     return $self; 




6650




 





 





 





 





 





 



 } 




6651




 





 





 





 





 





 



   




6652




 





 





 





 





 





 



 sub type_property($$$) 




6653




 





 





 





 





 





 



 { 




6654




2





 





 




  
2
  



  
0
  




6



     my $self= pop @_; 




6655




2





 





 





 





 





5



     my ($key,$value)= @_; 




6656




2





 





 





 





 





8



     $self->set_property($key,$value); 




6657




2





 





 





 





 





8



     return $self; 




6658




 





 





 





 





 





 



 } 




6659




 





 





 





 





 





 



   




6660




 





 





 





 





 





 



 #################### 




6661




 





 





 





 





 





 



 # ColumnSpec 




6662




 





 





 





 





 





 



   




6663




 





 





 





 





 





 



 sub colspec($) 




6664




 





 





 





 





 





 



 { 




6665




2





 





 




  
2
  



  
0
  




532



     my ($x)= @_; 




6666




2




  
 50
  




 





 





 





9



     if (ref($x)) { 




6667




2





 





 





 





 





9



         return $x->colspec(); 




6668




 





 





 





 





 





 



     } 




6669




 





 





 





 





 





 



     else { 




6670




0





 





 





 





 





0



         croak "ColumnSpec expected, but found non-reference (user types are not supported yet)."; 




6671




 





 





 





 





 





 



     } 




6672




 





 





 





 





 





 



 } 




6673




 





 





 





 





 





 



   




6674




 





 





 





 





 





 



 sub colspec_property($$$$) 




6675




 





 





 





 





 





 



 { 




6676




4





 





 




  
4
  



  
0
  




20



     my $self= pop @_; 




6677




4





 





 





 





 





11



     my ($name, $key, $value)= @_; 




6678




4





 





 





 





 





15



     $self->{name}{$key}=   $name; 




6679




4





 





 





 





 





10



     $self->{option}{$key}= $value; 




6680




4





 





 





 





 





32



     return $self; 




6681




 





 





 





 





 





 



 } 




6682




 





 





 





 





 





 



   




6683




 





 





 





 





 





 



 sub colspec_type_base($$) 




6684




 





 





 





 





 





 



 { 




6685




0





 





 




  
0
  



  
0
  




0



     my $self= pop @_; 




6686




0





 





 





 





 





0



     my ($base)= @_; 




6687




0





 





 





 





 





0



     type_base($base, $self->{datatype}); 




6688




0





 





 





 





 





0



     return $self; 




6689




 





 





 





 





 





 



 } 




6690




 





 





 





 





 





 



   




6691




 





 





 





 





 





 



 sub colspec_type_property($$$) 




6692




 





 





 





 





 





 



 { 




6693




0





 





 




  
0
  



  
0
  




0



     my $self= pop @_; 




6694




0





 





 





 





 





0



     my ($key, $value)= @_; 




6695




0





 





 





 





 





0



     type_property($key, $value, $self->{datatype}); 




6696




0





 





 





 





 





0



     return $self; 




6697




 





 





 





 





 





 



 } 




6698




 





 





 





 





 





 



   




6699




 





 





 





 





 





 



 sub colspec_type_basewlist($@) 




6700




 





 





 





 





 





 



 { 




6701




0





 





 




  
0
  



  
0
  




0



     my $self= pop @_; 




6702




0





 





 





 





 





0



     my ($base, @value)= @_; 




6703




0





 





 





 





 





0



     type_basewlist($base, @value, $self->{datatype}); 




6704




0





 





 





 





 





0



     return $self; 




6705




 





 





 





 





 





 



 } 




6706




 





 





 





 





 





 



   




6707




 





 





 





 





 





 



 sub colspec_type_length($$;$) 




6708




 





 





 





 





 





 



 { 




6709




0





 





 




  
0
  



  
0
  




0



     my $self= pop @_; 




6710




0





 





 





 





 





0



     my ($prec1, $prec2)= @_; 




6711




0





 





 





 





 





0



     type_length($prec1, $prec2, $self->{datatype}); 




6712




0





 





 





 





 





0



     return $self; 




6713




 





 





 





 





 





 



 } 




6714




 





 





 





 





 





 



   




6715




 





 





 





 





 





 



 sub colspec_type_largelength($$$;$) 




6716




 





 





 





 





 





 



 { 




6717




0





 





 




  
0
  



  
0
  




0



     my $self= pop @_; 




6718




0





 





 





 





 





0



     my ($coeff, $mul, $unit)= @_; 




6719




0





 





 





 





 





0



     type_largelength($coeff, $mul, $unit, $self->{datatype}); 




6720




0





 





 





 





 





0



     return $self; 




6721




 





 





 





 





 





 



 } 




6722




 





 





 





 





 





 



   




6723




 





 





 





 





 





 



 #################### 




6724




 





 





 





 





 





 



 # identifier interpolation, column and table: 




6725




 





 





 





 





 





 



   




6726




 





 





 





 





 





 



 sub tabname($) 




6727




 





 





 





 





 





 



 { 




6728




1





 





 




  
1
  



  
0
  




4



     my ($x)= @_; 




6729




1




  
 50
  




 





 





 





8



     if (ref($x)) { 




 




 




  
 50
  




 





 





 





 



   




6730




0





 





 





 





 





0



         return $x->tabname; 




6731




 





 





 





 





 





 



     } 




6732




 





 





 





 





 





 



     elsif (defined $x) { 




6733




1





 





 





 





 





3



         return SQL::Yapp::TableName->obj(get_quote_id->($xlat_table->($x))); 




6734




 





 





 





 





 





 



     } 




6735




 





 





 





 





 





 



     else { 




6736




0





 





 





 





 





0



         croak "Error: Cannot use undef/NULL as a table name"; 




6737




 





 





 





 





 





 



     } 




6738




 





 





 





 





 





 



 } 




6739




 





 





 





 





 





 



   




6740




 





 





 





 





 





 



 # Schema-qualified names: 




6741




 





 





 





 





 





 



 sub schemaname1($$$) 




6742




 





 





 





 





 





 



 { 




6743




122





 





 




  
122
  



  
0
  




214



     my ($class,$xlat,$x)= @_; 




6744




122




  
 50
  




 





 





 





255



     if (defined $x) { 




6745




122





 





 





 





 





299



         return $class->obj(get_quote_id->($xlat->($x))); 




6746




 





 





 





 





 





 



     } 




6747




 





 





 





 





 





 



     else { 




6748




0





 





 





 





 





0



         croak "Error: Cannot use undef/NULL as a table name"; 




6749




 





 





 





 





 





 



     } 




6750




 





 





 





 





 





 



 } 




6751




 





 





 





 





 





 



   




6752




 





 





 





 





 





 



 sub schemaname2($$$$) 




6753




 





 





 





 





 





 



 { 




6754




2





 





 




  
2
  



  
0
  




10



     my ($class,$xlat,$x,$y)= @_; 




6755




 





 





 





 





 





 



   




6756




2




  
100
  




 





 





 





11



     if (ref($x)) { croak_no_ref($x); } 




 




1





 





 





 





 





5



   




6757




1




  
 50
  




 





 





 





4



     if (ref($y)) { croak_no_ref($y); } 




 




0





 





 





 





 





0



   




6758




1




  
 50
  




 





 





 





5



     croak "Error: Cannot use undef/NULL as an identifier" 




6759




 





 





 





 





 





 



         unless defined $y; 




6760




 





 





 





 





 





 



   




6761




1




  
 50
  




 





 





 





10



     return $class->obj( 




6762




 





 





 





 





 





 



                get_quote_id->( 




6763




 





 





 





 





 





 



                    undef, 




6764




 





 





 





 





 





 



                    (defined $x ? $xlat_schema->($x) : undef), 




6765




 





 





 





 





 





 



                    $xlat->($y))); 




6766




 





 





 





 





 





 



 } 




6767




 





 





 





 





 





 



   




6768




 





 





 





 





 





 



 sub schemaname3($$$$$) 




6769




 





 





 





 





 





 



 { 




6770




3





 





 




  
3
  



  
0
  




7



     my ($class,$xlat,$x,$y,$z)= @_; 




6771




3




  
 50
  




 





 





 





10



     if (ref($x)) { croak_no_ref($x); } 




 




0





 





 





 





 





0



   




6772




3




  
 50
  




 





 





 





8



     if (ref($y)) { croak_no_ref($y); } 




 




0





 





 





 





 





0



   




6773




3




  
 50
  




 





 





 





9



     if (ref($z)) { croak_no_ref($z); } 




 




0





 





 





 





 





0



   




6774




3




  
 50
  




 





 





 





10



     croak "Error: Cannot use undef/NULL as an identifier" 




6775




 





 





 





 





 





 



         unless defined $z; 




6776




 





 





 





 





 





 



   




6777




3




  
 50
  




 





 





 





15



     return $class->obj( 




 




 




  
 50
  




 





 





 





 



   




6778




 





 





 





 





 





 



                get_quote_id->( 




6779




 





 





 





 





 





 



                    (defined $x ? $xlat_catalog->($x) : undef), 




6780




 





 





 





 





 





 



                    (defined $y ? $xlat_schema->($y)  : undef), 




6781




 





 





 





 





 





 



                    $xlat->($z))); 




6782




 





 





 





 





 





 



 } 




6783




 





 





 





 





 





 



   




6784




 





 





 





 





 





 



   




6785




 





 





 





 





 





 



 # Table: 




6786




 





 





 





 





 





 



 sub table1($) 




6787




 





 





 





 





 





 



 { 




6788




124





 





 




  
124
  



  
0
  




6698



     my ($x)= @_; 




6789




124




  
100
  




 





 





 





455



     return ref($x) ? $x->table1 : schemaname1('SQL::Yapp::Table', $xlat_table, $x); 




6790




 





 





 





 





 





 



 } 




6791




 





 





 





 





 





 



   




6792




 





 





 





 





 





 



 sub table2($$) 




6793




 





 





 





 





 





 



 { 




6794




2





 





 




  
2
  



  
0
  




946



     my ($x,$y)= @_; 




6795




2





 





 





 





 





11



     return schemaname2('SQL::Yapp::Table', $xlat_table, $x, $y); 




6796




 





 





 





 





 





 



 } 




6797




 





 





 





 





 





 



   




6798




 





 





 





 





 





 



 sub table3($$$) 




6799




 





 





 





 





 





 



 { 




6800




3





 





 




  
3
  



  
0
  




530



     my ($x,$y,$z)= @_; 




6801




3





 





 





 





 





11



     return schemaname3('SQL::Yapp::Table', $xlat_table, $x, $y, $z); 




6802




 





 





 





 





 





 



 } 




6803




 





 





 





 





 





 



   




6804




 





 





 





 





 





 



   




6805




 





 





 





 





 





 



 # Index: 




6806




 





 





 





 





 





 



 sub index1($) 




6807




 





 





 





 





 





 



 { 




6808




0





 





 




  
0
  



  
0
  




0



     my ($x)= @_; 




6809




0




  
  0
  




 





 





 





0



     return ref($x) ? $x->index1 : schemaname1('SQL::Yapp::Index', $xlat_index, $x); 




6810




 





 





 





 





 





 



 } 




6811




 





 





 





 





 





 



   




6812




 





 





 





 





 





 



 sub index2($$) 




6813




 





 





 





 





 





 



 { 




6814




0





 





 




  
0
  



  
0
  




0



     my ($x,$y)= @_; 




6815




0





 





 





 





 





0



     return schemaname2('SQL::Yapp::Index', $xlat_index, $x, $y); 




6816




 





 





 





 





 





 



 } 




6817




 





 





 





 





 





 



   




6818




 





 





 





 





 





 



 sub index3($$$) 




6819




 





 





 





 





 





 



 { 




6820




0





 





 




  
0
  



  
0
  




0



     my ($x,$y,$z)= @_; 




6821




0





 





 





 





 





0



     return schemaname3('SQL::Yapp::Index', $xlat_index, $x, $y, $z); 




6822




 





 





 





 





 





 



 } 




6823




 





 





 





 





 





 



   




6824




 





 





 





 





 





 



   




6825




 





 





 





 





 





 



 # CharSet: 




6826




 





 





 





 





 





 



 sub charset1($) 




6827




 





 





 





 





 





 



 { 




6828




2





 





 




  
2
  



  
0
  




7



     my ($x)= @_; 




6829




2




  
 50
  




 





 





 





127



     return ref($x) ? $x->charset1 : schemaname1('SQL::Yapp::CharSet', $xlat_charset, $x); 




6830




 





 





 





 





 





 



 } 




6831




 





 





 





 





 





 



   




6832




 





 





 





 





 





 



 sub charset2($$) 




6833




 





 





 





 





 





 



 { 




6834




0





 





 




  
0
  



  
0
  




0



     my ($x,$y)= @_; 




6835




0





 





 





 





 





0



     return schemaname2('SQL::Yapp::CharSet', $xlat_charset, $x, $y); 




6836




 





 





 





 





 





 



 } 




6837




 





 





 





 





 





 



   




6838




 





 





 





 





 





 



 sub charset3($$$) 




6839




 





 





 





 





 





 



 { 




6840




0





 





 




  
0
  



  
0
  




0



     my ($x,$y,$z)= @_; 




6841




0





 





 





 





 





0



     return schemaname3('SQL::Yapp::CharSet', $xlat_charset, $x, $y, $z); 




6842




 





 





 





 





 





 



 } 




6843




 





 





 





 





 





 



   




6844




 





 





 





 





 





 



   




6845




 





 





 





 





 





 



 # Collate: 




6846




 





 





 





 





 





 



 sub collate1($) 




6847




 





 





 





 





 





 



 { 




6848




0





 





 




  
0
  



  
0
  




0



     my ($x)= @_; 




6849




0




  
  0
  




 





 





 





0



     return ref($x) ? $x->collate1 : schemaname1('SQL::Yapp::Collate', $xlat_collate, $x); 




6850




 





 





 





 





 





 



 } 




6851




 





 





 





 





 





 



   




6852




 





 





 





 





 





 



 sub collate2($$) 




6853




 





 





 





 





 





 



 { 




6854




0





 





 




  
0
  



  
0
  




0



     my ($x,$y)= @_; 




6855




0





 





 





 





 





0



     return schemaname2('SQL::Yapp::Collate', $xlat_collate, $x, $y); 




6856




 





 





 





 





 





 



 } 




6857




 





 





 





 





 





 



   




6858




 





 





 





 





 





 



 sub collate3($$$) 




6859




 





 





 





 





 





 



 { 




6860




0





 





 




  
0
  



  
0
  




0



     my ($x,$y,$z)= @_; 




6861




0





 





 





 





 





0



     return schemaname3('SQL::Yapp::Collate', $xlat_collate, $x, $y, $z); 




6862




 





 





 





 





 





 



 } 




6863




 





 





 





 





 





 



   




6864




 





 





 





 





 





 



   




6865




 





 





 





 





 





 



 # Constraint: 




6866




 





 





 





 





 





 



 sub constraint1($) 




6867




 





 





 





 





 





 



 { 




6868




0





 





 




  
0
  



  
0
  




0



     my ($x)= @_; 




6869




0




  
  0
  




 





 





 





0



     return ref($x) ? $x->constraint1 : schemaname1('SQL::Yapp::Constraint', $xlat_constraint, $x); 




6870




 





 





 





 





 





 



 } 




6871




 





 





 





 





 





 



   




6872




 





 





 





 





 





 



 sub constraint2($$) 




6873




 





 





 





 





 





 



 { 




6874




0





 





 




  
0
  



  
0
  




0



     my ($x,$y)= @_; 




6875




0





 





 





 





 





0



     return schemaname2('SQL::Yapp::Constraint', $xlat_constraint, $x, $y); 




6876




 





 





 





 





 





 



 } 




6877




 





 





 





 





 





 



   




6878




 





 





 





 





 





 



 sub constraint3($$$) 




6879




 





 





 





 





 





 



 { 




6880




0





 





 




  
0
  



  
0
  




0



     my ($x,$y,$z)= @_; 




6881




0





 





 





 





 





0



     return schemaname3('SQL::Yapp::Constraint', $xlat_constraint, $x, $y, $z); 




6882




 





 





 





 





 





 



 } 




6883




 





 





 





 





 





 



   




6884




 





 





 





 





 





 



   




6885




 





 





 





 





 





 



 # Transliteration: 




6886




 





 





 





 





 





 



 sub transliteration1($) 




6887




 





 





 





 





 





 



 { 




6888




0





 





 




  
0
  



  
0
  




0



     my ($x)= @_; 




6889




0




  
  0
  




 





 





 





0



     return ref($x) ? $x->transliteration1 : schemaname1('SQL::Yapp::Transliteration', $xlat_transliteration, $x); 




6890




 





 





 





 





 





 



 } 




6891




 





 





 





 





 





 



   




6892




 





 





 





 





 





 



 sub transliteration2($$) 




6893




 





 





 





 





 





 



 { 




6894




0





 





 




  
0
  



  
0
  




0



     my ($x,$y)= @_; 




6895




0





 





 





 





 





0



     return schemaname2('SQL::Yapp::Transliteration', $xlat_transliteration, $x, $y); 




6896




 





 





 





 





 





 



 } 




6897




 





 





 





 





 





 



   




6898




 





 





 





 





 





 



 sub transliteration3($$$) 




6899




 





 





 





 





 





 



 { 




6900




0





 





 




  
0
  



  
0
  




0



     my ($x,$y,$z)= @_; 




6901




0





 





 





 





 





0



     return schemaname3('SQL::Yapp::Transliteration', $xlat_transliteration, $x, $y, $z); 




6902




 





 





 





 





 





 



 } 




6903




 





 





 





 





 





 



   




6904




 





 





 





 





 





 



   




6905




 





 





 





 





 





 



 # Transcoding: 




6906




 





 





 





 





 





 



 sub transcoding1($) 




6907




 





 





 





 





 





 



 { 




6908




0





 





 




  
0
  



  
0
  




0



     my ($x)= @_; 




6909




0




  
  0
  




 





 





 





0



     return ref($x) ? $x->transcoding1 : schemaname1('SQL::Yapp::Transcoding', $xlat_transcoding, $x); 




6910




 





 





 





 





 





 



 } 




6911




 





 





 





 





 





 



   




6912




 





 





 





 





 





 



 sub transcoding2($$) 




6913




 





 





 





 





 





 



 { 




6914




0





 





 




  
0
  



  
0
  




0



     my ($x,$y)= @_; 




6915




0





 





 





 





 





0



     return schemaname2('SQL::Yapp::Transcoding', $xlat_transcoding, $x, $y); 




6916




 





 





 





 





 





 



 } 




6917




 





 





 





 





 





 



   




6918




 





 





 





 





 





 



 sub transcoding3($$$) 




6919




 





 





 





 





 





 



 { 




6920




0





 





 




  
0
  



  
0
  




0



     my ($x,$y,$z)= @_; 




6921




0





 





 





 





 





0



     return schemaname3('SQL::Yapp::Transcoding', $xlat_transcoding, $x, $y, $z); 




6922




 





 





 





 





 





 



 } 




6923




 





 





 





 





 





 



   




6924




 





 





 





 





 





 



   




6925




 





 





 





 





 





 



 # Engine: 




6926




 





 





 





 





 





 



 sub engine1($) 




6927




 





 





 





 





 





 



 { 




6928




1





 





 




  
1
  



  
0
  




468



     my ($x)= @_; 




6929




1




  
 50
  




 





 





 





7



     return ref($x) ? $x->engine1 : schemaname1('SQL::Yapp::Engine', $xlat_engine, $x); 




6930




 





 





 





 





 





 



 } 




6931




 





 





 





 





 





 



   




6932




 





 





 





 





 





 



 sub engine2($$) 




6933




 





 





 





 





 





 



 { 




6934




0





 





 




  
0
  



  
0
  




0



     my ($x,$y)= @_; 




6935




0





 





 





 





 





0



     return schemaname2('SQL::Yapp::Engine', $xlat_engine, $x, $y); 




6936




 





 





 





 





 





 



 } 




6937




 





 





 





 





 





 



   




6938




 





 





 





 





 





 



 sub engine3($$$) 




6939




 





 





 





 





 





 



 { 




6940




0





 





 




  
0
  



  
0
  




0



     my ($x,$y,$z)= @_; 




6941




0





 





 





 





 





0



     return schemaname3('SQL::Yapp::Engine', $xlat_engine, $x, $y, $z); 




6942




 





 





 





 





 





 



 } 




6943




 





 





 





 





 





 



   




6944




 





 





 





 





 





 



   




6945




 





 





 





 





 





 



 # Columns: 




6946




 





 





 





 





 





 



 sub colname($) 




6947




 





 





 





 





 





 



 { 




6948




10





 





 




  
10
  



  
0
  




29



     my ($x)= @_; 




6949




10




  
 50
  




 





 





 





44



     if (ref($x)) { 




 




 




  
 50
  




 





 





 





 



   




6950




0





 





 





 





 





0



         return $x->colname; 




6951




 





 





 





 





 





 



     } 




6952




 





 





 





 





 





 



     elsif (defined $x) { 




6953




10





 





 





 





 





31



         return SQL::Yapp::ColumnName->obj(get_quote_id->($xlat_column->($x))); 




6954




 





 





 





 





 





 



     } 




6955




 





 





 





 





 





 



     else { 




6956




0





 





 





 





 





0



         croak "Error: Cannot use undef/NULL as a column name"; 




6957




 





 





 





 





 





 



     } 




6958




 





 





 





 





 





 



 } 




6959




 





 





 





 





 





 



   




6960




 





 





 





 





 





 



 sub column1($) 




6961




 





 





 





 





 





 



 { 




6962




209





 





 




  
209
  



  
0
  




33960



     my ($x)= @_; 




6963




209




  
100
  




 





 





 





737



     if (ref($x)) { 




 




 




  
 50
  




 





 





 





 



   




6964




4





 





 





 





 





17



         return $x->column1; 




6965




 





 





 





 





 





 



     } 




6966




 





 





 





 





 





 



     elsif (defined $x) { 




6967




205





 





 





 





 





478



         return SQL::Yapp::Column->obj(get_quote_id->($xlat_column->($x))); 




6968




 





 





 





 





 





 



     } 




6969




 





 





 





 





 





 



     else { 




6970




0





 





 





 





 





0



         croak "Error: Cannot use undef/NULL as an identifier"; 




6971




 





 





 





 





 





 



     } 




6972




 





 





 





 





 





 



 } 




6973




 





 





 





 





 





 



   




6974




 





 





 





 





 





 



 sub column1_single($) #internal 




6975




 





 





 





 





 





 



 { 




6976




25





 





 




  
25
  



  
0
  




35



     my ($x)= @_; 




6977




25




  
100
  




 





 





 





118



     if (ref($x)) { 




 




 




  
 50
  




 





 





 





 



   




6978




1





 





 





 





 





12



         return $x->column1_single; 




6979




 





 





 





 





 





 



     } 




6980




 





 





 





 





 





 



     elsif (defined $x) { 




6981




24





 





 





 





 





50



         return get_quote_id->($xlat_column->($x)); 




6982




 





 





 





 





 





 



     } 




6983




 





 





 





 





 





 



     else { 




6984




0





 





 





 





 





0



         croak "Error: Cannot use undef/NULL as an identifier"; 




6985




 





 





 





 





 





 



     } 




6986




 





 





 





 





 





 



 } 




6987




 





 





 





 





 





 



   




6988




 





 





 





 





 





 



 sub column2($$) 




6989




 





 





 





 





 





 



 { 




6990




25





 





 




  
25
  



  
0
  




3003



     my ($x,$y)= @_; 




6991




25





 





 





 





 





58



     return SQL::Yapp::Column->obj(table1($x).'.'.column1_single($y)); 




6992




 





 





 





 





 





 



 } 




6993




 





 





 





 





 





 



   




6994




 





 





 





 





 





 



 sub column3($$$) 




6995




 





 





 





 





 





 



 { 




6996




0





 





 




  
0
  



  
0
  




0



     my ($x,$y,$z)= @_; 




6997




0





 





 





 





 





0



     return SQL::Yapp::Column->obj(table2($x,$y).'.'.column1_single($z)); 




6998




 





 





 





 





 





 



 } 




6999




 





 





 





 





 





 



   




7000




 





 





 





 





 





 



 sub column4($$$$) 




7001




 





 





 





 





 





 



 { 




7002




0





 





 




  
0
  



  
0
  




0



     my ($w,$x,$y,$z)= @_; 




7003




0





 





 





 





 





0



     return SQL::Yapp::Column->obj(table3($w,$x,$y).'.'.column1_single($z)); 




7004




 





 





 





 





 





 



 } 




7005




 





 





 





 





 





 



   




7006




 





 





 





 





 





 



 # Generated with mkidentn.pl: 




7007




0





 





 




  
0
  



  
0
  




0



 sub table1_n($)         { map { table1        ($_   )                       } @{ $_[0] }  } 




 




0





 





 





 





 





0



   




 




0





 





 





 





 





0



   




7008




0





 





 




  
0
  



  
0
  




0



 sub table2_1n($$)       { map { table2        ($_[0], $_   )                } @{ $_[1] }  } 




 




0





 





 





 





 





0



   




 




0





 





 





 





 





0



   




7009




0





 





 




  
0
  



  
0
  




0



 sub table2_n1($$)       { map { table2        ($_   , $_[1])                } @{ $_[0] }  } 




 




0





 





 





 





 





0



   




 




0





 





 





 





 





0



   




7010




0





 





 




  
0
  



  
0
  




0



 sub table2_nn($$)       { map { table2_1n     ($_   , $_[1])                } @{ $_[0] }  } 




 




0





 





 





 





 





0



   




 




0





 





 





 





 





0



   




7011




0





 





 




  
0
  



  
0
  




0



 sub table3_11n($$$)     { map { table3        ($_[0], $_[1], $_   )         } @{ $_[2] }  } 




 




0





 





 





 





 





0



   




 




0





 





 





 





 





0



   




7012




0





 





 




  
0
  



  
0
  




0



 sub table3_1n1($$$)     { map { table3        ($_[0], $_   , $_[2])         } @{ $_[1] }  } 




 




0





 





 





 





 





0



   




 




0





 





 





 





 





0



   




7013




0





 





 




  
0
  



  
0
  




0



 sub table3_1nn($$$)     { map { table3_11n    ($_[0], $_   , $_[2])         } @{ $_[1] }  } 




 




0





 





 





 





 





0



   




 




0





 





 





 





 





0



   




7014




0





 





 




  
0
  



  
0
  




0



 sub table3_n11($$$)     { map { table3        ($_   , $_[1], $_[2])         } @{ $_[0] }  } 




 




0





 





 





 





 





0



   




 




0





 





 





 





 





0



   




7015




0





 





 




  
0
  



  
0
  




0



 sub table3_n1n($$$)     { map { table3_11n    ($_   , $_[1], $_[2])         } @{ $_[0] }  } 




 




0





 





 





 





 





0



   




 




0





 





 





 





 





0



   




7016




0





 





 




  
0
  



  
0
  




0



 sub table3_nn1($$$)     { map { table3_1n1    ($_   , $_[1], $_[2])         } @{ $_[0] }  } 




 




0





 





 





 





 





0



   




 




0





 





 





 





 





0



   




7017




0





 





 




  
0
  



  
0
  




0



 sub table3_nnn($$$)     { map { table3_1nn    ($_   , $_[1], $_[2])         } @{ $_[0] }  } 




 




0





 





 





 





 





0



   




 




0





 





 





 





 





0



   




7018




 





 





 





 





 





 



   




7019




0





 





 




  
0
  



  
0
  




0



 sub column1_n($)        { map { column1       ($_   )                       } @{ $_[0] }  } 




 




0





 





 





 





 





0



   




 




0





 





 





 





 





0



   




7020




4





 





 




  
4
  



  
0
  




9



 sub column2_1n($$)      { map { column2       ($_[0], $_   )                } @{ $_[1] }  } 




 




8





 





 





 





 





19



   




 




4





 





 





 





 





8



   




7021




0





 





 




  
0
  



  
0
  




0



 sub column2_n1($$)      { map { column2       ($_   , $_[1])                } @{ $_[0] }  } 




 




0





 





 





 





 





0



   




 




0





 





 





 





 





0



   




7022




2





 





 




  
2
  



  
0
  




964



 sub column2_nn($$)      { map { column2_1n    ($_   , $_[1])                } @{ $_[0] }  } 




 




4





 





 





 





 





11



   




 




2





 





 





 





 





8



   




7023




0





 





 




  
0
  



  
0
  




0



 sub column3_11n($$$)    { map { column3       ($_[0], $_[1], $_   )         } @{ $_[2] }  } 




 




0





 





 





 





 





0



   




 




0





 





 





 





 





0



   




7024




0





 





 




  
0
  



  
0
  




0



 sub column3_1n1($$$)    { map { column3       ($_[0], $_   , $_[2])         } @{ $_[1] }  } 




 




0





 





 





 





 





0



   




 




0





 





 





 





 





0



   




7025




0





 





 




  
0
  



  
0
  




0



 sub column3_1nn($$$)    { map { column3_11n   ($_[0], $_   , $_[2])         } @{ $_[1] }  } 




 




0





 





 





 





 





0



   




 




0





 





 





 





 





0



   




7026




0





 





 




  
0
  



  
0
  




0



 sub column3_n11($$$)    { map { column3       ($_   , $_[1], $_[2])         } @{ $_[0] }  } 




 




0





 





 





 





 





0



   




 




0





 





 





 





 





0



   




7027




0





 





 




  
0
  



  
0
  




0



 sub column3_n1n($$$)    { map { column3_11n   ($_   , $_[1], $_[2])         } @{ $_[0] }  } 




 




0





 





 





 





 





0



   




 




0





 





 





 





 





0



   




7028




0





 





 




  
0
  



  
0
  




0



 sub column3_nn1($$$)    { map { column3_1n1   ($_   , $_[1], $_[2])         } @{ $_[0] }  } 




 




0





 





 





 





 





0



   




 




0





 





 





 





 





0



   




7029




0





 





 




  
0
  



  
0
  




0



 sub column3_nnn($$$)    { map { column3_1nn   ($_   , $_[1], $_[2])         } @{ $_[0] }  } 




 




0





 





 





 





 





0



   




 




0





 





 





 





 





0



   




7030




0





 





 




  
0
  



  
0
  




0



 sub column4_111n($$$$)  { map { column4       ($_[0], $_[1], $_[2], $_   )  } @{ $_[3] }  } 




 




0





 





 





 





 





0



   




 




0





 





 





 





 





0



   




7031




0





 





 




  
0
  



  
0
  




0



 sub column4_11n1($$$$)  { map { column4       ($_[0], $_[1], $_   , $_[3])  } @{ $_[2] }  } 




 




0





 





 





 





 





0



   




 




0





 





 





 





 





0



   




7032




0





 





 




  
0
  



  
0
  




0



 sub column4_11nn($$$$)  { map { column4_111n  ($_[0], $_[1], $_   , $_[3])  } @{ $_[2] }  } 




 




0





 





 





 





 





0



   




 




0





 





 





 





 





0



   




7033




0





 





 




  
0
  



  
0
  




0



 sub column4_1n11($$$$)  { map { column4       ($_[0], $_   , $_[2], $_[3])  } @{ $_[1] }  } 




 




0





 





 





 





 





0



   




 




0





 





 





 





 





0



   




7034




0





 





 




  
0
  



  
0
  




0



 sub column4_1n1n($$$$)  { map { column4_111n  ($_[0], $_   , $_[2], $_[3])  } @{ $_[1] }  } 




 




0





 





 





 





 





0



   




 




0





 





 





 





 





0



   




7035




0





 





 




  
0
  



  
0
  




0



 sub column4_1nn1($$$$)  { map { column4_11n1  ($_[0], $_   , $_[2], $_[3])  } @{ $_[1] }  } 




 




0





 





 





 





 





0



   




 




0





 





 





 





 





0



   




7036




0





 





 




  
0
  



  
0
  




0



 sub column4_1nnn($$$$)  { map { column4_11nn  ($_[0], $_   , $_[2], $_[3])  } @{ $_[1] }  } 




 




0





 





 





 





 





0



   




 




0





 





 





 





 





0



   




7037




0





 





 




  
0
  



  
0
  




0



 sub column4_n111($$$$)  { map { column4       ($_   , $_[1], $_[2], $_[3])  } @{ $_[0] }  } 




 




0





 





 





 





 





0



   




 




0





 





 





 





 





0



   




7038




0





 





 




  
0
  



  
0
  




0



 sub column4_n11n($$$$)  { map { column4_111n  ($_   , $_[1], $_[2], $_[3])  } @{ $_[0] }  } 




 




0





 





 





 





 





0



   




 




0





 





 





 





 





0



   




7039




0





 





 




  
0
  



  
0
  




0



 sub column4_n1n1($$$$)  { map { column4_11n1  ($_   , $_[1], $_[2], $_[3])  } @{ $_[0] }  } 




 




0





 





 





 





 





0



   




 




0





 





 





 





 





0



   




7040




0





 





 




  
0
  



  
0
  




0



 sub column4_n1nn($$$$)  { map { column4_11nn  ($_   , $_[1], $_[2], $_[3])  } @{ $_[0] }  } 




 




0





 





 





 





 





0



   




 




0





 





 





 





 





0



   




7041




0





 





 




  
0
  



  
0
  




0



 sub column4_nn11($$$$)  { map { column4_1n11  ($_   , $_[1], $_[2], $_[3])  } @{ $_[0] }  } 




 




0





 





 





 





 





0



   




 




0





 





 





 





 





0



   




7042




0





 





 




  
0
  



  
0
  




0



 sub column4_nn1n($$$$)  { map { column4_1n1n  ($_   , $_[1], $_[2], $_[3])  } @{ $_[0] }  } 




 




0





 





 





 





 





0



   




 




0





 





 





 





 





0



   




7043




0





 





 




  
0
  



  
0
  




0



 sub column4_nnn1($$$$)  { map { column4_1nn1  ($_   , $_[1], $_[2], $_[3])  } @{ $_[0] }  } 




 




0





 





 





 





 





0



   




 




0





 





 





 





 





0



   




7044




0





 





 




  
0
  



  
0
  




0



 sub column4_nnnn($$$$)  { map { column4_1nnn  ($_   , $_[1], $_[2], $_[3])  } @{ $_[0] }  } 




 




0





 





 





 





 





0



   




 




0





 





 





 





 





0



   




7045




 





 





 





 





 





 



   




7046




 





 





 





 





 





 



 #################### 




7047




 





 





 





 





 





 



 # stmt interpolation: 




7048




 





 





 





 





 





 



   




7049




 





 





 





 





 





 



 sub stmt($) 




7050




 





 





 





 





 





 



 { 




7051




3





 





 




  
3
  



  
0
  




23



     my ($x)= @_; 




7052




3




  
 50
  




 





 





 





11



     if (ref($x)) { 




7053




3





 





 





 





 





21



         return $x->stmt; 




7054




 





 





 





 





 





 



     } 




7055




 





 





 





 





 





 



     else { 




7056




0





 





 





 





 





0



         croak "Error: Expected 'Stmt' object, but found: ".my_dumper($x); 




7057




 





 





 





 





 





 



     } 




7058




 





 





 





 





 





 



 } 




7059




 





 





 





 





 





 



   




7060




 





 





 





 





 





 



 sub subquery($) 




7061




 





 





 





 





 





 



 { 




7062




1





 





 




  
1
  



  
0
  




3



     my ($x1)= @_; 




7063




1





 





 





 





 





8



     my $x= SQL::Yapp::Stmt->obj($x1); 




7064




1





 





 





 





 





8



     return $x->subquery; 




7065




 





 





 





 





 





 



 } 




7066




 





 





 





 





 





 



   




7067




 





 





 





 





 





 



 #################### 




7068




 





 





 





 





 





 



 # expr interpolation: 




7069




 





 





 





 





 





 



   




7070




 





 





 





 





 





 



 sub exprparen($) 




7071




 





 





 





 





 





 



 { 




7072




70





 





 




  
70
  



  
0
  




2271



     my ($x)= @_; 




7073




70




  
100
  




 





 





 





140



     if (ref($x)) { 




7074




5




  
 50
  




 





 





 





21



         die Dumper($x) if ref($x) eq 'HASH'; 




7075




5




  
 50
  




 





 





 





17



         die Dumper($x) if ref($x) eq 'ARRAY'; 




7076




5




  
 50
  




 





 





 





15



         die Dumper($x) if ref($x) eq 'CODE'; 




7077




5




  
 50
  




 





 





 





15



         die Dumper($x) if ref($x) eq 'SCALAR'; 




7078




5





 





 





 





 





23



         return $x->exprparen; 




7079




 





 





 





 





 





 



     } 




7080




 





 





 





 





 





 



     else { 




7081




65





 





 





 





 





130



         return SQL::Yapp::Expr->obj(get_quote_val->($x)); # raw perl scalar: quote as value, no parens 




7082




 





 





 





 





 





 



     } 




7083




 





 





 





 





 





 



 } 




7084




 





 





 





 





 





 



   




7085




 





 





 





 





 





 



 sub expr($) 




7086




 





 





 





 





 





 



 { 




7087




153





 





 




  
153
  



  
0
  




8281



     my ($x)= @_; 




7088




153




  
100
  




 





 





 





325



     if (ref($x)) { 




7089




21




  
 50
  




 





 





 





86



         confess 'Error: Trying to invoke $x->expr() on unblessed reference $x ". 




7090




 





 





 





 





 





 



                 "(maybe missing nested sqlExpr{...} inside a block, or ". 




7091




 





 





 





 





 





 



                 "additional () around {} interpolation?)' 




7092




 





 





 





 





 





 



             unless blessed($x); 




7093




21





 





 





 





 





104



         return $x->expr; 




7094




 





 





 





 





 





 



     } 




7095




 





 





 





 





 





 



     else { 




7096




132





 





 





 





 





276



         return SQL::Yapp::Expr->obj(get_quote_val->($x)); # raw perl scalar: quote as value 




7097




 





 





 





 





 





 



     } 




7098




 





 





 





 





 





 



 } 




7099




 





 





 





 





 





 



   




7100




 





 





 





 





 





 



 sub expr_or_check($) 




7101




 





 





 





 





 





 



 { 




7102




5





 





 




  
5
  



  
0
  




13



     my ($x)= @_; 




7103




5




  
100
  




 





 





 





17



     if (ref($x)) { 




7104




3





 





 





 





 





10



         return $x->expr_or_check; 




7105




 





 





 





 





 





 



     } 




7106




 





 





 





 





 





 



     else { 




7107




2





 





 





 





 





6



         return SQL::Yapp::Expr->obj(get_quote_val->($x)); # raw perl scalar: quote as value 




7108




 





 





 





 





 





 



     } 




7109




 





 





 





 





 





 



 } 




7110




 





 





 





 





 





 



   




7111




 





 





 





 





 





 



 sub exprparen_hash(\%) 




7112




 





 





 





 





 





 



 { 




7113




3





 





 




  
3
  



  
0
  




9



     my ($x)= @_; 




7114




6





 





 





 





 





13



     return map { 




7115




3





 





 





 





 





20



         my $n= $_; 




7116




6





 





 





 





 





11



         my $e= $x->{$n}; 




7117




6




  
100
  



  
 66
  




 





 





65



         (blessed($e) && $e->isa('SQL::Yapp::Check') ? 




7118




 





 





 





 





 





 



             '('.get_quote_id->($n).' '.$e->check.')' 




7119




 





 





 





 





 





 



         :   '('.get_quote_id->($n).' = '.exprparen($e).')' 




7120




 





 





 





 





 





 



         ) 




7121




 





 





 





 





 





 



     } 




7122




 





 





 





 





 





 



     sort keys %$x; 




7123




 





 





 





 





 





 



 } 




7124




 





 





 





 





 





 



   




7125




 





 





 





 





 





 



 sub expr_hash(\%) 




7126




 





 





 





 





 





 



 { 




7127




4





 





 




  
4
  



  
0
  




11



     my ($x)= @_; 




7128




7





 





 





 





 





13



     return map { 




7129




4





 





 





 





 





21



         my $n= $_; 




7130




7





 





 





 





 





13



         my $e= $x->{$n}; 




7131




7




  
 50
  



  
 33
  




 





 





38



         (blessed($e) && $e->isa('SQL::Yapp::Check') ? 




7132




 





 





 





 





 





 



             '('.get_quote_id->($n).' '.$e->check.')' 




7133




 





 





 





 





 





 



         :   SQL::Yapp::Infix->obj('=', get_quote_id->($n), exprparen($e)) 




7134




 





 





 





 





 





 



         ) 




7135




 





 





 





 





 





 



     } 




7136




 





 





 





 





 





 



     sort keys %$x; 




7137




 





 





 





 





 





 



 } 




7138




 





 





 





 





 





 



   




7139




 





 





 





 





 





 



 #################### 




7140




 





 





 





 





 





 



 # order interpolation: 




7141




 





 





 





 





 





 



   




7142




 





 





 





 





 





 



 sub asc($) 




7143




 





 





 





 





 





 



 { 




7144




9





 





 




  
9
  



  
0
  




440



     my ($x)= @_; 




7145




9




  
100
  




 





 





 





25



     if (ref($x)) { 




 




 




  
 50
  




 





 





 





 



   




7146




4





 





 





 





 





16



         return $x->asc; 




7147




 





 





 





 





 





 



     } 




7148




 





 





 





 





 





 



     elsif (defined $x) { 




7149




5





 





 





 





 





12



         return column1($x); 




7150




 





 





 





 





 





 



     } 




7151




 





 





 





 





 





 



     else { 




7152




0





 





 





 





 





0



         return NULL; 




7153




 





 





 





 





 





 



     } 




7154




 





 





 





 





 





 



 } 




7155




 





 





 





 





 





 



   




7156




 





 





 





 





 





 



 sub desc($) 




7157




 





 





 





 





 





 



 { 




7158




10





 





 




  
10
  



  
0
  




39



     my ($x)= @_; 




7159




10




  
100
  




 





 





 





30



     if (ref($x)) { 




 




 




  
 50
  




 





 





 





 



   




7160




6





 





 





 





 





17



         return $x->desc; 




7161




 





 





 





 





 





 



     } 




7162




 





 





 





 





 





 



     elsif (defined $x) { 




7163




4





 





 





 





 





9



         return SQL::Yapp::Desc->obj(column1($x)); 




7164




 





 





 





 





 





 



     } 




7165




 





 





 





 





 





 



     else { 




7166




0





 





 





 





 





0



         return NULL; 




7167




 





 





 





 





 





 



     } 




7168




 





 





 





 





 





 



 } 




7169




 





 





 





 





 





 



   




7170




 





 





 





 





 





 



 #################### 




7171




 





 





 





 





 





 



 # table option: 




7172




 





 





 





 





 





 



   




7173




 





 





 





 





 





 



 sub tableopt($) 




7174




 





 





 





 





 





 



 { 




7175




2





 





 




  
2
  



  
0
  




7



     my ($x)= @_; 




7176




2




  
 50
  




 





 





 





6



     if (ref($x)) { 




7177




2





 





 





 





 





6



         return $x->tableopt; 




7178




 





 





 





 





 





 



     } 




7179




 





 





 





 





 





 



     else { 




7180




0





 





 





 





 





0



         croak "Error: Expected 'TableOption' object, but found: ".my_dumper($x); 




7181




 





 





 





 





 





 



     } 




7182




 





 





 





 





 





 



 } 




7183




 





 





 





 





 





 



   




7184




 





 





 





 





 





 



 #################### 




7185




 





 





 





 





 





 



 # join interpolation: 




7186




 





 





 





 





 





 



   




7187




 





 





 





 





 





 



 sub joinclause($) 




7188




 





 





 





 





 





 



 { 




7189




4





 





 




  
4
  



  
0
  




11



     my ($x)= @_; 




7190




4




  
 50
  




 





 





 





11



     if (ref($x)) { 




7191




4





 





 





 





 





12



         return $x->joinclause; 




7192




 





 





 





 





 





 



     } 




7193




 





 





 





 





 





 



     else { 




7194




0





 





 





 





 





0



         croak "Error: Expected 'Join' object, but found: ".my_dumper($x); 




7195




 





 





 





 





 





 



     } 




7196




 





 





 





 





 





 



 } 




7197




 





 





 





 





 





 



   




7198




 





 





 





 





 





 



 #################### 




7199




 





 





 





 





 





 



 # limit interpolation: 




7200




 





 





 





 





 





 



   




7201




 





 





 





 





 





 



 sub limit_number($) 




7202




 





 





 





 





 





 



 { 




7203




14





 





 




  
14
  



  
0
  




51



     my ($x)= @_; 




7204




14




  
 50
  




 





 





 





74



     if (ref($x)) { 




 




 




  
 50
  




 





 





 





 



   




7205




0





 





 





 





 





0



         return $x->limit_number; 




7206




 





 





 





 





 





 



     } 




7207




 





 





 





 





 





 



     elsif (looks_like_number $x) { 




7208




14





 





 





 





 





61



         return $x; 




7209




 





 





 





 





 





 



     } 




7210




 





 





 





 





 





 



     else { 




7211




0





 





 





 





 





0



         croak "Error: Expected number or ?, but found: ".my_dumper($x); 




7212




 





 





 





 





 





 



     } 




7213




 





 





 





 





 





 



 } 




7214




 





 





 





 





 





 



   




7215




 





 





 





 





 





 



 sub limit($$) 




7216




 





 





 





 





 





 



 { 




7217




2





 





 




  
2
  



  
0
  




7



     my ($cnt, $offset)= @_; 




7218




 





 





 





 





 





 



   




7219




 





 





 





 





 





 



     # FIXME: if dialect is 'std' (or maybe 'std2008'), produce OFFSET/FETCH 




7220




 





 





 





 





 





 



     #        clause (SQL-2008). 




7221




2




  
100
  




 





 





 





9



     if (defined $cnt) { 




7222




1




  
 50
  




 





 





 





3



         if (defined $offset) { 




7223




1





 





 





 





 





7



             return " LIMIT ".limit_number($cnt)." OFFSET ".limit_number($offset); 




7224




 





 





 





 





 





 



         } 




7225




 





 





 





 





 





 



         else { 




7226




0





 





 





 





 





0



             return " LIMIT ".limit_number($cnt); 




7227




 





 





 





 





 





 



         } 




7228




 





 





 





 





 





 



     } 




7229




 





 





 





 





 





 



     else { 




7230




1




  
 50
  




 





 





 





5



         if (defined $offset) { 




7231




1




  
 50
  




 





 





 





5



             if ($write_dialect eq 'postgresql') { 




7232




0





 





 





 





 





0



                 return " LIMIT ALL OFFSET ".limit_number($offset); 




7233




 





 





 





 





 





 



             } 




7234




 





 





 





 





 





 



             else { 




7235




1





 





 





 





 





3



                 return " LIMIT ${\LARGE_LIMIT_CNT} OFFSET ".limit_number($offset); 




 




1





 





 





 





 





7



   




7236




 





 





 





 





 





 



             } 




7237




 





 





 





 





 





 



         } 




7238




 





 





 





 





 





 



         else { 




7239




0





 





 





 





 





0



             return ''; 




7240




 





 





 





 





 





 



         } 




7241




 





 





 





 





 





 



     } 




7242




 





 





 





 





 





 



 } 




7243




 





 





 





 





 





 



   




7244




 





 





 





 





 





 



 #################### 




7245




 





 





 





 





 





 



 # case: 




7246




 





 





 





 





 





 



   




7247




 





 





 





 





 





 



 sub whenthen($$) 




7248




 





 





 





 





 





 



 { 




7249




6





 





 




  
6
  



  
0
  




10



     my ($expr, $then)= @_; 




7250




6





 





 





 





 





152



     return 'WHEN '.$expr.' THEN '.$then; 




7251




 





 





 





 





 





 



 } 




7252




 





 





 





 





 





 



   




7253




 





 





 





 





 





 



 sub caseswitch($$@) 




7254




 





 





 





 





 





 



 { 




7255




 





 





 





 





 





 



    #my ($switchval, $default, @whenthen) 




7256




8




  
100
  




 




  
8
  



  
0
  




27



    if (scalar(@_) == 2) { # @whenthen is empty => always use default 




7257




2





 





 





 





 





7



        return $_[1];      # return default 




7258




 





 





 





 





 





 



    } 




7259




 





 





 





 





 





 



    return 




7260




6





 





 





 





 





116



       join(' ', 




7261




 





 





 





 





 





 



           'CASE', 




7262




 





 





 





 





 





 



           $_[0], 




7263




 





 





 





 





 





 



           @_[2..$#_],     # @whenthen 




7264




 





 





 





 





 





 



           'ELSE',         # always generate default, it's easier. 




7265




 





 





 





 





 





 



           $_[1], 




7266




 





 





 





 





 





 



           'END' 




7267




 





 





 





 





 





 



      ); 




7268




 





 





 





 





 





 



 } 




7269




 





 





 





 





 





 



   




7270




 





 





 





 





 





 



 sub casecond($@) 




7271




 





 





 





 





 





 



 { 




7272




 





 





 





 





 





 



    #my ($default, @whenthen) 




7273




0




  
  0
  




 




  
0
  



  
0
  




 



    if (scalar(@_) == 1) { # @whenthen is empty => always use default 




7274




0





 





 





 





 





 



        return $_[0];      # return default 




7275




 





 





 





 





 





 



    } 




7276




 





 





 





 





 





 



    return 




7277




0





 





 





 





 





 



       join(' ', 




7278




 





 





 





 





 





 



           'CASE', 




7279




 





 





 





 





 





 



           @_[1..$#_],     # @whenthen 




7280




 





 





 





 





 





 



           'ELSE',         # always generate default, it's easier. 




7281




 





 





 





 





 





 



           $_[0], 




7282




 





 





 





 





 





 



           'END' 




7283




 





 





 





 





 





 



      ); 




7284




 





 





 





 





 





 



 } 




7285




 





 





 





 





 





 



   




7286




 





 





 





 





 





 



 1; 




7287




 





 





 





 





 





 



   




7288




 





 





 





 





 





 



 ###################################################################### 




7289




 





 





 





 





 





 



 ###################################################################### 




7290




 





 





 





 





 





 



 ###################################################################### 




7291




 





 





 





 





 





 



   




7292




 





 





 





 





 





 



 __END__
    #
    # All:
    #     - UNION
    #     - INTERSECT
    #     - EXCEPT
    #     - FETCH [ FIRST | NEXT ] count [ ROW | ROWS ] ONLY  (same as LIMIT in SQL:2008)

    $r->{opt_front}= [];
    push_option ($lx, $r->{opt_front}, [
        'DISTINCT', 'ALL',
        ($read_dialect{mysql} ?
            ('DISTINCTROW')
        :   ()
        )
    ]);

    push_option_list ($lx, $r->{opt_front}, [
        ($read_dialect{mysql} ?
            (
                'HIGH_PRIORITY', 'STRAIGHT_JOIN',
                'SQL_SMALL_RESULT', 'SQL_BIG_RESULT', 'SQL_BUFFER_RESULT',
                'SQL_CACHE', 'SQL_NO_CACHE', 'SQL_CALC_FOUND_ROWS'
            )
        :   ()
        )
    ]);

    return unless
        $r->{expr_list}= parse_list([], $lx, \&parse_expr_as, ',');

    if (looking_at($lx, 'FROM', SHIFT)) {
        return unless
            $r->{from}= parse_list([], $lx, \&parse_table_as, ',')
        and $r->{join}= parse_try_list([], $lx, \&parse_join);

        if (looking_at($lx, 'WHERE', SHIFT)) {
            return unless
                $r->{where}= parse_where ($lx);
        }
        if (looking_at($lx, 'GROUP BY', SHIFT)) {
            return unless
                $r->{group_by}= parse_list([], $lx, \&parse_order, ',');

            $r->{group_by_with_rollup}= looking_at($lx, 'WITH ROLLUP', SHIFT);
        }
        if (looking_at($lx, 'HAVING', SHIFT)) {
            return unless
                $r->{having}= parse_expr ($lx);
        }
        if (looking_at($lx, 'ORDER BY', SHIFT)) {
            return unless
                $r->{order_by}= parse_list([], $lx, \&parse_order, ',');
        }

        if (looking_at($lx, 'LIMIT', SHIFT)) {
            unless (looking_at($lx, 'ALL', SHIFT)) {
                my $first_num= parse_limit_num ($lx);
                if (looking_at($lx, ',', SHIFT)) {
                    $r->{limit_offset}= $first_num;
                    $r->{limit_cnt}=    parse_limit_num($lx);
                }
                else {
                    $r->{limit_cnt}= $first_num;
                }
            }
        }
        if (!$r->{limit_offset} &&
            looking_at ($lx, 'OFFSET', SHIFT))
        {
            $r->{limit_offset}= parse_limit_num ($lx);
        }

        $r->{opt_back}=  [];
        push_option_list ($lx, $r->{opt_back}, [
            ($read_dialect{mysql} || $read_dialect{postgresql} ?
                ('FOR UPDATE')
            :   ()
            ),
            ($read_dialect{mysql} ?
                (
                    'LOCK IN SHARE MODE'  # FIXME: normalise: PostgreSQL: FOR SHARE
                )
            :   ()
            ),
            ($read_dialect{postgresql} ?
                (
                    'FOR SHARE',          # FIXME: normalise: MySQL: LOCK IN SHARE MODE
                    'NOWAIT'
                )
            :   ()
            ),
        ]);
    }

    lock_hash %$r;
    return $r;
}

sub parse_insert($)
{
    my ($lx)= @_;
    my $r= create ($lx, ['Stmt','Insert'],
        qw(
            opt_front
            into
            column
            default_values
            value
            value_interpol
            set
            select
            duplicate_update
        )
    );

    return unless expect($lx, 'INSERT', SHIFT);

    # PostgreSQL:
    #    - RETURNING ...

    $r->{opt_front}= [];
    push_option_list ($lx, $r->{opt_front}, [
        ($read_dialect{mysql} ?
            (
                'IGNORE',
                'LOW_PRIORITY',
                'HIGH_PRIORITY',
                'DELAYED',
            )
        :   ()
        )
    ]);

    looking_at($lx, 'INTO', SHIFT); # optional in MySQL

    return unless
        $r->{into}= parse_table($lx);

    if (looking_at($lx, '(')) {
        return unless
            $r->{column}= parse_list_delim($lx, \&parse_column_name);
    }

    parse_choice($lx,
        'DEFAULT VALUES' => sub {
            lexer_shift($lx);
            $r->{default_values}= 1;
        },

        'VALUE' => 'VALUES',
        'VALUES' => sub {
            lexer_shift($lx);
            $r->{value}= parse_list([], $lx, \&parse_expr_list_delim, ',');
        },

        'SET' => sub {
            # MySQL extension, but will be normalised to VALUES clause, so we
            # always accept this even with !$read_dialect{mysql}.
            if ($r->{column}) {
                $lx->{error}= "Either column list or 'SET' expected, but found both.";
                return;
            }
            lexer_shift($lx);
            $r->{set}= parse_list([], $lx, \&parse_expr, ',');
        },

        (map { $_ => 'interpolStmt' } @SELECT_INITIAL),
        'interpol' => 'interpolStmt',
        'interpolStmt' => sub {
            $r->{select}= parse_select_stmt($lx);
        },
    );
    return if $lx->{error};

    if ($read_dialect{mysql} &&
        looking_at ($lx, 'ON DUPLICATE KEY UPDATE', SHIFT))
    {
        return unless
            $r->{duplicate_update}= parse_list([], $lx, \&parse_expr, ',');
    }

    lock_hash %$r;
    return $r;
}

sub parse_update($)
{
    my ($lx)= @_;
    my $r= create ($lx, ['Stmt','Update'],
        qw(
            opt_front
            table
            set
            from
            join
            where
            order_by
            limit_cnt
            limit_offset
        )
    );

    return unless expect($lx, 'UPDATE', SHIFT);

    # PostgreSQL:
    #    - RETURNING ...

    $r->{opt_front}= [];
    push_option_list ($lx, $r->{opt_front}, [
        ($read_dialect{mysql} ?
            (
                'IGNORE',
                'LOW_PRIORITY',
            )
        :   ()
        ),
        ($read_dialect{postgresql} ?
            (
                'ONLY',
            )
        :   ()
        )
    ]);

    return unless
        $r->{table}= parse_list([], $lx, \&parse_table_as, ',')
    and expect($lx, 'SET', SHIFT)
    and $r->{set}= parse_list([], $lx, \&parse_expr, ',');

    if (looking_at($lx, 'FROM', SHIFT)) {
        return unless
            $r->{from}= parse_list([], $lx, \&parse_table_as, ',');
    }
    return unless
        $r->{join}= parse_try_list([], $lx, \&parse_join);

    if (looking_at($lx, 'WHERE', SHIFT)) {
        return unless
            $r->{where}= parse_where ($lx);
    }
    if (looking_at($lx, 'ORDER BY', SHIFT)) {
        return unless
            $r->{order_by}= parse_list([], $lx, \&parse_order, ',');
    }
    if (looking_at($lx, 'LIMIT', SHIFT)) {
        $r->{limit_cnt}= parse_limit_num($lx);
    }

    lock_hash %$r;
    return $r;
}

sub parse_delete($)
{
    my ($lx)= @_;
    my $r= create ($lx, ['Stmt','Delete'],
        qw(
            opt_front
            from
            from_opt_front
            join
            using
            where
            order_by
            limit_cnt
            limit_offset
        )
    );

    return unless expect($lx, 'DELETE', SHIFT);

    # PostgreSQL:
    #    - RETURNING ...

    $r->{opt_front}= [];
    push_option_list ($lx, $r->{opt_front}, [
        ($read_dialect{mysql} ?
            (
                'IGNORE',
                'LOW_PRIORITY',
                'QUICK'
            )
        :   ()
        )
    ]);

    return unless expect($lx, 'FROM', SHIFT);

    $r->{from_opt_front}= [];
    push_option ($lx, $r->{from_opt_front}, [
        ($read_dialect{postgresql} ?
            ('ONLY')
        :   ()
        )
    ]);

    return unless
        $r->{from}= parse_list([], $lx, \&parse_table_as, ',');

    if (looking_at($lx, 'USING', SHIFT)) {
        return unless
            $r->{using}= parse_list([], $lx, \&parse_table_as, ',');
    }

    return unless
        $r->{join}= parse_try_list([], $lx, \&parse_join);

    if (looking_at($lx, 'WHERE', SHIFT)) {
        return unless
            $r->{where}= parse_where ($lx);
    }
    if (looking_at($lx, 'ORDER BY', SHIFT)) {
        return unless
            $r->{order_by}= parse_list([], $lx, \&parse_order, ',');
    }
    if (looking_at($lx, 'LIMIT', SHIFT)) {
        $r->{limit_cnt}= parse_limit_num($lx);
    }

    lock_hash %$r;
    return $r;
}

sub keyword($$)
{
    my ($lx, $keyword)= @_;
    return
        unless $keyword;

    return $keyword
        if ref($keyword);

    my $r= create($lx, 'Keyword', qw(keyword));
    $r->{keyword}= $keyword;
    lock_hash %$r;
    return $r;
}

sub parse_index_option($)
{
    my ($lx)= @_;
    my $r= create($lx, 'IndexOption', qw(arg));

    parse_choice($lx,
        -default => sub {
            $r= undef;
        },

        # MySQL does not like it here, but only accepts it in front of the
        # column list, which is against the manual's description.
        #'USING' => sub {
        #    lexer_shift($lx);
        #    return unless
        #        my $t= expect($lx, ['BTREE','HASH','RTREE'], SHIFT);
        #    $r->{type}= 'using';
        #    $r->{arg}=  $t;
        #},
    );
    return unless $r;
    return if $lx->{error};

    lock_hash %$r;
    return $r;
}

sub parse_index_type ($)
{
    my ($lx)= @_;
    if (looking_at($lx, 'USING', SHIFT)) {
        return expect($lx, ['BTREE','HASH','RTREE'], SHIFT);
    }
    return;
}

sub parse_table_constraint($)
{
    my ($lx)= @_;
    my $r= create($lx, "TableConstraint", qw(constraint index_type column index_option reference));
    $r->{index_option}= [];

    if (looking_at($lx, 'CONSTRAINT', SHIFT)) {
        return unless
            $r->{constraint}= parse_constraint($lx);
    }

    parse_choice($lx,
        'PRIMARY KEY' => sub {
            lexer_shift($lx);
            $r->{type}=  'primary_key';
            $r->{index_type}= parse_index_type($lx);
            return unless
                $r->{column}= parse_list_delim($lx, \&parse_column_index)
            and $r->{index_option}= parse_try_list([], $lx, \&parse_index_option);
        },
        'UNIQUE' => sub {
            lexer_shift($lx);
            $r->{type}= 'unique';
            $r->{index_type}= parse_index_type($lx);
            return unless
                $r->{column}= parse_list_delim($lx, \&parse_column_index)
            and $r->{index_option}= parse_try_list([], $lx, \&parse_index_option);
        },
        'FULLTEXT' => sub {
            lexer_shift($lx);
            $r->{type}= 'fulltext';
            $r->{index_type}= parse_index_type($lx);
            return unless
                $r->{column}= parse_list_delim($lx, \&parse_column_index)
            and $r->{index_option}= parse_try_list([], $lx, \&parse_index_option);
        },
        'SPATIAL' => sub {
            lexer_shift($lx);
            $r->{type}= 'spatial';
            $r->{index_type}= parse_index_type($lx);
            return unless
                $r->{column}= parse_list_delim($lx, \&parse_column_index)
            and $r->{index_option}= parse_try_list([], $lx, \&parse_index_option);
        },
        'FOREIGN KEY' => sub {
            lexer_shift($lx);
            $r->{type}= 'foreign_key';
            $r->{index_type}= parse_index_type($lx);
            return unless
                $r->{column}= parse_list_delim($lx, \&parse_column_name)
            and $r->{reference}= parse_references($lx);
        },
        # 'CHECK' => sub {
        # },
        ($read_dialect{mysql} ?
            (
                'INDEX' => sub {
                    lexer_shift($lx);
                    $r->{type}= 'index';
                    # FIXME: mysql allows an index name here
                    return unless
                        $r->{column}= parse_list_delim($lx, \&parse_column_index);
                    $r->{index_option}= parse_try_list([], $lx, \&parse_index_option);
                }
            )
        :   ()
        ),
    );
    return if $lx->{error};

    lock_hash %$r;
    return $r;
}

sub parse_table_option1($$$$)
{
    my ($lx, $r, $name, $parse)= @_;
    $r->{type}= 'literal';
    $r->{name}= $name;
    lexer_shift($lx);
    looking_at($lx, '=', SHIFT); # optional =
    return unless
        $r->{value}= $parse->($lx);
    while (looking_at($lx, ',', SHIFT)) {} # optional ,
    return $r;
}

sub parse_on_commit_action($)
{
    my ($lx)= @_;
    return keyword ($lx,
        expect($lx,
            [
                'PRESERVE ROWS',
                'DELETE ROWS',
                ($read_dialect{postgresql} ?
                    (
                        'DROP'
                    )
                :   ()
                )
            ],
            SHIFT
        )
    );
}

sub parse_table_option($)
{
    my ($lx)= @_;
    my $r= create($lx, 'TableOption', qw(name value token));

    parse_choice($lx,
        -default => sub {
            $r= undef;
        },

        ($read_dialect{mysql} ?
            (
                'ENGINE' => sub {
                    return parse_table_option1($lx, $r, 'ENGINE', \&parse_engine);
                },

                'CHARACTER SET' => 'DEFAULT CHARACTER SET',
                'DEFAULT CHARACTER SET' => sub {
                    return parse_table_option1($lx, $r, 'DEFAULT CHARACTER SET', \&parse_charset);
                },

                'COLLATE' => 'DEFAULT COLLATE',
                'DEFAULT COLLATE' => sub {
                    return parse_table_option1($lx, $r, 'DEFAULT COLLATE', \&parse_collate);
                },

                'AUTO_INCREMENT' => sub {
                    return parse_table_option1($lx, $r, 'AUTO_INCREMENT', \&parse_expr);
                },

                'COMMENT' => sub {
                    return parse_table_option1($lx, $r, 'COMMENT', \&parse_expr);
                },
            )
        :   ()
        ),

        'ON COMMIT' => sub {
            return parse_table_option1($lx, $r, 'ON COMMIT', \&parse_on_commit_action);
        },

        'interpolTableOption' => 'interpol',
        'interpol' => sub {
            $r->{type}= 'interpol';
            $r->{token}= $lx->{token};
            lexer_shift($lx);
            while (looking_at($lx, ',', SHIFT)) {} # optional ,
            return $r;
        },
    );
    return unless $r;
    return if $lx->{error};
    lock_hash %$r;
    return $r;
}

sub parse_column_def($)
{
    my ($lx)= @_;
    my $r= create($lx, 'ColumnDef', qw(name column_spec));
    return unless
        $r->{name}=        parse_column_name($lx)
    and $r->{column_spec}= parse_column_spec($lx);
    lock_hash %$r;
    return $r;
}

sub parse_column_def_or_option($)
{
    my ($lx)= @_;
    return parse_choice($lx,
        'interpol' => 'ident',
        'ident' => sub {
            return parse_column_def($lx);
        },
        -default => sub {
            return parse_table_constraint($lx);
        },
    );
}

sub parse_create_table($)
{
    my ($lx)= @_;
    return unless
        expect($lx, \@CREATE_TABLE_INITIAL);

    my $r= create($lx, ['Stmt','CreateTable'],
                  qw(subtype if_not_exists table column_def tabconstr tableopt select));
    $r->{subtype}= lexer_shift($lx);

    if ($read_dialect{mysql} &&
        looking_at($lx, 'IF NOT EXISTS', SHIFT))
    {
        $r->{if_not_exists}= 1;
    }

    return unless
        $r->{table}= parse_table($lx);

    $r->{column_def}= [];
    $r->{tabconstr}=  [];
    if (looking_at($lx, '(')) {
        return unless
            my $spec= parse_list_delim($lx, \&parse_column_def_or_option);

        $r->{column_def}= [ grep { $_->{kind} eq 'ColumnDef' } @$spec ];
        $r->{tabconstr}=  [ grep { $_->{kind} ne 'ColumnDef' } @$spec ];
    }

    return unless
        $r->{tableopt}= parse_try_list([], $lx, \&parse_table_option);

    if (looking_at($lx, 'AS', SHIFT) ||
        looking_at($lx, \@SELECT_INITIAL))
    {
        return unless
            $r->{select}= parse_select($lx);
    }

    unless (scalar(@{ $r->{column_def} }) || $r->{select}) {
        $lx->{error}= 'Either query or at least one column expected';
        return;
    }

    lock_hash %$r;
    return $r;
}

sub parse_drop_table($)
{
    my ($lx)= @_;
    return unless
        expect($lx, \@DROP_TABLE_INITIAL);

    my $r= create($lx, ['Stmt','DropTable'],
                  qw(subtype if_exists table cascade));
    $r->{subtype}= lexer_shift($lx);

    if ($read_dialect{mysql} &&
        looking_at($lx, 'IF EXISTS', SHIFT))
    {
        $r->{if_exists}= 1;
    }

    return unless
        $r->{table}= parse_list([], $lx, \&parse_table, ',');

    $r->{cascade}= looking_at($lx, ['RESTRICT','CASCADE'], SHIFT);

    lock_hash %$r;
    return $r;
}

sub parse_column_pos_perhaps($)
{
    my ($lx)= @_;
    return parse_choice($lx,
        -default => sub {
            return;
        },
        'FIRST' => sub {
            return lexer_shift($lx);
        },
        'AFTER' => sub {
            lexer_shift($lx);
            return ('AFTER', parse_column_name($lx));
        },
    );
}

sub parse_alter_table($)
{
    my ($lx)= @_;
    return unless
        expect($lx, \@ALTER_TABLE_INITIAL);

    my $r= create($lx, ['Stmt','AlterTable'],
                  qw(subtype functor subfunctor arg online ignore table only));
    $r->{subtype}= lexer_shift($lx);
    $r->{arg}=     [];

    return unless
        $r->{table}= parse_table($lx);

    $r->{only}= looking_at($lx, 'ONLY', SHIFT);

    parse_choice($lx,
        'DROP CONSTRAINT' => sub {
            $r->{functor}= lexer_shift($lx);
            return unless
                my $constraint= parse_constraint($lx);
            push @{ $r->{arg} }, $constraint, looking_at($lx, ['RESTRICT','CASCADE'], SHIFT);
        },

        'DROP COLUMN' => sub {
            $r->{functor}= lexer_shift($lx);
            return unless
                my $column= parse_column_name($lx);
            push @{ $r->{arg} }, $column, looking_at($lx, ['RESTRICT','CASCADE'], SHIFT);
        },

        'RENAME COLUMN' => sub {
            $r->{functor}= lexer_shift($lx);

            return unless
                my $column= parse_column_name($lx)
            and expect($lx, 'TO', SHIFT)
            and my $column2= parse_column_name($lx);

            push @{ $r->{arg} }, $column, 'TO', $column2;
        },

        'DROP PRIMARY KEY' => sub {
            $r->{functor}= lexer_shift($lx);
        },

        'ALTER COLUMN' => sub {
            $r->{functor}= lexer_shift($lx);
            push @{ $r->{arg} }, parse_column_name($lx);
            return if $lx->{error};

            parse_choice($lx,
                'DROP DEFAULT'  => 'SET NOT NULL',
                'DROP NOT NULL' => 'SET NOT NULL',
                'SET NOT NULL'  => sub {
                    push @{ $r->{arg} }, lexer_shift($lx);
                },

                'SET DEFAULT' => sub {
                    push @{ $r->{arg} }, lexer_shift($lx);
                    push @{ $r->{arg} }, parse_expr($lx);
                },

                ($read_dialect{postgresql} ?
                    (
                        'TYPE' => sub {
                            push @{ $r->{arg} }, lexer_shift($lx);
                            push @{ $r->{arg} }, parse_type($lx);
                            return if $lx->{error};
                            if (my $x= looking_at($lx, 'USING', SHIFT)) {
                                push @{ $r->{arg} }, $x, parse_expr($lx);
                            }
                        }
                    )
                :   ()
                ),
            );
        },

        'RENAME TO' => sub {
            $r->{functor}= lexer_shift($lx);
            push @{ $r->{arg} }, parse_table($lx);
        },

        'ADD COLUMN' => sub {
            $r->{functor}= lexer_shift($lx);
            if (looking_at($lx, '(', SHIFT)) {
                push @{ $r->{arg} }, parse_list([], $lx, \&parse_column_def, ',');
                return if $lx->{error};
                expect($lx, ')', SHIFT);
            }
            else {
                return unless
                    my $col1= parse_column_name($lx)
                and my $spec= parse_column_spec($lx);
                push @{ $r->{arg} }, $col1, $spec, parse_column_pos_perhaps($lx);
            }
        },

        'ADD' => sub {
            $r->{functor}= lexer_shift($lx);
            push @{ $r->{arg} }, parse_table_constraint($lx);
        },

        ($read_dialect{mysql} ?
            (
                'MODIFY COLUMN' => sub {
                    $r->{functor}= lexer_shift($lx);
                    return unless
                        my $col1= parse_column_name($lx)
                    and my $spec= parse_column_spec($lx);
                    push @{ $r->{arg} }, $col1, $spec, parse_column_pos_perhaps($lx);
                },
                'CHANGE COLUMN' => sub {
                    $r->{functor}= lexer_shift($lx);
                    return unless
                        my $col1= parse_column_name($lx)
                    and my $col2= parse_column_name($lx)
                    and my $spec= parse_column_spec($lx);
                    push @{ $r->{arg} }, $col1, $col2, $spec, parse_column_pos_perhaps($lx);
                },
                'DROP FOREIGN KEY' => sub { # standard SQL: DROP CONSTRAINT
                    $r->{functor}= lexer_shift($lx);
                    return unless
                        my $constraint= parse_constraint($lx);
                    push @{ $r->{arg} }, $constraint;
                },
                'DROP INDEX' => sub {
                    $r->{functor}= lexer_shift($lx);
                    return unless
                        my $index= parse_index($lx);
                    push @{ $r->{arg} }, $index;
                },
            )
        :   ()
        ),
    );
    return if $lx->{error};

    lock_hash %$r;
    return $r;
}

sub parse_stmt_interpol($)
{
    my ($lx)= @_;

    # Some interpols will never be good statements, so issue an error as early
    # as possible (i.e., at compile time instead of at runtime):
    if ($lx->{token}{type} eq 'num' ||
        $lx->{token}{type} eq 'string')
    {
        $lx->{error}= "Expected 'Stmt', but found $lx->{token}{type}";
        return;
    }

    if (! $lx->{token}{type}) {
        $lx->{error}= "Expected 'Stmt', but found $lx->{token}{kind}";
        return;
    }

    if ($lx->{token}{perltype} eq 'hash') {
        $lx->{error}= "Expected scalar or array, but found $lx->{token}{perltype}.";
        return;
    }

    # But some may be:
    my $r= create ($lx, ['Stmt','Interpol'], qw(token));
    $r->{token}= $lx->{token};
    lexer_shift($lx);

    lock_hash %$r;
    return $r;
}

sub parse_select_stmt($)
{
    my ($lx)= @_;
    return parse_choice($lx,
        'SELECT'   => sub { parse_select ($lx) },

        'interpolStmt' => 'interpol',
        'interpol' => sub { parse_stmt_interpol ($lx) },
    );
}

sub parse_stmt($)
{
    my ($lx)= @_;
    return parse_choice($lx,
        'SELECT'   => sub { parse_select ($lx) },
        'INSERT'   => sub { parse_insert ($lx) },
        'UPDATE'   => sub { parse_update ($lx) },
        'DELETE'   => sub { parse_delete ($lx) },

        (map { $_ => 'CREATE TABLE' } @CREATE_TABLE_INITIAL),
        'CREATE TABLE' => sub { parse_create_table($lx) },

        (map { $_ => 'DROP TABLE' } @DROP_TABLE_INITIAL),
        'DROP TABLE' => sub { parse_drop_table($lx) },

        (map { $_ => 'ALTER TABLE' } @ALTER_TABLE_INITIAL),
        'ALTER TABLE' => sub { parse_alter_table($lx) },

        'interpolStmt' => 'interpol',
        'interpol' => sub { parse_stmt_interpol ($lx) },
    );
}

######################################################################
# Perl generation:


## First: creating a list of strings.
#
# The str_ family implements a simple concatenator for strings.  The goal
# is to generate a list of literal strings and Perl code generating strings,
# separated by commas.  For appending such things to the list, there is
# str_append_str() and str_append_perl(), resp.  E.g.:
#
#    my $s= str_new();
#    str_append_str  ($s, "a");
#    str_append_perl ($s, "b");
#
# This would result in the following string:
#
#    'a',b
#
# Appending the comma separator is done automatically.
#
# Further, we need to keep track of the line number.  So there is a function
# str_target_line() for setting the target line number for the next string
# or raw perl code that is appended.  Appending the necessary newline
# characters is done automatically by the str_ functions.
#
# Finally, we need to generate substrings by joining them.  This is done
# with the str_append_join() and str_append_end() functions.  E.g.
#
#    my $s= str_new();
#    str_append_str  ($s, 'a');
#    str_append_join ($s, sep => ':');
#    str_append_perl ($s, 'b');
#    str_target_line ($s, 2);
#    str_append_str  ($s, 'c');
#    str_append_end  ($s);
#    str_append_perl ($s, 'd');
#
# This results in the following string in $s:
#
#    'a',join(':',b,
#    'c'),d
#
# Another possible sub-list structure is a map, which can be added with
# str_append_map() ... str_append_en() functions.  E.g.:
#
#    str_append_str  ($s, 'a');
#    str_append_map  ($s, '$_." DESC"');
#    str_append_perl ($s, 'b');
#    str_append_str  ($s, 'c');
#    str_append_end  ($s);
#    str_append_perl ($s, 'd');
#
# This results in:
#
#    'a',(map{$_." DESC"} b,'c'),d
#
# A str_append_min1() ... str_append_end() block checks that there
# is at least one result in the enclosed list.  This, together with
# _max1_if_scalar, are slightly inefficient and should later be eliminated
# if possible.
#
# str_get_string() returns the current string as composed so far.  If the
# string is empty, an empty list () is returned instead, because the
# empty string is not a valid syntactic empty list in Perl, so it causes
# problems, e.g. after map:
#
#     (map {...} -->HERE<--)
#
# If we insert an empty string -->HERE<--, then we get a syntax error.
#
# The implementation of the str_ family is very straightforward: we have a
# current state that is updated and a string that is appended to accordingly.
sub str_new($)
{
    my ($line_start)= @_;
    my $text= [];
    my $s= {
        buff        => '',
        need_comma  => 0,
        line_is     => 1,
        line_target => 1,
        line_start  => $line_start,
        end_str     => [],  # final str to push, if defined
    };
    lock_keys %$s; # poor-man's bless()
    return $s;
}

sub str_append_raw($$)
{
    my ($s, $text)= @_;
    $s->{buff}.= $text;
    $s->{line_is}+= ($text =~ tr/\n//);
}

sub str_sync_line($)
{
    my ($s)= @_;
    while ($s->{line_is} < $s->{line_target}) {
        str_append_raw ($s, "\n");
    }
}
sub str_target_line($$)
{
    my ($s, $n)= @_;
    my_confess "undefined line number" unless defined $n;
    $s->{line_target}= $n;
}

sub str_append_comma($)
{
    my ($s)= @_;
    if ($s->{need_comma}) {
        str_append_raw ($s, COMMA_STR);
        $s->{need_comma}= 0;
    }
}

sub str_append_perl($$)
{
    my ($s, $perl)= @_;
    if ($perl ne '') {
        str_append_comma($s);
        str_sync_line ($s);
        str_append_raw ($s, $perl);
        $s->{need_comma}= 1;
    }
}

sub str_append_str($$)
{
    my ($s, $contents)= @_;
    str_append_perl ($s, quote_perl($contents));
}

sub str_append_join($%)
{
    my ($s, %opt)= @_;
    $opt{prefix}||=  '';
    $opt{suffix}||=  '';
    $opt{sep}||=     '';

    str_append_comma($s);
    str_sync_line  ($s);
    if ($opt{joinfunc}) {
        # special case: ignore all other settings
        str_append_raw ($s, "$opt{joinfunc}(");
        $s->{need_comma}= 0;
        push @{ $s->{end_str} }, undef;
    }
    elsif ($opt{prefix} eq '' &&
           $opt{suffix} eq '' &&
           (
               $opt{never_empty} ||
               (defined $opt{result0} && $opt{result0} eq '')
           ))
    {
        # simple case 1
        str_append_raw ($s, 'join(');
        str_append_str ($s, $opt{sep});
        $s->{need_comma}= 1;
        push @{ $s->{end_str} }, undef;
    }
    elsif ($opt{sep} eq '' &&
           (
               $opt{never_empty} ||
               (defined $opt{result0} && $opt{result0} eq $opt{prefix}.$opt{suffix})
           ))
    {
        # simple case 2
        str_append_raw ($s, 'join(');
        str_append_str ($s, '');

        if($opt{prefix} ne '') {
            str_append_str ($s, $opt{prefix});
        }

        push @{ $s->{end_str} }, $opt{suffix} || undef;
    }
    else {
        # complex case:
        str_append_raw ($s, __PACKAGE__.'::joinlist(');
        str_append_perl ($s, $s->{line_target} + $s->{line_start});
            # Unfortunately, Perl's caller() is often imprecise for the
            # generated code, and I couldn't find a cause for that to avoid
            # that.  So the original line number is passed long for
            # nicer error messages if necessary.
        str_append_comma($s);
        str_append_str ($s,  $opt{result0});
        str_append_comma($s);
        str_append_str ($s,  $opt{prefix});
        str_append_comma($s);
        str_append_str ($s,  $opt{sep});
        str_append_comma($s);
        str_append_str ($s,  $opt{suffix});
        $s->{need_comma}= 1;
        push @{ $s->{end_str} }, undef;
    }
}

sub str_append_map($$)
{
    my ($s,$code)= @_;
    str_append_comma($s);
    str_sync_line  ($s);
    str_append_raw ($s, "(map{ $code } ");
    $s->{need_comma}= 0;
    push @{ $s->{end_str} }, undef;
}

sub str_append_funcall_begin($$$)
{
    my ($s, $func, $in_list)= @_;
    str_append_comma($s);
    str_sync_line  ($s);
    if ($in_list) {
        str_append_raw ($s, "(map { $func(");
    }
    else {
        str_append_raw ($s, "$func(");
    }
    $s->{need_comma}= 0;
    push @{ $s->{end_str} }, undef;
}

sub str_append_funcall_end($$)
{
    my ($s, $in_list)= @_;
    if ($in_list) {
        str_append_perl ($s, '$_');
        str_append_raw ($s, ') }');
        $s->{need_comma}= 0;
    }
}

sub str_append_funcall($$$)
{
    my ($s, $code, $in_list)= @_;
    str_append_funcall_begin ($s, $code, $in_list);
    str_append_funcall_end   ($s, $in_list);
}

sub str_append_end($)
# Terminator for:
#   str_append_map
#   str_append_funcall
#   str_append_join
{
    my ($s)= @_;
    my $end_str= pop @{ $s->{end_str} };
    if (defined $end_str) {
        str_append_str($s, $end_str);
    }
    str_append_raw ($s, ')');
    $s->{need_comma}= 1;
}

sub str_get_string($)
{
    my ($s)= @_;
    return '()' if $s->{buff} eq '';
    return $s->{buff};
}

# Now start appending more complex things:

sub str_append_thing($$$$);

sub str_append_list($$$;%)
# If you know the list is non-empty, please specify never_empty => 1
# so str_append_join() can optimise.
{
    my ($str, $list, $parens, %opt)= @_;
    local $SIG{__DIE__}= \&my_confess;

    # set line to first element (if any):
    if (scalar(@$list)) {
        str_target_line ($str, $list->[0]{line});
    }

    # joining, delimiters, result if empty:
    str_append_join($str,
        sep      => defined $opt{sep} ? $opt{sep} : COMMA_STR,  # waiting for Perl 5.10: //
        prefix   => $opt{prefix},
        suffix   => $opt{suffix},
        result0  => $opt{result0},
    );

    # map?
    if (my $x= $opt{map}) {
        str_append_comma ($str);
        str_sync_line    ($str);
        str_append_raw   ($str, "map{$x} ");
        $str->{need_comma}= 0;
    };

    # the list:
    for my $l (@$list) {
        str_append_thing ($str, $l, IN_LIST, $parens);
    }

    # end:
    str_append_end($str);
}

sub interpol_set_context ($$);

sub perl_val($$$)
{
    my ($token, $ctxt, $allow)= @_;

    my_confess "Expected ".(english_or \"e_perl, $allow).", but found '$token->{kind}'"
        if $allow &&
           scalar(grep { $token->{kind} eq $_ } flatten($allow)) == 0;

    return switch($token->{kind},
        'ident'    => sub { quote_perl($token->{value}) },
        '*'        => sub { __PACKAGE__.'::ASTERISK'    },
        '?'        => sub { __PACKAGE__.'::QUESTION'    },
        'NULL'     => sub { __PACKAGE__.'::NULL'        },
        'TRUE'     => sub { __PACKAGE__.'::TRUE'        },
        'FALSE'    => sub { __PACKAGE__.'::FALSE'       },
        'UNKNOWN'  => sub { __PACKAGE__.'::UNKNOWN'     },
        'DEFAULT'  => sub { __PACKAGE__.'::DEFAULT'     },
        -default => sub {
            if ($token->{kind} =~ /^interpol/) {
                return interpol_set_context ($token->{value}, $ctxt);
            }
            else {
                my_confess "No idea how to print thing in Perl: ".token_describe($token);
            }
        }
    );
}

sub perl_val_list($$$)
{
    my ($token, $ctxt, $allow)= @_;
    my $s= perl_val($token, $ctxt, $allow);

    if ($token->{perltype} eq 'hash') {
        return "sort keys $s";
    }
    else {
        return $s;
    }
}

sub token_pos($)
{
    my ($token)= @_;
    return "$token->{lx}{file}:".($token->{line} + $token->{lx}{line_start});
}

sub lx_pos($)
{
    my ($lx)= @_;
    return "$lx->{file}:".($lx->{line} + $lx->{line_start});
}

sub croak_unless_scalar($)
{
    my ($token)= @_;
    die token_pos($token).": ".
        "Error: Scalar context, embedded Perl must not be syntactic array or hash.\n"
        if $token->{perltype} eq 'array' || $token->{perltype} eq 'hash';
}

sub str_append_typed($$$$$%)
{
    my ($str, $callback, $ctxt, $thing, $in_list, %opt)= @_;
    my $q_val= perl_val ($thing->{token}, $ctxt, undef);

    if (!$in_list ||
        $thing->{token}{perltype} eq 'scalar')
    {
        croak_unless_scalar ($thing->{token});
        str_append_perl ($str, __PACKAGE__."::${callback}($q_val)");
    }
    elsif ($thing->{token}{perltype} eq 'hash') {
        if ($opt{hash}) {
            str_append_perl ($str, __PACKAGE__."::${callback}_hash($q_val)");
        }
        elsif ($opt{hashkeys}) {
            str_append_map  ($str, __PACKAGE__."::${callback}(\$_)");
            str_append_perl ($str, "sort keys $q_val");
            str_append_end  ($str);
        }
        else {
            die token_pos($thing->{token}).": Error: Hashes are not allowed here.\n";
        }
    }
    else {
        str_append_map  ($str, __PACKAGE__."::${callback}(\$_)");
        str_append_perl ($str, $q_val);
        str_append_end  ($str);
    }
}

sub is_multicol($);
sub is_multicol($)
{
    my ($thing) = @_;
    return switch ($thing->{kind},
        'ExprAs' => sub{
            return is_multicol($thing->{expr});
        },
        'Expr' => sub {
            if ($thing->{type} eq 'column') {
                return is_multicol($thing->{arg});
            }
            return 0;
        },
        'Column' => sub {
            return is_multicol($thing->{ident_chain}[-1]);
        },
        '*' => sub {
            return 1;
        },
        'interpol' => sub {
            return $thing->{perltype} ne 'scalar';
        },
        -default => sub {
            return 0;
        },
    );
}

# Contexts for the different sql{...} interpolation blocks:
my %ident_context= (
    'Column' => {
        1 => [ 'Column' ],
        2 => [ 'Table', 'none' ],
    },
);

sub str_append_ident_chain($$$@)
{
    my ($str, $in_list, $family, @token)= @_;
    my $func= lc($family);

    my $ctxt= $ident_context{$family}{scalar @token} ||
              (scalar(@token) == 1 ?
                  [ $family ]
              :   [ map 'none', 1..scalar(@token) ]
              );

    my $n= scalar(@token);
    my @non_scalar_i= grep { $token[$_]{perltype} ne 'scalar' } 0..$n-1;

    if (!$in_list ||
        scalar(@non_scalar_i) == 0)
    {
        for my $a (@token) { croak_unless_scalar ($a); }
        my $q_vals= join(",",
                        map
                        { perl_val($token[$_], $ctxt->[$_], undef) }
                        0..$n-1
                    );
        str_append_perl ($str, __PACKAGE__."::${func}${n}($q_vals)");
    }
    elsif (scalar(@non_scalar_i) == 1) {
        str_append_map ($str,
            __PACKAGE__."::${func}${n}(".
                join(",",
                    map {
                        ($token[$_]{perltype} eq 'scalar' ?
                            perl_val($token[$_], $ctxt->[$_], undef)
                        :   '$_'
                        )
                    }
                    0..$n-1
                ).
            ")"
        );
        my ($i)= @non_scalar_i;
        str_append_perl ($str, perl_val_list($token[$i], $ctxt->[$i], undef));
        str_append_end  ($str);
    }
    else {
        my $f_ident= "${func}${n}_".join('', map{ $_->{perltype} eq 'scalar' ? 1 : 'n' } @token);
        str_append_perl ($str,
            __PACKAGE__."::$f_ident(".
                join(",",
                    map {
                        ($token[$_]{perltype} eq 'scalar' ?
                            perl_val($token[$_], $ctxt->[$_], undef)
                        :   '['.perl_val_list($token[$_], $ctxt->[$_], undef).']'
                        )
                    }
                    0..$n-1
                ).
            ")"
        );
    }
}

sub str_append_limit ($$$)
{
    my ($str, $limit_cnt, $limit_offset)= @_;

    if (defined $limit_cnt || defined $limit_offset) {
        my $limit_cnt_str= 'undef';
        if ($limit_cnt) {
            $limit_cnt_str= perl_val($limit_cnt, 'Expr', ['interpol', 'interpolExpr', '?']);
        }

        my $limit_offset_str= 'undef';
        if ($limit_offset) {
            $limit_offset_str= perl_val($limit_offset, 'Expr', ['interpol', 'interpolExpr', '?']);
        }

        str_append_perl ($str, __PACKAGE__."::limit($limit_cnt_str, $limit_offset_str)");
    }
}

sub str_append_parens($$$)
{
    my ($str, $thing, $in_list)= @_;
    if ($in_list) {
        str_append_map ($str, "\"(\$_)\"");
        str_append_thing ($str, $thing, $in_list, NO_PARENS);
        str_append_end ($str);
    }
    else {
        str_append_join  ($str, prefix => '(', suffix => ')', never_empty => 1);
        str_append_thing ($str, $thing, $in_list, NO_PARENS);
        str_append_end   ($str);
    }
}

sub str_append_table_key($$$)
{
    my ($str, $thing, $type)= @_;
    str_append_join ($str, sep => ' ');
    if (my $x= $thing->{constraint}) {
        str_append_str   ($str, 'CONSTRAINT');
        str_append_thing ($str, $x, NOT_IN_LIST, NO_PARENS);
    }
    str_append_str  ($str, $type);
    if (my $x= $thing->{index_type}) {
        str_append_str ($str, "USING $x");
    }
    str_append_list ($str, $thing->{column}, NO_PARENS, prefix=>'(', suffix=>')');
    for my $o (@{ $thing->{index_option} }) {
        str_append_thing ($str, $o, IN_LIST, NO_PARENS);
    }
    if (my $x= $thing->{reference}) {
        str_append_thing ($str, $x, NOT_IN_LIST, NO_PARENS);
    }
    str_append_end ($str);
}

# str_append_thing() converts a recursive representation of the parsed SQL
# structure into a Perl string that generates a list of either string
# representations of the SQL structure (in good SQL syntax), or blessed
# objects of the correct type.
#
# The result of this function is then used to wrap and bless the string
# or objects appropriately according to which kind of SQL structure the
# string contains (statement, expressions, column, etc.).
#
# In detail, str_append_thing() appends pieces of Perl code to $str, that
# each represent a small piece of the SQL command.
#
# Each invocation of str_append_thing appends code to $str that generates
# exactly the amount of objects that are represented.  This might seem
# obvious, but since $str is actually a comma separated list, this
# requirement means that if multiple pieces are pushed for a single
# thing, then a join(...) must enclose and group these.  E.g.
# the code that generates a SELECT statement from scratch appends
# several pieces of code to $str, and to make only one string, a
# join() is generated.
#
sub str_append_thing($$$$)
{
    my ($str, $thing, $in_list, $parens)= @_;
    local $SIG{__DIE__}= \&my_confess;

    # simple things to append:
    unless (defined $thing) {
        str_append_perl ($str, 'undef');
        return;
    }
    unless (ref $thing) {
        str_append_str ($str, $thing);
        return;
    }
    if (ref($thing) eq 'ARRAY') {
        str_append_list ($str, $thing, NO_PARENS, prefix => '(', suffix => ')');
        return;
    }

    # normal structure:
    str_target_line ($str, $thing->{line});

    switch($thing->{kind},
        'Stmt' => sub {
            switch($thing->{type},
                'Select' => sub {
                    # find out type name depending on number of columns:
                    my $type_name = 'SelectStmt';
                    if (scalar(@{ $thing->{expr_list} }) == 1) {
                        unless (is_multicol($thing->{expr_list}[0])) {
                            $type_name = 'SelectStmtSingle';
                        }
                    }

                    # generate:
                    str_append_funcall ($str, __PACKAGE__.'::'.$type_name.'->obj', $in_list);
                    str_append_join ($str, never_empty => 1);

                    str_append_list ($str, $thing->{expr_list}, NO_PARENS,
                        prefix => join(' ', 'SELECT',
                                            @{ $thing->{opt_front} }
                                  ).' '
                    );

                    if (my $x= $thing->{from}) {
                        str_append_list ($str, $x, NO_PARENS, prefix => ' FROM ');

                        if (my $x= $thing->{join}) {
                            if (@$x) {
                                str_append_map ($str, '" $_" ');
                                for my $xi (@$x) {
                                    str_append_thing ($str, $xi, IN_LIST, NO_PARENS);
                                }
                                str_append_end ($str);
                            }
                        }
                        if (my $x= $thing->{where}) {
                            str_target_line ($str, $x->{line});
                            str_append_str   ($str, ' WHERE ');
                            str_append_thing ($str, $x, NOT_IN_LIST, NO_PARENS);
                        }
                        if (my $x= $thing->{group_by}) {
                            my $suffix= '';
                            if ($thing->{group_by_with_rollup}) {
                                $suffix= ' WITH ROLLUP';
                            }
                            str_append_list ($str, $x, NO_PARENS,
                                prefix  => ' GROUP BY ',
                                suffix  => $suffix,
                                result0 => '',
                            );
                        }
                        if (my $x= $thing->{having}) {
                            str_target_line ($str, $x->{line});
                            str_append_str   ($str, ' HAVING ');
                            str_append_thing ($str, $x, NOT_IN_LIST, NO_PARENS);
                        }
                        if (my $x= $thing->{order_by}) {
                            str_append_list ($str, $x, NO_PARENS,
                                prefix  => ' ORDER BY ',
                                result0 => ''
                            );
                        }
                        str_append_limit ($str, $thing->{limit_cnt}, $thing->{limit_offset});

                        str_append_str ($str, join('', map " $_", @{ $thing->{opt_back} }));
                    }

                    str_append_end ($str);
                    str_append_end ($str);
                },
                'Delete' => sub {
                    str_append_funcall ($str, __PACKAGE__.'::Stmt->obj', $in_list);
                    str_append_join ($str, never_empty => 1);

                    str_append_list ($str, $thing->{from}, NO_PARENS,
                        prefix =>
                            join(' ',
                                'DELETE',
                                @{ $thing->{opt_front} },
                                'FROM',
                                @{ $thing->{from_opt_front} },
                            ).' '
                    );

                    if (my $x= $thing->{using}) {
                        str_append_list ($str, $x, NO_PARENS,
                            prefix => ' USING ',
                            result0 => ''
                        );
                    }

                    if (my $x= $thing->{join}) {
                        if (@$x) {
                            str_append_map ($str, '" $_" ');
                            for my $xi (@$x) {
                                str_append_thing ($str, $xi, IN_LIST, NO_PARENS);
                            }
                            str_append_end ($str);
                        }
                    }
                    if (my $x= $thing->{where}) {
                        str_target_line ($str, $x->{line});
                        str_append_str   ($str, ' WHERE ');
                        str_append_thing ($str, $x, NOT_IN_LIST, NO_PARENS);
                    }
                    if (my $x= $thing->{order_by}) {
                        str_append_list ($str, $x, NO_PARENS,
                            prefix  => ' ORDER BY ',
                            result0 => ''
                        );
                    }
                    str_append_limit ($str, $thing->{limit_cnt}, $thing->{limit_offset});

                    str_append_end ($str);
                    str_append_end ($str);
                },
                'Insert' => sub {
                    str_append_funcall ($str, __PACKAGE__.'::Stmt->obj', $in_list);
                    str_append_join ($str, never_empty => 1);

                    str_append_str ($str,
                        join(' ',
                            'INSERT',
                            @{ $thing->{opt_front} },
                            'INTO',
                        ).' '
                    );

                    str_append_thing ($str, $thing->{into}, NOT_IN_LIST, NO_PARENS);

                    if (my $col= $thing->{column}) {
                        str_append_list ($str, $col, NO_PARENS, prefix => ' (', suffix => ')');
                    }

                    if (my $val= $thing->{value}) {
                        str_append_str  ($str, ' VALUES ');
                        str_append_list ($str, $val, NO_PARENS);
                    }
                    elsif (my $set= $thing->{set}) {
                        str_append_funcall ($str, __PACKAGE__."::set2values", NOT_IN_LIST);
                        for my $l (@$set) {
                            str_append_thing ($str, $l, IN_LIST, NO_PARENS);
                        }
                        str_append_end ($str);
                    }
                    elsif (my $sel= $thing->{select}) {
                        str_append_str   ($str, ' ');
                        str_append_thing ($str, $sel, NOT_IN_LIST, NO_PARENS);
                    }
                    elsif ($thing->{default_values}) {
                        str_append_str ($str, ' DEFAULT VALUES');
                    }
                    else {
                        die;
                    }

                    if (my $x= $thing->{duplicate_update}) {
                        str_append_str  ($str, ' ON DUPLICATE KEY UPDATE ');
                        str_append_list ($str, $x, NO_PARENS, map => __PACKAGE__.'::assign($_)');
                    }

                    str_append_end ($str);
                    str_append_end ($str);
                },
                'Update' => sub {
                    str_append_funcall ($str, __PACKAGE__.'::Stmt->obj', $in_list);
                    str_append_join ($str, never_empty => 1);

                    str_append_list ($str, $thing->{table}, NO_PARENS,
                        prefix => join(' ', 'UPDATE',
                                            @{ $thing->{opt_front} }
                                  ).' '
                    );

                    if (my $x= $thing->{from}) {
                        str_append_list ($str, $x, NO_PARENS,
                            prefix => ' FROM ',
                            result0 => ''
                        );
                    }
                    if (my $x= $thing->{join}) {
                        if (@$x) {
                            str_append_map ($str, '" $_" ');
                            for my $xi (@$x) {
                                str_append_thing ($str, $xi, IN_LIST, NO_PARENS);
                            }
                            str_append_end ($str);
                        }
                    }
                    if (my $x= $thing->{set}) {
                        str_append_list ($str, $x, NO_PARENS,
                            prefix => ' SET ',
                            result0 => ''  # this is an error.
                        );
                    }
                    if (my $x= $thing->{where}) {
                        str_target_line ($str, $x->{line});
                        str_append_str   ($str, ' WHERE ');
                        str_append_thing ($str, $x, NOT_IN_LIST, NO_PARENS);
                    }
                    if (my $x= $thing->{order_by}) {
                        str_append_list ($str, $x, NO_PARENS,
                            prefix  => ' ORDER BY ',
                            result0 => ''
                        );
                    }
                    str_append_limit ($str, $thing->{limit_cnt}, $thing->{limit_offset});

                    str_append_end ($str);
                    str_append_end ($str);
                },
                'CreateTable' => sub {
                    str_append_funcall ($str, __PACKAGE__.'::Stmt->obj', $in_list);
                    str_append_join ($str, never_empty => 1);

                    str_append_str ($str, "$thing->{subtype} ");
                    if ($thing->{if_not_exists}) {
                        str_append_str ($str, 'IF NOT EXISTS ');
                    }
                    str_append_thing ($str, $thing->{table}, NOT_IN_LIST, NO_PARENS);

                    my @tabspec= (
                        @{ $thing->{column_def} },
                        @{ $thing->{tabconstr} }
                    );
                    str_append_list ($str, \@tabspec, NO_PARENS,
                        result0 => '',
                        prefix  => ' (',
                        suffix  => ')'
                    );

                    str_append_list ($str, $thing->{tableopt}, NO_PARENS,
                        result0 => '',
                        prefix  => ' ',
                        sep     => ' ',
                    );

                    if (my $x= $thing->{select}) {
                        str_append_str   ($str, ' AS ');
                        str_append_thing ($str, $x, NOT_IN_LIST, NO_PARENS);
                    }

                    str_append_end ($str);
                    str_append_end ($str);
                },
                'DropTable' => sub {
                    str_append_funcall ($str, __PACKAGE__.'::Stmt->obj', $in_list);
                    str_append_join ($str, never_empty => 1);

                    str_append_str ($str, "$thing->{subtype} ");
                    if ($thing->{if_exists}) {
                        str_append_str ($str, 'IF EXISTS ');
                    }
                    str_append_list ($str, $thing->{table}, NO_PARENS);

                    if (my $x= $thing->{cascade}) {
                        str_append_str ($str, " $x");
                    }
                    str_append_end ($str);
                    str_append_end ($str);
                },
                'AlterTable' => sub {
                    str_append_funcall ($str, __PACKAGE__.'::Stmt->obj', $in_list);
                    str_append_join ($str, never_empty => 1);

                    str_append_str ($str, "$thing->{subtype} ");
                    if ($thing->{only}) {
                        str_append_str ($str, 'ONLY ');
                    }
                    str_append_thing ($str, $thing->{table}, NOT_IN_LIST, NO_PARENS);

                    str_append_join ($str, sep => ' ', prefix => ' ');
                    for my $l ($thing->{functor}, @{ $thing->{arg} }) {
                        str_append_thing ($str, $l, NOT_IN_LIST, NO_PARENS);
                    }
                    str_append_end ($str);

                    str_append_end ($str);
                    str_append_end ($str);
                },
                'Interpol' => sub {
                    str_append_typed ($str, 'stmt', 'Stmt', $thing, $in_list);
                },
            );
        },

        'TableOption' => sub {
            switch ($thing->{type},
               'interpol' => sub {
                    str_append_typed ($str, 'tableopt', 'TableOption', $thing, $in_list);
               },
               'literal' => sub {
                    str_append_join  ($str, sep => ' ');
                    str_append_str   ($str, $thing->{name});
                    str_append_thing ($str, $thing->{value}, NOT_IN_LIST, NO_PARENS);
                    str_append_end   ($str);
               }
            );
        },

        'Keyword' => sub {
            str_append_str ($str, $thing->{keyword});
        },

        'Join' => sub {
            if ($thing->{type} eq 'interpol') {
                str_append_typed ($str, 'joinclause', 'Join', $thing, $in_list);
            }
            else {
                str_append_join ($str, result0 => '');

                if ($thing->{natural}) {
                    if ($thing->{type} eq 'INNER') {
                        str_append_str ($str, "NATURAL JOIN ");
                    }
                    else {
                        str_append_str ($str, "NATURAL $thing->{type} JOIN ");
                    }
                }
                else {
                    str_append_str ($str, "$thing->{type} JOIN ");
                }

                str_append_list ($str, $thing->{table}, NO_PARENS);

                if (my $on= $thing->{on}) {
                    str_append_str ($str, ' ON ');
                    str_append_thing ($str, $on, NOT_IN_LIST, NO_PARENS);
                }
                elsif (my $using= $thing->{using}) {
                    str_append_str  ($str, ' USING (');
                    str_append_list ($str, $using, NO_PARENS);
                    str_append_str  ($str, ')');
                };

                str_append_end ($str);
            }
        },

        'Table' => 'Column',
        'CharSet' => 'Column',
        'Collate' => 'Column',
        'Index' => 'Column',
        'Constraint' => 'Column',
        'Transliteration' => 'Column',
        'Transcoding' => 'Column',
        'Engine' => 'Column',
        'Column' => sub {
            str_append_ident_chain ($str, $in_list, $thing->{kind}, @{ $thing->{ident_chain} });
        },

        'TableAs' => sub {
            if (my $x= $thing->{as}) {
                str_append_join  ($str, sep => ' AS ', never_empty => 1);
                str_append_thing ($str, $thing->{table}, NOT_IN_LIST, NO_PARENS);
                str_append_thing ($str, $x, NOT_IN_LIST, NO_PARENS);
                str_append_end   ($str);
            }
            else {
                str_append_thing ($str, $thing->{table}, $in_list, NO_PARENS);
            }
        },

        'ExprAs' => sub {
            if (my $x= $thing->{as}) {
                str_append_join  ($str, sep => ' AS ', never_empty => 1);
                str_append_thing ($str, $thing->{expr}, NOT_IN_LIST, NO_PARENS);
                str_append_thing ($str, $x, NOT_IN_LIST, NO_PARENS);
                str_append_end   ($str);
            }
            else {
                str_append_thing ($str, $thing->{expr}, $in_list, $parens);
            }
        },
        'Order' => sub {
            switch($thing->{type},
                'interpol' => sub {
                    if ($thing->{desc}) {
                        str_append_typed ($str, 'desc', 'Order', $thing, $in_list, hashkeys => 1);
                    }
                    else {
                        str_append_typed ($str, 'asc', 'Order', $thing, $in_list, hashkeys => 1);
                    }
                },
                'expr' => sub {
                    if ($thing->{desc}) {
                        str_append_map   ($str, __PACKAGE__.'::desc($_)');
                        str_append_thing ($str, $thing->{expr}, $in_list, NO_PARENS);
                        str_append_end   ($str);
                    }
                    else {
                        str_append_thing ($str, $thing->{expr}, $in_list, NO_PARENS);
                    }
                },
            );
        },
        'TypeList' => sub {
            switch($thing->{type},
                'interpol' => sub {
                    str_append_typed ($str, 'typelist', 'Type', $thing, $in_list);
                },

                'explicit' => sub {
                    str_append_list ($str, $thing->{arg}, NO_PARENS, prefix => '(', suffix => ')');
                        # may not be empty!
                },
            );
        },
        'Type' => sub {
            switch ($thing->{type},
                'interpol' => sub {
                    str_append_typed ($str, 'type', 'Type', $thing, $in_list);
                },
                'base' => sub {
                    str_append_perl ($str, __PACKAGE__.'::Type->new()');
                },
            );
        },
        'TypePost' => sub {
            return str_append_parens ($str, $thing, NOT_IN_LIST)
                if $parens;

            str_append_funcall_begin ($str, __PACKAGE__.'::type_'.$thing->{functor}, $in_list);
            for my $arg (@{ $thing->{arg} }) {
                str_append_thing ($str, $arg, NOT_IN_LIST, NO_PARENS);
            }
            str_append_funcall_end ($str, $in_list);
            str_append_thing ($str, $thing->{base}, $in_list, NO_PARENS);
            str_append_end ($str);
        },
        'ColumnDef' => sub {
            str_append_join  ($str, sep => ' ');
            str_append_thing ($str, $thing->{name},        NOT_IN_LIST, NO_PARENS);
            str_append_thing ($str, $thing->{column_spec}, NOT_IN_LIST, NO_PARENS);
            str_append_end   ($str);
        },

        'ColumnSpec' => sub {
            switch ($thing->{type},
                'interpol' => sub {
                    str_append_typed ($str, 'colspec', 'ColumnSpec', $thing, $in_list);
                },
                'base' => sub {
                    str_append_funcall ($str, __PACKAGE__.'::ColumnSpec->new', $in_list);
                    str_append_thing ($str, $thing->{datatype}, $in_list, NO_PARENS);
                    str_append_end ($str);
                }
            );
        },
        'ColumnSpecPost' => sub {
            return str_append_parens ($str, $thing, NOT_IN_LIST)
                if $parens;

            str_append_funcall_begin ($str, __PACKAGE__.'::colspec_'.$thing->{functor}, $in_list);
            for my $arg (@{ $thing->{arg} }) {
                str_append_thing ($str, $arg, NOT_IN_LIST, NO_PARENS);
            }
            str_append_funcall_end ($str, $in_list);
            str_append_thing ($str, $thing->{base}, $in_list, NO_PARENS);
            str_append_end ($str);
        },

        'TableConstraint' => sub {
            switch($thing->{type},
                'primary_key' => sub {
                    str_append_table_key ($str, $thing, 'PRIMARY KEY');
                },
                'unique' => sub {
                    str_append_table_key ($str, $thing, 'UNIQUE');
                },
                'fulltext' => sub {
                    str_append_table_key ($str, $thing, 'FULLTEXT');
                },
                'spatial' => sub {
                    str_append_table_key ($str, $thing, 'SPATIAL');
                },
                'index' => sub {
                    str_append_table_key ($str, $thing, 'INDEX');
                },
                'foreign_key' => sub {
                    str_append_table_key ($str, $thing, 'FOREIGN KEY');
                },
            );
        },

        'IndexOption' => sub {
            switch($thing->{type},
                'using' => sub {
                    str_append_str ($str, "USING $thing->{arg}");
                }
            );
        },

        'References' => sub {
            # table column match on_delete on_update));
            str_append_join  ($str, sep => ' ',
                prefix => 'REFERENCES ',
                suffix =>
                    join('', map { " $_" }
                        ($thing->{match} ?
                            ('MATCH', $thing->{match})
                        :   ()
                        ),
                        ($thing->{on_delete} ?
                            ('ON DELETE', $thing->{on_delete})
                        :   ()
                        ),
                        ($thing->{on_update} ?
                            ('ON UPDATE', $thing->{on_update})
                        :   ()
                        ),
                    )
            );
            str_append_thing ($str, $thing->{table}, NOT_IN_LIST, NO_PARENS);
            str_append_list  ($str, $thing->{column}, NO_PARENS,
                 prefix => '(', suffix => ')', result0 => '');
            str_append_end   ($str);
        },

        'CharUnit' => sub {
            str_append_str ($str, $thing->{name});
        },

        'ExprList' => sub {
            switch($thing->{type},
                'interpol' => sub {
                    str_append_typed ($str, 'exprlist', 'Expr', $thing, $in_list);
                },

                'explicit' => sub {
                    str_append_list ($str, $thing->{arg}, NO_PARENS, prefix => '(', suffix => ')');
                        # may not be empty!
                },
            );
        },
        'ExprEmpty' => sub {
            # Append an empty string.  Must have an operand here, otherwise
            # parameters might get mixed up.
            str_append_str($str, '');
        },
        'Check' => sub {
            str_append_join  ($str, joinfunc => __PACKAGE__.'::Check->obj');
            str_append_thing ($str, $thing->{expr}, NOT_IN_LIST, NO_PARENS);
            str_append_end   ($str);
        },
        'Expr' => sub {
            switch($thing->{type},
                'limit' => sub {
                    my $limit_cnt_str= perl_val($thing->{arg}, 'Expr',
                                             ['interpol', 'interpolExpr', '?']);
                    str_append_perl ($str, __PACKAGE__."::limit_number($limit_cnt_str)");
                },
                'interpol' => sub {
                    my $func= $thing->{maybe_check} ?
                                   'expr_or_check'
                              : ($thing->{token}{type} eq 'num' ||
                                 $thing->{token}{type} eq 'string' ||
                                 !$parens) ?
                                   'expr'
                              :    'exprparen';
                    str_append_typed ($str, $func, 'Expr', $thing, $in_list, hash => 1);
                },
                'column' => sub {
                    str_append_thing ($str, $thing->{arg}, $in_list, NO_PARENS);
                },
                '()' => sub {
                    str_append_thing ($str, $thing->{arg}, $in_list, PARENS);
                },
                'subquery' => sub {
                    str_append_funcall ($str, __PACKAGE__.'::subquery', $in_list);
                    str_append_thing ($str, $thing->{arg}, $in_list, NO_PARENS);
                    str_append_end   ($str);
                },
                'prefix1' => sub {
                    $in_list= NOT_IN_LIST; # just to be sure
                    return str_append_parens ($str, $thing, NOT_IN_LIST)
                        if $parens;
                    die 'Expected exactly 1 argument' unless scalar(@{ $thing->{arg} }) == 1;

                    str_append_join ($str,
                        prefix => "$thing->{functor}{value} ",
                        never_empty => 1
                    );
                    str_append_thing ($str, $thing->{arg}[0], NOT_IN_LIST, PARENS);
                    str_append_end ($str);
                },
                'prefixn' => sub {
                    $parens= NO_PARENS; # just to be sure
                    die 'Expected exactly 1 argument' unless scalar(@{ $thing->{arg} }) == 1;

                    if ($in_list) {
                        str_append_map ($str, "'$thing->{functor}{value} '.(\$_)");
                    }
                    else {
                        str_append_join ($str,
                            prefix => "$thing->{functor}{value} ",
                            never_empty => 1
                        );
                    }
                    str_append_thing ($str, $thing->{arg}[0], $in_list, PARENS);
                    str_append_end ($str);
                },

                'infix2' => sub {
                    $in_list= NOT_IN_LIST; # just to be sure
                    return str_append_parens ($str, $thing, NOT_IN_LIST)
                        if $parens;

                    my $f= $thing->{functor};
                    str_append_join  ($str, joinfunc => __PACKAGE__.'::Infix->obj');
                    str_append_str   ($str, $thing->{functor}{value});
                    str_append_thing ($str, $thing->{arg}[0], NOT_IN_LIST, PARENS);
                    str_append_thing ($str, $thing->{arg}[1], NOT_IN_LIST, PARENS);
                    str_append_end   ($str);
                },

                'infix23' => 'infix3',
                'infix3' => sub {
                    $in_list= NOT_IN_LIST; # just to be sure
                    return str_append_parens ($str, $thing, NOT_IN_LIST)
                        if $parens;

                    my $f= $thing->{functor};
                    str_append_join  ($str, never_empty => 1);
                    str_append_thing ($str, $thing->{arg}[0], NOT_IN_LIST, PARENS);
                    str_append_str   ($str, " $thing->{functor}{value} ");
                    str_append_thing ($str, $thing->{arg}[1], NOT_IN_LIST, PARENS);
                    if (scalar(@{ $thing->{arg} }) == 3) {
                        str_append_str   ($str, " $thing->{functor}{value2} ");
                        str_append_thing ($str, $thing->{arg}[2], NOT_IN_LIST, PARENS);
                    }
                    str_append_end   ($str);
                },

                # prefix and suffix allow bitwise application:
                # Currently not supported via _prefix() and _suffix() helper
                # functions, but may be later.  (Needs only a little rewrite
                # here.  The helper functions don't need to be changed.)
                'prefix()' => 'prefix',
                'suffix' => 'prefix',
                'prefix' => sub {
                    if ($thing->{type} eq 'prefix()') { # for AND() and OR() as functors
                        $in_list = NOT_IN_LIST;
                    }
                    my $f= $thing->{functor};
                    my $fk= $functor_kind{$f->{type} || ''}
                            or die "Expected $thing->{type} to be mapped by \%functor_kind";
                    if ($in_list) {
                        my $qt= quote_perl($f->{value});
                        str_append_map ($str, __PACKAGE__."::_".$fk."($qt,".($parens?1:0).",\$_)");
                        for my $l (@{ $thing->{arg} }) {
                            str_append_thing ($str, $l, IN_LIST, PARENS);
                        }
                        str_append_end ($str);
                    }
                    else {
                        str_append_funcall($str, __PACKAGE__."::_".$fk, NOT_IN_LIST);
                        str_append_thing ($str, $f->{value}, IN_LIST, NO_PARENS);
                        str_append_thing ($str, $parens?1:0, IN_LIST, NO_PARENS);
                        for my $l (@{ $thing->{arg} }) {
                            str_append_thing ($str, $l, IN_LIST, PARENS);
                        }
                        str_append_end ($str);
                    }
                },

                # funcall and infix use args inline if they are in list context.
                # They are handled by _prefix() and _suffix() helper functions in order
                # to allow dialect conversion:
                'funcall' => 'infix()',
                'infix()' => sub {
                    $in_list= NOT_IN_LIST; # just to be sure
                    my $f= $thing->{functor};
                    my $fk= $functor_kind{$f->{type} || ''}
                            or die 'Expected $thing->{type} to be mapped by %functor_kind';

                    str_append_funcall($str, __PACKAGE__."::_".$fk, NOT_IN_LIST);
                    str_append_thing ($str, $f->{value}, IN_LIST, NO_PARENS);
                    str_append_thing ($str, $parens?1:0, IN_LIST, NO_PARENS);
                    for my $l (@{ $thing->{arg} }) {
                        str_append_thing ($str, $l, IN_LIST, PARENS);
                    }
                    str_append_end ($str);
                },

                'funcsep' => sub {
                    $in_list= NOT_IN_LIST; # just to be sure
                    str_append_join ($str, never_empty => 1, sep => ' ');
                    str_append_str  ($str, "$thing->{functor}{value}(");
                    for my $t (@{ $thing->{arg} }) {
                        str_append_thing ($str, $t, NOT_IN_LIST, NO_PARENS);
                    }
                    str_append_end  ($str);
                },

                'case' => sub {
                    $in_list= NOT_IN_LIST; # just to be sure

                    # FIXME (maybe): we add parens here, so if there are no
                    # when-then pairs at all and only the else part is printed,
                    # it will get parens, too, no matter what.  That's ok,
                    # since it's a non-standard, marginal special case.
                    return str_append_parens ($str, $thing, NOT_IN_LIST)
                        if $parens;

                    my $sw= $thing->{switchval};
                    if ($sw) {
                        str_append_funcall ($str, __PACKAGE__."::caseswitch", NOT_IN_LIST);
                        str_append_thing ($str, $sw, NOT_IN_LIST, NO_PARENS);
                    }
                    else {
                        str_append_funcall ($str, __PACKAGE__."::casecond", NOT_IN_LIST);
                    }

                    if (my $e= $thing->{otherwise}) {
                        str_append_thing ($str, $e, NOT_IN_LIST, NO_PARENS);
                    }
                    else {
                        str_append_str ($str, 'NULL');
                    }

                    for my $wh (@{ $thing->{arg} }) {
                        if (ref($wh) eq 'ARRAY') {
                            my ($when,$expr)= @$wh;
                            str_append_funcall ($str, __PACKAGE__.'::whenthen', NOT_IN_LIST);
                            str_append_thing ($str, $when, NOT_IN_LIST, NO_PARENS);
                            str_append_thing ($str, $expr, NOT_IN_LIST, NO_PARENS);
                            str_append_end ($str);
                        }
                        else {
                            die 'expected array';
                        }
                    }

                    str_append_end ($str);
                },
            );
        },

        'ColumnName' => sub {
            switch ($thing->{type},
                'interpol' => 'ident',
                'ident' => sub {
                    str_append_typed ($str, 'colname', 'none', $thing, $in_list, hashkeys => 1);
                }
            );
        },

        'ColumnIndex' => sub {
            if (defined $thing->{length} || $thing->{desc}) {
                str_append_join  ($str, sep => ' ');
                str_append_thing ($str, $thing->{name}, NOT_IN_LIST, NO_PARENS);
                if (defined $thing->{length}) {
                    str_append_join  ($str, prefix => '(', suffix => ')');
                    str_append_thing ($str, $thing->{length}, NOT_IN_LIST, NO_PARENS);
                    str_append_end   ($str);
                }
                if ($thing->{desc}) {
                    str_append_str ($str, 'DESC');
                }
                str_append_end   ($str);
            }
            else {
                str_append_thing ($str, $thing->{name}, $in_list, $parens);
            }
        },

        'TableName' => sub {
            switch ($thing->{type},
                'interpol' => 'ident',
                'ident' => sub {
                    str_append_typed ($str, 'tabname', 'none', $thing, $in_list, hashkeys => 1);
                }
            );
        },

        'Fetch' => 'Do',
        'Do' => sub {
            str_append_thing ($str, $thing->{stmt}, $in_list, $parens);
        },
    );
}

sub to_perl($$\@)
{
    my ($line_start, $kind, $things)= @_;
    my $str= str_new($line_start);
    for my $thing (@$things) {
        str_append_thing ($str, $thing, IN_LIST, NO_PARENS);
    }
    my $text= str_get_string($str);
    return "do{".__PACKAGE__."::_max1_if_scalar map{".__PACKAGE__."::${kind}->obj(\$_)} $text}",
}

######################################################################
# Top-level parser interface:

sub lx_die_perhaps($;$)
{
    my $lx= shift;

    # if a test value is given, check that it is defined:
    if (scalar(@_)) {
        my ($check_val)= @_;
        unless (defined $check_val) {
            $lx->{error}||= 'Unknown error';
        }
    }

    # if an error is set, then die:
    if ($lx->{error}) {
        die lx_pos($lx).": Error: $lx->{error}\n";
    }
}


sub parse_1_or_list($$$;$)
{
    my ($lx, $parse_elem, $list_sep, $end)= @_;
    my $r= parse_list([], $lx, $parse_elem, $list_sep, $end);
    lx_die_perhaps($lx, $r);
    return @$r;
}

sub parse_0_try_list($$)
{
    my ($lx, $parse_elem)= @_;
    my $r= parse_try_list([], $lx, $parse_elem);
    lx_die_perhaps($lx, $r);
    return @$r;
}

sub parse_stmt_list($)
{
    parse_1_or_list ($_[0], \&parse_stmt,  ';', ['}',')',']']);
}

sub parse_do_stmt($)
{
    my ($lx) = @_;
    map {
        my $stmt = $_;
        my $r = create($lx, 'Do', qw(stmt));
        $r->{stmt} = $stmt;
        $r;
    }
    parse_stmt_list($lx);
}

sub parse_fetch_stmt($)
{
    my ($lx) = @_;
    map {
        my $stmt = $_;
        my $r = create($lx, 'Fetch', qw(stmt));
        $r->{stmt} = $stmt;
        $r;
    }
    parse_stmt_list($lx);
}

my %top_parse= (
    # pure parse actions:
    'Stmt'            => \&parse_stmt_list,

    'Join'            => sub { parse_0_try_list($_[0], \&parse_join)                 },
    'TableOption'     => sub { parse_0_try_list($_[0], \&parse_table_option)         },

    'Expr'            => sub { parse_1_or_list ($_[0], \&parse_expr,            ',') },
    'Check'           => sub { parse_1_or_list ($_[0], \&parse_check,           ',') },
    'Type'            => sub { parse_1_or_list ($_[0], \&parse_type,            ',') },
    'Column'          => sub { parse_1_or_list ($_[0], \&parse_column,          ',') },
    'Table'           => sub { parse_1_or_list ($_[0], \&parse_table,           ',') },
    'Index'           => sub { parse_1_or_list ($_[0], \&parse_index,           ',') },
    'CharSet'         => sub { parse_1_or_list ($_[0], \&parse_charset,         ',') },
    'Collate'         => sub { parse_1_or_list ($_[0], \&parse_collate,         ',') },
    'Constraint'      => sub { parse_1_or_list ($_[0], \&parse_constraint,      ',') },
    'Transliteration' => sub { parse_1_or_list ($_[0], \&parse_transliteration, ',') },
    'Transcoding'     => sub { parse_1_or_list ($_[0], \&parse_transcoding,     ',') },
    'Order'           => sub { parse_1_or_list ($_[0], \&parse_order,           ',') },
    'ColumnSpec'      => sub { parse_1_or_list ($_[0], \&parse_column_spec,     ',') },

    # parse & execute actions:
    'Do'              => sub { parse_do_stmt   ($_[0]) },
    'Fetch'           => sub { parse_fetch_stmt($_[0]) },
);
my $top_parse_re=  '(?:'.join('|', sort { length($b) <=> length($a) } '',     keys %top_parse).')';
my $top_parse_re2= '(?:'.join('|', sort { length($b) <=> length($a) } 'none', keys %top_parse).')';

sub interpol_set_context ($$)
{
    my ($text, $ctxt)= @_;
    $text=~ s/(\Q${\SQL_MARK}\E$top_parse_re)(?::$top_parse_re2)?(\s*\{)/$1:$ctxt$2/gs;
    return $text;
}

sub good_interpol_type($)
{
    my ($type)= @_;
    return !!$top_parse{$type};
}

sub mark_sql()
{
    # Step 1:
    # This function will get the text without comments, strings, etc.,
    # and replace the initial SQL marking the start of SQL syntax by
    # our special SQL_MARK.  Then, the unprocessed text will be
    # processed by replace_sql().
    s/\b\Q$sql_marker\E($top_parse_re\s*\{)/${\SQL_MARK}$1/gs;

    # Step 2:
    # Unmark false positives.  The above finds false matches in
    # variables:
    #
    #    $sql{...}
    #
    # We cannot(?) do this in one go, as we'd need a variable-width
    # negative look-behind regexp, which Perl does not have.  This
    # is because there can be arbitrary white space between $ and
    # a variable name.
    s/([\$\@\%]\s*)\Q${\SQL_MARK}\E/$1$sql_marker/gs;

    # Note that there are still false positives, which are really hard
    # to find unless we start parsing Perl completely:
    #
    #   ${ sql{blah} }
}

sub parse($$)
{
    my ($kind, $str)= @_;
    my $lx= lexer_new ($str, "", 0);
    my $func= $top_parse{$kind};
    return undef unless $func;
    return () if looking_at($lx, '');
    my @thing= $func->($lx);
    expect($lx, '', SHIFT);
    lx_die_perhaps ($lx);
    return to_perl(1, $kind, @thing);
}

sub replace_sql()
{
    my ($module, $file, $line)= caller(4); # find our from where we were invoked

    mark_sql();
    #print STDERR "DEBUG: BEFORE: $_\n";

    pos($_)= 0;
    REPLACEMENT: while (/(\Q${\SQL_MARK}\E($top_parse_re)(?::($top_parse_re2))?\s*\{)/gs) {
        # prepare lexer:
        my $ctxt=     $3 || 'Stmt';
        my $speckind= $2;
        my $kind=     $speckind || $ctxt;
        my $start=    pos($_) - length($1);
        my $prefix=   substr($_, 0, $start);
        my $line_rel= ($prefix =~ tr/\n//);
        my $lx=       lexer_new ($_, $file, $line + $line_rel);

        # select parser:
        my $func= $top_parse{$kind};
        unless ($func) {
            die "$file:".($line+$line_rel+1).
                  ": Error: Plain ${sql_marker}${speckind}{...} is illegal, because the ".
                  "surrounding block must not return an object.\n\tPlease use ".
                  (english_or map "${sql_marker}${_}{...}", keys %top_parse)." to disambiguate.\n";
            last REPLACEMENT;
        }

        # parse (including closing brace):
        my @thing= $func->($lx);
        expect ($lx, '}', SHIFT);
        lx_die_perhaps ($lx);

        my $end= $lx->{token}{pos};
        my_confess unless defined $end && $start < $end;

        # Make Perl code:
        # Represent the parse result as a list in Perl (if it's only
        # one element, the parens don't hurt).  Each thing is
        # handled individually by to_perl():
        my $perl= to_perl($line + $line_rel, $kind, @thing);

        # replace:
        print STDERR "$file:".($line+$line_rel+1).': DEBUG: '.__PACKAGE__." replacement: $perl\n"
            if $debug;

        my $old_text= substr($_, $start, $end-$start, $perl); # extract and replace text
            # pos($_) is now undef, which is ok, we will
            # rescan the text anyway.

        # Insert newlines at the end that have been dropped so that the line
        # count does not change and Perl's error messages are useful:
        my $line_cnt_old= ($old_text =~ tr/\n//);
        my $line_cnt_new= ($perl     =~ tr/\n//);
        my_confess "More newlines than before" #.": \n###\n$old_text\n###$perl\n###\n"
            if $line_cnt_new > $line_cnt_old;

        if (my $line_cnt_less= $line_cnt_old - $line_cnt_new) {
            substr($_, $start + length($perl), 0, "\n" x $line_cnt_less);
        }

        # rescan everything in order to recurse into embedded sql{...}:
        pos($_)= 0;
    }
    pos($_)= undef;

    #print STDERR "DEBUG: AFTER: $_\n";
};

FILTER_ONLY
    # code_no_comments => \&mark_sql,    # This is way to slow.
    all  => \&replace_sql;

######################################################################
# Functions used in generated code:

# Obj:
{
    package SQL::Yapp::Obj;

    use strict;
    use warnings;
    use Carp qw(croak);

    sub op($) { return ''; }

    ######################################################################
    # stringify: simply return second entry in array, the string:
    use overload '""' => 'value',
                 cmp  => sub { "$_[0]" cmp "$_[1]" };

    sub type_error($$)
    {
        my ($x, $want)= @_;
        my $r= ref($x);
        $r=~ s/^SQL::Yapp:://;
        croak "Error: Expected $want, but found ".$r;
    }

    sub asc($)              { $_[0]->type_error('Asc');             }
    sub assign($)           { $_[0]->type_error('assignment');      }
    sub charset($)          { $_[0]->type_error('CharSet');         }
    sub constraint($)       { $_[0]->type_error('Constraint');      }
    sub charset1($)         { $_[0]->type_error('CharSet');         }
    sub collate1($)         { $_[0]->type_error('Collate');         }
    sub colname($)          { $_[0]->type_error('ColumnName');      }
    sub colspec($)          { $_[0]->type_error('ColumnSpec');      }
    sub column1($)          { $_[0]->type_error('Column');          }
    sub column1_single($)   { $_[0]->type_error('Column');          }
    sub constraint1($)      { $_[0]->type_error('Constraint');      }
    sub desc($)             { $_[0]->type_error('Desc');            }
    sub engine1($)          { $_[0]->type_error('Engine');          }
    sub expr($)             { $_[0]->type_error('Expr');            }
    sub expr_or_check($)    { $_[0]->type_error('Expr or Check');   }
    sub check($)            { $_[0]->type_error('Check');           }
    sub exprparen($)        { $_[0]->type_error('Expr');            }
    sub index1($)           { $_[0]->type_error('Index');           }
    sub joinclause($)       { $_[0]->type_error('JOIN clause');     }
    sub limit_number($)     { $_[0]->type_error('number or ?');     }
    sub stmt($)             { $_[0]->type_error('Stmt');            }
    sub subquery($)         { $_[0]->type_error('subquery');        }
    sub table1($)           { $_[0]->type_error('Table');           }
    sub tabname($)          { $_[0]->type_error('TableName');       }
    sub tableopt($)         { $_[0]->type_error('TableOption');     }
    sub transcoding($)      { $_[0]->type_error('Transcoding');     }
    sub transliteration1($) { $_[0]->type_error('Transliteration'); }
    sub type($)             { $_[0]->type_error('Type');            }

    sub do($)               { $_[0]->type_error('Do');              }
    sub fetch($)            { $_[0]->type_error('Fetch');           }
}

# Obj1:
{
    package SQL::Yapp::Obj1;

    use strict;
    use warnings;
    use base qw(SQL::Yapp::Obj);
    use Scalar::Util qw(blessed);

    sub obj($$)
    {
        my ($class,$x)= @_;
        return $x
            if blessed($x) && $x->isa(__PACKAGE__);
        return bless([$x], $class);
    }

    sub value($) { return $_[0][0]; }
}

###############
# Asterisk:
{
    package SQL::Yapp::Asterisk;

    use strict;
    use warnings;
    use base qw(SQL::Yapp::Obj);

    sub obj($)
    {
        my ($class)= @_;
        return bless([], $class);
    }

    sub value($)          { return '*'; }

    sub column1($)        { return $_[0]; }
    sub column1_single($) { return $_[0]; }
    sub expr($)           { return $_[0]; }
    sub expr_or_check($)  { return $_[0]; }

    sub asterisk($)       { return $_[0]; }
}

# Question:
{
    package SQL::Yapp::Question;

    use strict;
    use warnings;
    use base qw(SQL::Yapp::Obj);

    sub obj($)
    {
        my ($class)= @_;
        return bless([], $class);
    }

    sub value($)         { return '?' }

    sub limit_number($)  { return $_[0]; }
    sub exprparen($)     { return $_[0]; }
    sub expr($)          { return $_[0]; }
    sub expr_or_check($) { return $_[0]; }
    sub asc($)           { return $_[0]; }
    sub desc($)          { return SQL::Yapp::Desc->obj($_[0]); }
}

# ExprSpecial:
{
    package SQL::Yapp::ExprSpecial;

    use strict;
    use warnings;
    use base qw(SQL::Yapp::Obj1);

    sub exprparen($)     { return $_[0]; }
    sub expr($)          { return $_[0]; }
    sub expr_or_check($) { return $_[0]; }
    sub asc($)           { return $_[0]; }
    sub desc($)          { return SQL::Yapp::Desc->obj($_[0]); }
}

# Stmt:
{
    package SQL::Yapp::Stmt;

    use strict;
    use warnings;
    use Carp qw(croak);
    use base qw(SQL::Yapp::Obj1);

    sub subquery($)      { $_[0]->type_error('SELECT statement'); }
    sub exprparen($)     { $_[0]->subquery(); }
    sub expr($)          { $_[0]->subquery(); }
    sub expr_or_check($) { $_[0]->subquery(); }

    sub stmt($)          { return $_[0]; }

    sub do($)
    {
        my ($stmt) = @_;
        my $dbh = SQL::Yapp::get_dbh();
        $dbh->do($stmt);
        return; # return no statements so that _max1_if_scalar is ok with void context
    }
}

# SelectStmt:
{
    package SQL::Yapp::SelectStmt;

    use strict;
    use warnings;
    use Carp qw(croak);
    use base qw(SQL::Yapp::Stmt);

    sub subquery($)      { return '('.($_[0]->value).')'; }

    sub fetch($)
    {
        my ($stmt) = @_;
        my $dbh = SQL::Yapp::get_dbh();
        my $sth = $dbh->prepare($stmt);
        my $aref = $dbh->selectall_arrayref($sth, { Slice => {} });
        return unless $aref;
        return @$aref;
    }
}

# SelectStmtSingle:
{
    package SQL::Yapp::SelectStmtSingle;

    use strict;
    use warnings;
    use Carp qw(croak);
    use base qw(SQL::Yapp::SelectStmt);

    sub fetch($)
    {
        my ($stmt) = @_;
        my $dbh = SQL::Yapp::get_dbh();
        my $sth = $dbh->prepare($stmt);
        return unless $sth->execute;
        my @r= ();
        while (my $a= $sth->fetchrow_arrayref) {
            die unless scalar(@$a) == 1;
            push @r, $a->[0];
        }
        return @r;
    }
}

# Do:
# This is a bit different, since the obj() method will actually execute the statement.
{
    package SQL::Yapp::Do;

    use strict;
    use warnings;
    use Carp qw(confess);

    sub obj($$)
    {
        my ($class, $stmt) = @_;
        return $stmt->do;
    }
}

# Fetch:
# This is a bit different, since the obj() method will actually execute the statement.
{
    package SQL::Yapp::Fetch;

    use strict;
    use warnings;

    sub obj($$)
    {
        my ($class, $stmt) = @_;
        return $stmt->fetch;
    }
}

# ColumnName:
{
    package SQL::Yapp::ColumnName;

    use strict;
    use warnings;
    use base qw(SQL::Yapp::Obj1);

    sub colname($) { return $_[0]; }
}

# TableName:
{
    package SQL::Yapp::TableName;

    use strict;
    use warnings;
    use base qw(SQL::Yapp::Obj1);

    sub tabname($) { return $_[0]; }
}

# Column:
{
    package SQL::Yapp::Column;

    use strict;
    use warnings;
    use base qw(SQL::Yapp::Obj1);

    sub column1($)       { return $_[0]; }
    sub exprparen($)     { return $_[0]; }
    sub expr($)          { return $_[0]; }
    sub expr_or_check($) { return $_[0]; }
    sub asc($)           { return $_[0]; }
    sub desc($)          { return SQL::Yapp::Desc->obj($_[0]); }
}

# Table:
{
    package SQL::Yapp::Table;
    use strict;
    use warnings;
    use base qw(SQL::Yapp::Obj1);
    sub table1($) { return $_[0]; }
}

# CharSet:
{
    package SQL::Yapp::CharSet;
    use strict;
    use warnings;
    use base qw(SQL::Yapp::Obj1);
    sub charset1($) { return $_[0]; }
}

# Collate:
{
    package SQL::Yapp::Collate;
    use strict;
    use warnings;
    use base qw(SQL::Yapp::Obj1);
    sub collate1($) { return $_[0]; }
}

# Constraint:
{
    package SQL::Yapp::Constraint;
    use strict;
    use warnings;
    use base qw(SQL::Yapp::Obj1);
    sub constraint1($) { return $_[0]; }
}

# Index:
{
    package SQL::Yapp::Index;
    use strict;
    use warnings;
    use base qw(SQL::Yapp::Obj1);
    sub index1($) { return $_[0]; }
}

# Transliteration:
{
    package SQL::Yapp::Transliteration;
    use strict;
    use warnings;
    use base qw(SQL::Yapp::Obj1);
    sub transliteration($) { return $_[0]; }
}

# Transcoding:
{
    package SQL::Yapp::Transcoding;
    use strict;
    use warnings;
    use base qw(SQL::Yapp::Obj1);
    sub transcoding($) { return $_[0]; }
}

# TableOption:
{
    package SQL::Yapp::TableOption;
    use strict;
    use warnings;
    use base qw(SQL::Yapp::Obj1);
    sub tableopt($) { return $_[0]; }
}

# Engine:
{
    package SQL::Yapp::Engine;
    use strict;
    use warnings;
    use base qw(SQL::Yapp::Obj1);
    sub engine1($) { return $_[0]; }
}


# Join:
{
    package SQL::Yapp::Join;

    use strict;
    use warnings;
    use base qw(SQL::Yapp::Obj1);

    sub joinclause($) { return $_[0]; }
}

# Check:
{
    package SQL::Yapp::Check;

    use strict;
    use warnings;
    use base qw(SQL::Yapp::Obj1);

    sub check($)         { return $_[0]; }
    sub expr_or_check($) { return $_[0]; }

    sub obj($$)
    {
        if (ref($_[1]) eq $_[0]) {
            return $_[1];
        }
        elsif (ref($_[1])) {
            bless($_[1], $_[0]);
        }
        else {
            $_[0]->SUPER::obj($_[1]);
        }
    }
}

# Expr:
{
    package SQL::Yapp::Expr;

    use strict;
    use warnings;
    use base qw(SQL::Yapp::Obj1);

    sub exprparen($)     { return '('.($_[0]->value).')'; }
    sub expr($)          { return $_[0]; }
    sub expr_or_check($) { return $_[0]; }
    sub asc($)           { return $_[0]; }
    sub desc($)          { return SQL::Yapp::Desc->obj($_[0]); }
}

# Infix:
{
    package SQL::Yapp::Infix;

    use strict;
    use warnings;
    use base qw(SQL::Yapp::Expr);
    use Carp qw(croak);

    sub obj($$$$)
    {
        my ($class, $op, $a1, $a2)= @_;
        return bless(["$a1 $op $a2", $op, $a1, $a2], $class);
    }

    sub op($)     { return $_[0][1]; }
    sub arg1($)   { return $_[0][2]; }
    sub arg2($)   { return $_[0][3]; }

    sub assign($)
    {
        my ($self)= @_;
        if ($self->op() eq '=') { # we're not checking everything, just whether it's an assignment
            return $self;
        }
        croak "Assignment expected, but found top-level operator '".($self->op)."'.";
    }
}

# Order:
{
    package SQL::Yapp::Order;

    use strict;
    use warnings;
    use base qw(SQL::Yapp::Obj1);
    use Scalar::Util qw(blessed);

    sub obj($$)
    {
        my ($class,$x)= @_;
        return $x
            if blessed($x) && $x->isa('SQL::Yapp::Obj');
        return bless([$x], 'SQL::Yapp::Asc'); # not Order, but Asc.
    }
}

# Asc:
{
    package SQL::Yapp::Asc;

    use strict;
    use warnings;
    use base qw(SQL::Yapp::Order);

    sub asc($)  { return $_[0]; }
    sub desc($) { return SQL::Yapp::Desc->obj($_[0]); }
}

# Desc:
{
    package SQL::Yapp::Desc;

    use strict;
    use warnings;
    use base qw(SQL::Yapp::Order);

    sub obj($$)
    {
        my ($class, $orig)= @_;
        return bless(["$orig DESC",$orig],$class);
    }

    sub orig($) { return $_[0][1]; }

    sub asc($)  { return $_[0]; }
    sub desc($) { return &orig; }
}

# Type:
{
    package SQL::Yapp::Type;

    use strict;
    use warnings;
    use base qw(SQL::Yapp::Obj);
    use Hash::Util qw(lock_keys);
    use Carp qw(croak);

    sub set_base($$$)
    {
        my ($self, $base, $spec)= @_;

        # set new spec:
        $self->{base}= $base;
        $self->{spec}= $spec;

        # filter options by new spec:
        for my $o (keys %{ $self->{option} }) {
            unless ($spec->{$o}) {
                delete $self->{option}{$o};
            }
        }

        return $self;
    }

    sub set_property($$$)
    {
        my ($self, $key, $value)= @_;
        my %a= %$self;
        croak "No $key for $self->{base} allowed." unless $self->{spec}{$key};
        $self->{option}{$key}= $value;
        return $self;
    }

    sub new($)
    {
        my $r= bless({ base => undef, spec => undef, option => {} }, $_[0]);
        lock_keys %$r;
        return $r;
    }

    sub obj($$)
    {
        return $_[1];
    }

    sub clone($)
    {
        my ($self)= @_;
        my $r= bless({
                   %$self,
                   # no need to make a deep copy of 'spec', because it is never changed.
                   option => { %{ $self->{option} } },
               }, __PACKAGE__);
        lock_keys %$r;
        return $r;
    }

    sub type($)
    {
        return $_[0]->clone(); # make a copy before trying to modify this
    }

    sub colspec($)
    {
        return SQL::Yapp::ColumnSpec->new($_[0]); # make a copy producing a ColumnSpec
    }

    sub value($)
    {
        my ($self)= @_;
        return '' unless $self->{base};
        my @r= ($self->{base});
        if ($self->{spec}{prec1} && defined $self->{option}{prec1}) {
            my $len_str= '';
            $len_str.= $self->{option}{prec1};
            if ($self->{spec}{prec2} && defined $self->{option}{prec2}) {
                $len_str.= ', '.$self->{option}{prec2};
            }
            else {
                if ($self->{spec}{prec_mul} && $self->{option}{prec_mul}) {
                    $len_str.= ' '.$self->{option}{prec_mul};
                }
                if ($self->{spec}{prec_unit} && $self->{option}{prec_unit}) {
                    $len_str.= ' '.$self->{option}{prec_unit};
                }
            }
            push @r, '('.$len_str.')';
        }
        if (my $value_list= $self->{spec}{value_list} && $self->{option}{value_list}) {
            push @r, '('.join(', ',@$value_list).')';
        }
        if (my $x= $self->{spec}{charset} && $self->{option}{charset}) {
            push @r, 'CHARACTER SET', $x;
        }
        if (my $x= $self->{spec}{collate} && $self->{option}{collate}) {
            push @r, 'COLLATE', $x;
        }
        for my $key ('sign', 'zerofill', 'timezone') {
            if (my $x= $self->{spec}{$key} && $self->{option}{$key}) {
                push @r, $x;
            }
        }

        return join(' ', @r);
    }
}


# ColumnSpec:
{
    package SQL::Yapp::ColumnSpec;

    use strict;
    use warnings;
    use base qw(SQL::Yapp::Obj);
    use Hash::Util qw(lock_keys);
    use Carp qw(croak);

    sub new($$)
    {
        my ($class, $type)= @_;
        my $r= bless({ datatype => $type->clone(), name => {}, option => {} }, $class);
        lock_keys %$r;
        return $r;
    }

    sub obj($$)
    {
        return $_[1];
    }

    sub clone($)
    {
        my ($self)= @_;
        my $r= bless({
                   datatype => $self->{datatype}->clone(),
                   name   => { %{ $self->{name}   } },
                   option => { %{ $self->{option} } },
               }, __PACKAGE__);
        lock_keys %$r;
        return $r;
    }

    sub colspec($)
    {
        return $_[0]->clone(); # make a copy before trying to modify this
    }

    sub name($$)
    {
        my ($self, $key)= @_;
        if (my $x= $self->{name}{$key}) {
            return ('CONSTRAINT', $x);
        }
        return;
    }

    sub value($)
    {
        my ($self)= @_;
        my @r= ($self->{datatype});

        for my $key ('notnull', 'autoinc', 'unique', 'primary', 'key') {
            if (my $x= $self->{option}{$key}) {
                push @r, $self->name($key), $x;
            }
        }

        for my $key ('default', 'column_format', 'storage') {
            if (my $x= $self->{option}{$key}) {
                push @r, $self->name($key), uc($key), $x;
            }
        }

        for my $key ('check') {
            if (my $x= $self->{option}{$key}) {
                push @r, $self->name($key), uc($key), '('.$x.')';
            }
        }

        for my $key ('references') {
            if (my $x= $self->{option}{$key}) {
                push @r, $self->name($key), $x;
            }
        }

        return join(' ', @r);
    }
}


# Special Constants:
sub ASTERISK { SQL::Yapp::Asterisk->obj(); }
sub QUESTION { SQL::Yapp::Question->obj(); }
sub NULL     { SQL::Yapp::ExprSpecial->obj('NULL'); }
sub TRUE     { SQL::Yapp::ExprSpecial->obj('TRUE'); }
sub FALSE    { SQL::Yapp::ExprSpecial->obj('FALSE'); }
sub UNKNOWN  { SQL::Yapp::ExprSpecial->obj('UNKNOWN'); }
sub DEFAULT  { SQL::Yapp::ExprSpecial->obj('DEFAULT'); }


# Wrapped DBI methods:
sub croak_no_ref($)
{
    my ($self)= @_;
    croak "Error: Wrong type argument from interpolated code:\n".
        "\tExpected scalar, but found ".my_dumper($self);
}

########################################
# Generators:

# These functions are used to typecheck interpolated Perl code's
# result values and to generate objects on the fly if that's possible.
# Usually on-the-fly generation coerces basic Perl types to a blessed
# object, but it would also be feasible to coerce objects to objects.
# Some 'generator' functions don't generate at all, but simply type
# check.
#
# Note: often these functions are invoked in string context, which
# means that directly after their invocation, the string cast operator
# is invoked.  However, there's no easy way to prevent object creation
# in that case, because there is no such thing as 'wantstring'
# (would-be analog to 'wantarray').  So these functions must always
# return a blessed reference.

sub _functor($$@)
{
    my ($functor, $parens, @arg)= @_;

    # possibly translate the functor to a different SQL dialect:
    if (my $dialect= $functor->{dialect}) {
        if (my $f2= find_ref(%$dialect, $write_dialect)) {
            $functor= $f2;
        }
    }

    # print it:
    my $name= $functor->{value};

    # prefix and suffix are not handled here, because they behave
    # differently: they assume exactly one argument are applied
    # point-wise.  They cannot be switched (ok, we might switch
    # between prefix and suffix, but that's not supported yet).
    my $s= switch ($functor->{type},
        'infix()' => sub {
            (scalar(@arg) ?
               join(" $name ", @arg)
            : defined($functor->{result0}) ?
               get_quote_val->($functor->{result0})
            :  die "Error: Functor $functor->{value} used with 0 args, but requires at least one."
            );
        },
        'funcall' => sub {
            $parens= 0;
            "$name(".join(", ", @arg).")";
        },
        'prefix' => sub {
            die "Error: Exactly one argument expected for operator $functor->{value},\n".
                "\tfound (".join(",", @arg).")"
                unless scalar(@arg) == 1;
            "$name $arg[0]"
        },
        'suffix' => sub {
            die "Error: exactly one argument expected, found @arg" unless scalar(@arg) == 1;
            "$arg[0] $name"
        },
    );
    return $parens ? "($s)" : $s;
}

sub _prefix($$@)
{
    my ($name, $parens)= splice @_,0,2;
    return _functor($functor_prefix{$name} || { value => $name, type => 'funcall' } , $parens, @_);
}

sub _suffix($$@)
{
    my ($name, $parens)= splice @_,0,2;
    return _functor($functor_suffix{$name}, $parens, @_);
}

sub _max1_if_scalar(@)
{
    # void context:
    unless (defined wantarray) {
        return if scalar(@_) == 0; # allow void context with no params (e.g. after Do)
        croak 'Error: NYI: void context is currently not supported for SQL blocks.';
    }

    # list context:
    return @_ if wantarray;

    # scalar context:
    croak 'Error: Multiple results cannot be assigned to scalar'
        if scalar(@_) > 1;
    return $_[0];
}

sub min1(@)
{
    croak 'Error: Expected at least one element, but found an empty list'
        if scalar(@_) == 0;
    return @_;
}

sub min1default($@)
{
    return @_ if scalar(@_) == 1;
    shift;
    return @_;
}

sub joinlist($$$$$@)
{
    if (scalar(@_) == 5) {
        return $_[1] if defined $_[1];
        my ($module, $file, $line)= caller;
        croak "$file:$_[0]: Error: Expected at least one element, but found an empty list";
    }
    return $_[2].join ($_[3], @_[5..$#_]).$_[4];
}

sub assign($) # check that the result is an assignment, i.e.:`a` =
{
    my ($x)= @_;
    if (ref($x)) {
        return $x->assign();
    }
    else {
        croak "Assignment expected, but found non-reference.";
    }
}

sub set2values(@)
{
    croak "At least one value expected" if scalar(@_) == 0;
    return
        ' ('.
        join(',', map { assign($_)->arg1() } @_).
        ') VALUES ('.
        join(',', map { $_->arg2() } @_).
        ')';
}

sub exprlist($)
{
    my ($x)= @_;
    croak "Array reference expected for expression list"
       unless ref($x) eq 'ARRAY';
    croak "At least one element expected in expression list"
       unless scalar(@$x) >= 1;
    return '('.join(', ', map { expr($_) } @$x).')';
}

####################
# Type

sub type($)
{
    my ($x)= @_;
    if (ref($x)) {
        return $x->type();
    }
    else {
        croak "Type expected, but found non-reference (user types are not supported yet).";
    }
}

# These have $self at the end because it's easier to generate code like that.
sub type_base($$)
{
    my $self= pop @_;
    my ($base)= @_;
    croak "Unrecognised base type '$base'" unless
        my $spec= find_ref(%type_spec, $base);
    die unless $self;
    return $self->set_base($base, $spec);
}

sub type_basewlist($@)
{
    my $self= pop @_;
    my ($base, @value)= @_;
    croak "Unrecognised base type '$base'" unless
        my $spec= find_ref(%type_spec, $base);
    die unless $self;
    $self->set_base($base, $spec);
    $self->set_property('value_list', \@value);
    return $self;
}

sub type_length($$;$)
{
    my $self= pop @_;
    my ($prec1, $prec2)= @_;
    $self->set_property('prec1', $prec1);
    $self->set_property('prec2', $prec2) if defined $prec2;
    return $self;
}

sub type_largelength($$$;$)
{
    my $self= pop @_;
    my ($coeff, $mul, $unit)= @_;
    $self->set_property('prec1',      $coeff);
    $self->set_property('prec_mul',   $mul)  if defined $mul;
    $self->set_property('prec_unit',  $unit) if defined $unit;
    return $self;
}

sub type_property($$$)
{
    my $self= pop @_;
    my ($key,$value)= @_;
    $self->set_property($key,$value);
    return $self;
}

####################
# ColumnSpec

sub colspec($)
{
    my ($x)= @_;
    if (ref($x)) {
        return $x->colspec();
    }
    else {
        croak "ColumnSpec expected, but found non-reference (user types are not supported yet).";
    }
}

sub colspec_property($$$$)
{
    my $self= pop @_;
    my ($name, $key, $value)= @_;
    $self->{name}{$key}=   $name;
    $self->{option}{$key}= $value;
    return $self;
}

sub colspec_type_base($$)
{
    my $self= pop @_;
    my ($base)= @_;
    type_base($base, $self->{datatype});
    return $self;
}

sub colspec_type_property($$$)
{
    my $self= pop @_;
    my ($key, $value)= @_;
    type_property($key, $value, $self->{datatype});
    return $self;
}

sub colspec_type_basewlist($@)
{
    my $self= pop @_;
    my ($base, @value)= @_;
    type_basewlist($base, @value, $self->{datatype});
    return $self;
}

sub colspec_type_length($$;$)
{
    my $self= pop @_;
    my ($prec1, $prec2)= @_;
    type_length($prec1, $prec2, $self->{datatype});
    return $self;
}

sub colspec_type_largelength($$$;$)
{
    my $self= pop @_;
    my ($coeff, $mul, $unit)= @_;
    type_largelength($coeff, $mul, $unit, $self->{datatype});
    return $self;
}

####################
# identifier interpolation, column and table:

sub tabname($)
{
    my ($x)= @_;
    if (ref($x)) {
        return $x->tabname;
    }
    elsif (defined $x) {
        return SQL::Yapp::TableName->obj(get_quote_id->($xlat_table->($x)));
    }
    else {
        croak "Error: Cannot use undef/NULL as a table name";
    }
}

# Schema-qualified names:
sub schemaname1($$$)
{
    my ($class,$xlat,$x)= @_;
    if (defined $x) {
        return $class->obj(get_quote_id->($xlat->($x)));
    }
    else {
        croak "Error: Cannot use undef/NULL as a table name";
    }
}

sub schemaname2($$$$)
{
    my ($class,$xlat,$x,$y)= @_;

    if (ref($x)) { croak_no_ref($x); }
    if (ref($y)) { croak_no_ref($y); }
    croak "Error: Cannot use undef/NULL as an identifier"
        unless defined $y;

    return $class->obj(
               get_quote_id->(
                   undef,
                   (defined $x ? $xlat_schema->($x) : undef),
                   $xlat->($y)));
}

sub schemaname3($$$$$)
{
    my ($class,$xlat,$x,$y,$z)= @_;
    if (ref($x)) { croak_no_ref($x); }
    if (ref($y)) { croak_no_ref($y); }
    if (ref($z)) { croak_no_ref($z); }
    croak "Error: Cannot use undef/NULL as an identifier"
        unless defined $z;

    return $class->obj(
               get_quote_id->(
                   (defined $x ? $xlat_catalog->($x) : undef),
                   (defined $y ? $xlat_schema->($y)  : undef),
                   $xlat->($z)));
}


# Table:
sub table1($)
{
    my ($x)= @_;
    return ref($x) ? $x->table1 : schemaname1('SQL::Yapp::Table', $xlat_table, $x);
}

sub table2($$)
{
    my ($x,$y)= @_;
    return schemaname2('SQL::Yapp::Table', $xlat_table, $x, $y);
}

sub table3($$$)
{
    my ($x,$y,$z)= @_;
    return schemaname3('SQL::Yapp::Table', $xlat_table, $x, $y, $z);
}


# Index:
sub index1($)
{
    my ($x)= @_;
    return ref($x) ? $x->index1 : schemaname1('SQL::Yapp::Index', $xlat_index, $x);
}

sub index2($$)
{
    my ($x,$y)= @_;
    return schemaname2('SQL::Yapp::Index', $xlat_index, $x, $y);
}

sub index3($$$)
{
    my ($x,$y,$z)= @_;
    return schemaname3('SQL::Yapp::Index', $xlat_index, $x, $y, $z);
}


# CharSet:
sub charset1($)
{
    my ($x)= @_;
    return ref($x) ? $x->charset1 : schemaname1('SQL::Yapp::CharSet', $xlat_charset, $x);
}

sub charset2($$)
{
    my ($x,$y)= @_;
    return schemaname2('SQL::Yapp::CharSet', $xlat_charset, $x, $y);
}

sub charset3($$$)
{
    my ($x,$y,$z)= @_;
    return schemaname3('SQL::Yapp::CharSet', $xlat_charset, $x, $y, $z);
}


# Collate:
sub collate1($)
{
    my ($x)= @_;
    return ref($x) ? $x->collate1 : schemaname1('SQL::Yapp::Collate', $xlat_collate, $x);
}

sub collate2($$)
{
    my ($x,$y)= @_;
    return schemaname2('SQL::Yapp::Collate', $xlat_collate, $x, $y);
}

sub collate3($$$)
{
    my ($x,$y,$z)= @_;
    return schemaname3('SQL::Yapp::Collate', $xlat_collate, $x, $y, $z);
}


# Constraint:
sub constraint1($)
{
    my ($x)= @_;
    return ref($x) ? $x->constraint1 : schemaname1('SQL::Yapp::Constraint', $xlat_constraint, $x);
}

sub constraint2($$)
{
    my ($x,$y)= @_;
    return schemaname2('SQL::Yapp::Constraint', $xlat_constraint, $x, $y);
}

sub constraint3($$$)
{
    my ($x,$y,$z)= @_;
    return schemaname3('SQL::Yapp::Constraint', $xlat_constraint, $x, $y, $z);
}


# Transliteration:
sub transliteration1($)
{
    my ($x)= @_;
    return ref($x) ? $x->transliteration1 : schemaname1('SQL::Yapp::Transliteration', $xlat_transliteration, $x);
}

sub transliteration2($$)
{
    my ($x,$y)= @_;
    return schemaname2('SQL::Yapp::Transliteration', $xlat_transliteration, $x, $y);
}

sub transliteration3($$$)
{
    my ($x,$y,$z)= @_;
    return schemaname3('SQL::Yapp::Transliteration', $xlat_transliteration, $x, $y, $z);
}


# Transcoding:
sub transcoding1($)
{
    my ($x)= @_;
    return ref($x) ? $x->transcoding1 : schemaname1('SQL::Yapp::Transcoding', $xlat_transcoding, $x);
}

sub transcoding2($$)
{
    my ($x,$y)= @_;
    return schemaname2('SQL::Yapp::Transcoding', $xlat_transcoding, $x, $y);
}

sub transcoding3($$$)
{
    my ($x,$y,$z)= @_;
    return schemaname3('SQL::Yapp::Transcoding', $xlat_transcoding, $x, $y, $z);
}


# Engine:
sub engine1($)
{
    my ($x)= @_;
    return ref($x) ? $x->engine1 : schemaname1('SQL::Yapp::Engine', $xlat_engine, $x);
}

sub engine2($$)
{
    my ($x,$y)= @_;
    return schemaname2('SQL::Yapp::Engine', $xlat_engine, $x, $y);
}

sub engine3($$$)
{
    my ($x,$y,$z)= @_;
    return schemaname3('SQL::Yapp::Engine', $xlat_engine, $x, $y, $z);
}


# Columns:
sub colname($)
{
    my ($x)= @_;
    if (ref($x)) {
        return $x->colname;
    }
    elsif (defined $x) {
        return SQL::Yapp::ColumnName->obj(get_quote_id->($xlat_column->($x)));
    }
    else {
        croak "Error: Cannot use undef/NULL as a column name";
    }
}

sub column1($)
{
    my ($x)= @_;
    if (ref($x)) {
        return $x->column1;
    }
    elsif (defined $x) {
        return SQL::Yapp::Column->obj(get_quote_id->($xlat_column->($x)));
    }
    else {
        croak "Error: Cannot use undef/NULL as an identifier";
    }
}

sub column1_single($) #internal
{
    my ($x)= @_;
    if (ref($x)) {
        return $x->column1_single;
    }
    elsif (defined $x) {
        return get_quote_id->($xlat_column->($x));
    }
    else {
        croak "Error: Cannot use undef/NULL as an identifier";
    }
}

sub column2($$)
{
    my ($x,$y)= @_;
    return SQL::Yapp::Column->obj(table1($x).'.'.column1_single($y));
}

sub column3($$$)
{
    my ($x,$y,$z)= @_;
    return SQL::Yapp::Column->obj(table2($x,$y).'.'.column1_single($z));
}

sub column4($$$$)
{
    my ($w,$x,$y,$z)= @_;
    return SQL::Yapp::Column->obj(table3($w,$x,$y).'.'.column1_single($z));
}

# Generated with mkidentn.pl:
sub table1_n($)         { map { table1        ($_   )                       } @{ $_[0] }  }
sub table2_1n($$)       { map { table2        ($_[0], $_   )                } @{ $_[1] }  }
sub table2_n1($$)       { map { table2        ($_   , $_[1])                } @{ $_[0] }  }
sub table2_nn($$)       { map { table2_1n     ($_   , $_[1])                } @{ $_[0] }  }
sub table3_11n($$$)     { map { table3        ($_[0], $_[1], $_   )         } @{ $_[2] }  }
sub table3_1n1($$$)     { map { table3        ($_[0], $_   , $_[2])         } @{ $_[1] }  }
sub table3_1nn($$$)     { map { table3_11n    ($_[0], $_   , $_[2])         } @{ $_[1] }  }
sub table3_n11($$$)     { map { table3        ($_   , $_[1], $_[2])         } @{ $_[0] }  }
sub table3_n1n($$$)     { map { table3_11n    ($_   , $_[1], $_[2])         } @{ $_[0] }  }
sub table3_nn1($$$)     { map { table3_1n1    ($_   , $_[1], $_[2])         } @{ $_[0] }  }
sub table3_nnn($$$)     { map { table3_1nn    ($_   , $_[1], $_[2])         } @{ $_[0] }  }

sub column1_n($)        { map { column1       ($_   )                       } @{ $_[0] }  }
sub column2_1n($$)      { map { column2       ($_[0], $_   )                } @{ $_[1] }  }
sub column2_n1($$)      { map { column2       ($_   , $_[1])                } @{ $_[0] }  }
sub column2_nn($$)      { map { column2_1n    ($_   , $_[1])                } @{ $_[0] }  }
sub column3_11n($$$)    { map { column3       ($_[0], $_[1], $_   )         } @{ $_[2] }  }
sub column3_1n1($$$)    { map { column3       ($_[0], $_   , $_[2])         } @{ $_[1] }  }
sub column3_1nn($$$)    { map { column3_11n   ($_[0], $_   , $_[2])         } @{ $_[1] }  }
sub column3_n11($$$)    { map { column3       ($_   , $_[1], $_[2])         } @{ $_[0] }  }
sub column3_n1n($$$)    { map { column3_11n   ($_   , $_[1], $_[2])         } @{ $_[0] }  }
sub column3_nn1($$$)    { map { column3_1n1   ($_   , $_[1], $_[2])         } @{ $_[0] }  }
sub column3_nnn($$$)    { map { column3_1nn   ($_   , $_[1], $_[2])         } @{ $_[0] }  }
sub column4_111n($$$$)  { map { column4       ($_[0], $_[1], $_[2], $_   )  } @{ $_[3] }  }
sub column4_11n1($$$$)  { map { column4       ($_[0], $_[1], $_   , $_[3])  } @{ $_[2] }  }
sub column4_11nn($$$$)  { map { column4_111n  ($_[0], $_[1], $_   , $_[3])  } @{ $_[2] }  }
sub column4_1n11($$$$)  { map { column4       ($_[0], $_   , $_[2], $_[3])  } @{ $_[1] }  }
sub column4_1n1n($$$$)  { map { column4_111n  ($_[0], $_   , $_[2], $_[3])  } @{ $_[1] }  }
sub column4_1nn1($$$$)  { map { column4_11n1  ($_[0], $_   , $_[2], $_[3])  } @{ $_[1] }  }
sub column4_1nnn($$$$)  { map { column4_11nn  ($_[0], $_   , $_[2], $_[3])  } @{ $_[1] }  }
sub column4_n111($$$$)  { map { column4       ($_   , $_[1], $_[2], $_[3])  } @{ $_[0] }  }
sub column4_n11n($$$$)  { map { column4_111n  ($_   , $_[1], $_[2], $_[3])  } @{ $_[0] }  }
sub column4_n1n1($$$$)  { map { column4_11n1  ($_   , $_[1], $_[2], $_[3])  } @{ $_[0] }  }
sub column4_n1nn($$$$)  { map { column4_11nn  ($_   , $_[1], $_[2], $_[3])  } @{ $_[0] }  }
sub column4_nn11($$$$)  { map { column4_1n11  ($_   , $_[1], $_[2], $_[3])  } @{ $_[0] }  }
sub column4_nn1n($$$$)  { map { column4_1n1n  ($_   , $_[1], $_[2], $_[3])  } @{ $_[0] }  }
sub column4_nnn1($$$$)  { map { column4_1nn1  ($_   , $_[1], $_[2], $_[3])  } @{ $_[0] }  }
sub column4_nnnn($$$$)  { map { column4_1nnn  ($_   , $_[1], $_[2], $_[3])  } @{ $_[0] }  }

####################
# stmt interpolation:

sub stmt($)
{
    my ($x)= @_;
    if (ref($x)) {
        return $x->stmt;
    }
    else {
        croak "Error: Expected 'Stmt' object, but found: ".my_dumper($x);
    }
}

sub subquery($)
{
    my ($x1)= @_;
    my $x= SQL::Yapp::Stmt->obj($x1);
    return $x->subquery;
}

####################
# expr interpolation:

sub exprparen($)
{
    my ($x)= @_;
    if (ref($x)) {
        die Dumper($x) if ref($x) eq 'HASH';
        die Dumper($x) if ref($x) eq 'ARRAY';
        die Dumper($x) if ref($x) eq 'CODE';
        die Dumper($x) if ref($x) eq 'SCALAR';
        return $x->exprparen;
    }
    else {
        return SQL::Yapp::Expr->obj(get_quote_val->($x)); # raw perl scalar: quote as value, no parens
    }
}

sub expr($)
{
    my ($x)= @_;
    if (ref($x)) {
        confess 'Error: Trying to invoke $x->expr() on unblessed reference $x ".
                "(maybe missing nested sqlExpr{...} inside a block, or ".
                "additional () around {} interpolation?)'
            unless blessed($x);
        return $x->expr;
    }
    else {
        return SQL::Yapp::Expr->obj(get_quote_val->($x)); # raw perl scalar: quote as value
    }
}

sub expr_or_check($)
{
    my ($x)= @_;
    if (ref($x)) {
        return $x->expr_or_check;
    }
    else {
        return SQL::Yapp::Expr->obj(get_quote_val->($x)); # raw perl scalar: quote as value
    }
}

sub exprparen_hash(\%)
{
    my ($x)= @_;
    return map {
        my $n= $_;
        my $e= $x->{$n};
        (blessed($e) && $e->isa('SQL::Yapp::Check') ?
            '('.get_quote_id->($n).' '.$e->check.')'
        :   '('.get_quote_id->($n).' = '.exprparen($e).')'
        )
    }
    sort keys %$x;
}

sub expr_hash(\%)
{
    my ($x)= @_;
    return map {
        my $n= $_;
        my $e= $x->{$n};
        (blessed($e) && $e->isa('SQL::Yapp::Check') ?
            '('.get_quote_id->($n).' '.$e->check.')'
        :   SQL::Yapp::Infix->obj('=', get_quote_id->($n), exprparen($e))
        )
    }
    sort keys %$x;
}

####################
# order interpolation:

sub asc($)
{
    my ($x)= @_;
    if (ref($x)) {
        return $x->asc;
    }
    elsif (defined $x) {
        return column1($x);
    }
    else {
        return NULL;
    }
}

sub desc($)
{
    my ($x)= @_;
    if (ref($x)) {
        return $x->desc;
    }
    elsif (defined $x) {
        return SQL::Yapp::Desc->obj(column1($x));
    }
    else {
        return NULL;
    }
}

####################
# table option:

sub tableopt($)
{
    my ($x)= @_;
    if (ref($x)) {
        return $x->tableopt;
    }
    else {
        croak "Error: Expected 'TableOption' object, but found: ".my_dumper($x);
    }
}

####################
# join interpolation:

sub joinclause($)
{
    my ($x)= @_;
    if (ref($x)) {
        return $x->joinclause;
    }
    else {
        croak "Error: Expected 'Join' object, but found: ".my_dumper($x);
    }
}

####################
# limit interpolation:

sub limit_number($)
{
    my ($x)= @_;
    if (ref($x)) {
        return $x->limit_number;
    }
    elsif (looks_like_number $x) {
        return $x;
    }
    else {
        croak "Error: Expected number or ?, but found: ".my_dumper($x);
    }
}

sub limit($$)
{
    my ($cnt, $offset)= @_;

    # FIXME: if dialect is 'std' (or maybe 'std2008'), produce OFFSET/FETCH
    #        clause (SQL-2008).
    if (defined $cnt) {
        if (defined $offset) {
            return " LIMIT ".limit_number($cnt)." OFFSET ".limit_number($offset);
        }
        else {
            return " LIMIT ".limit_number($cnt);
        }
    }
    else {
        if (defined $offset) {
            if ($write_dialect eq 'postgresql') {
                return " LIMIT ALL OFFSET ".limit_number($offset);
            }
            else {
                return " LIMIT ${\LARGE_LIMIT_CNT} OFFSET ".limit_number($offset);
            }
        }
        else {
            return '';
        }
    }
}

####################
# case:

sub whenthen($$)
{
    my ($expr, $then)= @_;
    return 'WHEN '.$expr.' THEN '.$then;
}

sub caseswitch($$@)
{
   #my ($switchval, $default, @whenthen)
   if (scalar(@_) == 2) { # @whenthen is empty => always use default
       return $_[1];      # return default
   }
   return
      join(' ',
          'CASE',
          $_[0],
          @_[2..$#_],     # @whenthen
          'ELSE',         # always generate default, it's easier.
          $_[1],
          'END'
     );
}

sub casecond($@)
{
   #my ($default, @whenthen)
   if (scalar(@_) == 1) { # @whenthen is empty => always use default
       return $_[0];      # return default
   }
   return
      join(' ',
          'CASE',
          @_[1..$#_],     # @whenthen
          'ELSE',         # always generate default, it's easier.
          $_[0],
          'END'
     );
}

1;

######################################################################
######################################################################
######################################################################

__END__