File Coverage

blib/lib/SQL/Yapp.pm

Criterion	Covered	Total	%
statement	2384	2945	80.9
branch	715	1112	64.3
condition	146	290	50.3
subroutine	519	723	71.7
pod	0	298	0.0
total	3764	5368	70.1

#! /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.002;

@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('DISTINCT', '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));

    if (looking_at($lx, '(', SHIFT)) {
        my $stmt;
        return unless
            $stmt= parse_select_stmt($lx)
        and expect ($lx, ')', SHIFT);

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

        $r->{table} = $s;
    }
    else {
        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);
        },

        'DISTINCT' => 'SOME',
        '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);

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

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

            }
            else {
                $r2 = parse_expr($lx, $functor, $right_mark);
            }

            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** (  , ... ) 




3292




 





 





 





 





 





 



     # 




3293




 





 





 





 





 





 



     # All: 




3294




 





 





 





 





 





 



     #     - UNION 




3295




 





 





 





 





 





 



     #     - INTERSECT 




3296




 





 





 





 





 





 



     #     - EXCEPT 




3297




 





 





 





 





 





 



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




3298




 





 





 





 





 





 



   




3299




185





 





 





 





 





305



     $r->{opt_front}= []; 




3300




 





 





 





 





 





 



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




3301




 





 





 





 





 





 



         'DISTINCT', 'ALL', 




3302




 





 





 





 





 





 



         ($read_dialect{mysql} ? 




3303




185




  
 50
  




 





 





 





671



             ('DISTINCTROW') 




3304




 





 





 





 





 





 



         :   () 




3305




 





 





 





 





 





 



         ) 




3306




 





 





 





 





 





 



     ]); 




3307




 





 





 





 





 





 



   




3308




 





 





 





 





 





 



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




3309




 





 





 





 





 





 



         ($read_dialect{mysql} ? 




3310




 





 





 





 





 





 



             ( 




3311




185




  
 50
  




 





 





 





710



                 'HIGH_PRIORITY', 'STRAIGHT_JOIN', 




3312




 





 





 





 





 





 



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




3313




 





 





 





 





 





 



                 'SQL_CACHE', 'SQL_NO_CACHE', 'SQL_CALC_FOUND_ROWS' 




3314




 





 





 





 





 





 



             ) 




3315




 





 





 





 





 





 



         :   () 




3316




 





 





 





 





 





 



         ) 




3317




 





 





 





 





 





 



     ]); 




3318




 





 





 





 





 





 



   




3319




 





 





 





 





 





 



     return unless 




3320




185




  
100
  




 





 





 





452



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




3321




 





 





 





 





 





 



   




3322




184




  
100
  




 





 





 





296



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




3323




 





 





 





 





 





 



         return unless 




3324




 





 





 





 





 





 



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




3325




99




  
 50
  



  
 33
  




 





 





243



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




3326




 





 





 





 





 





 



   




3327




99




  
100
  




 





 





 





185



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




3328




 





 





 





 





 





 



             return unless 




3329




44




  
 50
  




 





 





 





99



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




3330




 





 





 





 





 





 



         } 




3331




99




  
100
  




 





 





 





177



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




3332




 





 





 





 





 





 



             return unless 




3333




6




  
 50
  




 





 





 





21



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




3334




 





 





 





 





 





 



   




3335




6





 





 





 





 





13



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




3336




 





 





 





 





 





 



         } 




3337




99




  
100
  




 





 





 





192



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




3338




 





 





 





 





 





 



             return unless 




3339




1




  
 50
  




 





 





 





2



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




3340




 





 





 





 





 





 



         } 




3341




99




  
100
  




 





 





 





162



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




3342




 





 





 





 





 





 



             return unless 




3343




8




  
 50
  




 





 





 





25



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




3344




 





 





 





 





 





 



         } 




3345




 





 





 





 





 





 



   




3346




99




  
100
  




 





 





 





164



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




3347




4




  
 50
  




 





 





 





13



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




3348




4





 





 





 





 





14



                 my $first_num= parse_limit_num ($lx); 




3349




4




  
100
  




 





 





 





15



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




3350




2





 





 





 





 





5



                     $r->{limit_offset}= $first_num; 




3351




2





 





 





 





 





6



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




3352




 





 





 





 





 





 



                 } 




3353




 





 





 





 





 





 



                 else { 




3354




2





 





 





 





 





4



                     $r->{limit_cnt}= $first_num; 




3355




 





 





 





 





 





 



                 } 




3356




 





 





 





 





 





 



             } 




3357




 





 





 





 





 





 



         } 




3358




99




  
100
  



  
100
  




 





 





293



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




3359




 





 





 





 





 





 



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




3360




 





 





 





 





 





 



         { 




3361




1





 





 





 





 





3



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




3362




 





 





 





 





 





 



         } 




3363




 





 





 





 





 





 



   




3364




99





 





 





 





 





160



         $r->{opt_back}=  []; 




3365




 





 





 





 





 





 



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




3366




 





 





 





 





 





 



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




3367




 





 





 





 





 





 



                 ('FOR UPDATE') 




3368




 





 





 





 





 





 



             :   () 




3369




 





 





 





 





 





 



             ), 




3370




 





 





 





 





 





 



             ($read_dialect{mysql} ? 




3371




 





 





 





 





 





 



                 ( 




3372




 





 





 





 





 





 



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




3373




 





 





 





 





 





 



                 ) 




3374




 





 





 





 





 





 



             :   () 




3375




 





 





 





 





 





 



             ), 




3376




 





 





 





 





 





 



             ($read_dialect{postgresql} ? 




3377




 





 





 





 





 





 



                 ( 




3378




99




  
 50
  



  
 33
  




 





 





532



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




 




 




  
 50
  




 





 





 





 



   




 




 




  
 50
  




 





 





 





 



   




3379




 





 





 





 





 





 



                     'NOWAIT' 




3380




 





 





 





 





 





 



                 ) 




3381




 





 





 





 





 





 



             :   () 




3382




 





 





 





 





 





 



             ), 




3383




 





 





 





 





 





 



         ]); 




3384




 





 





 





 





 





 



     } 




3385




 





 





 





 





 





 



   




3386




184





 





 





 





 





507



     lock_hash %$r; 




3387




184





 





 





 





 





6895



     return $r; 




3388




 





 





 





 





 





 



 } 




3389




 





 





 





 





 





 



   




3390




 





 





 





 





 





 



 sub parse_insert($) 




3391




 





 





 





 





 





 



 { 




3392




13





 





 




  
13
  



  
0
  




24



     my ($lx)= @_; 




3393




13





 





 





 





 





44



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




3394




 





 





 





 





 





 



         qw( 




3395




 





 





 





 





 





 



             opt_front 




3396




 





 





 





 





 





 



             into 




3397




 





 





 





 





 





 



             column 




3398




 





 





 





 





 





 



             default_values 




3399




 





 





 





 





 





 



             value 




3400




 





 





 





 





 





 



             value_interpol 




3401




 





 





 





 





 





 



             set 




3402




 





 





 





 





 





 



             select 




3403




 





 





 





 





 





 



             duplicate_update 




3404




 





 





 





 





 





 



         ) 




3405




 





 





 





 





 





 



     ); 




3406




 





 





 





 





 





 



   




3407




13




  
 50
  




 





 





 





31



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




3408




 





 





 





 





 





 



   




3409




 





 





 





 





 





 



     # PostgreSQL: 




3410




 





 





 





 





 





 



     #    - RETURNING ... 




3411




 





 





 





 





 





 



   




3412




13





 





 





 





 





29



     $r->{opt_front}= []; 




3413




 





 





 





 





 





 



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




3414




 





 





 





 





 





 



         ($read_dialect{mysql} ? 




3415




 





 





 





 





 





 



             ( 




3416




13




  
 50
  




 





 





 





65



                 'IGNORE', 




3417




 





 





 





 





 





 



                 'LOW_PRIORITY', 




3418




 





 





 





 





 





 



                 'HIGH_PRIORITY', 




3419




 





 





 





 





 





 



                 'DELAYED', 




3420




 





 





 





 





 





 



             ) 




3421




 





 





 





 





 





 



         :   () 




3422




 





 





 





 





 





 



         ) 




3423




 





 





 





 





 





 



     ]); 




3424




 





 





 





 





 





 



   




3425




13





 





 





 





 





37



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




3426




 





 





 





 





 





 



   




3427




 





 





 





 





 





 



     return unless 




3428




13




  
 50
  




 





 





 





29



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




3429




 





 





 





 





 





 



   




3430




13




  
100
  




 





 





 





26



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




3431




 





 





 





 





 





 



         return unless 




3432




5




  
 50
  




 





 





 





23



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




3433




 





 





 





 





 





 



     } 




3434




 





 





 





 





 





 



   




3435




 





 





 





 





 





 



     parse_choice($lx, 




3436




 





 





 





 





 





 



         'DEFAULT VALUES' => sub { 




3437



  
0
  




 





 




  
0
  




 





0



             lexer_shift($lx); 




3438



  
0
  




 





 





 





 





0



             $r->{default_values}= 1; 




3439




 





 





 





 





 





 



         }, 




3440




 





 





 





 





 





 



   




3441




 





 





 





 





 





 



         'VALUE' => 'VALUES', 




3442




 





 





 





 





 





 



         'VALUES' => sub { 




3443




5





 





 




  
5
  




 





17



             lexer_shift($lx); 




3444




5





 





 





 





 





20



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




3445




 





 





 





 





 





 



         }, 




3446




 





 





 





 





 





 



   




3447




 





 





 





 





 





 



         'SET' => sub { 




3448




 





 





 





 





 





 



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




3449




 





 





 





 





 





 



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




3450




8




  
 50
  




 




  
8
  




 





19



             if ($r->{column}) { 




3451



  
0
  




 





 





 





 





0



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




3452



  
0
  




 





 





 





 





0



                 return; 




3453




 





 





 





 





 





 



             } 




3454




8





 





 





 





 





18



             lexer_shift($lx); 




3455




8





 





 





 





 





25



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




3456




 





 





 





 





 





 



         }, 




3457




 





 





 





 





 





 



   




3458




13





 





 





 





 





59



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




3459




 





 





 





 





 





 



         'interpol' => 'interpolStmt', 




3460




 





 





 





 





 





 



         'interpolStmt' => sub { 




3461



  
0
  




 





 




  
0
  




 





0



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




3462




 





 





 





 





 





 



         }, 




3463




13





 





 





 





 





80



     ); 




3464




13




  
 50
  




 





 





 





164



     return if $lx->{error}; 




3465




 





 





 





 





 





 



   




3466




13




  
100
  



  
 66
  




 





 





54



     if ($read_dialect{mysql} && 




3467




 





 





 





 





 





 



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




3468




 





 





 





 





 





 



     { 




3469




 





 





 





 





 





 



         return unless 




3470




1




  
 50
  




 





 





 





4



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




3471




 





 





 





 





 





 



     } 




3472




 





 





 





 





 





 



   




3473




13





 





 





 





 





43



     lock_hash %$r; 




3474




13





 





 





 





 





490



     return $r; 




3475




 





 





 





 





 





 



 } 




3476




 





 





 





 





 





 



   




3477




 





 





 





 





 





 



 sub parse_update($) 




3478




 





 





 





 





 





 



 { 




3479




9





 





 




  
9
  



  
0
  




17



     my ($lx)= @_; 




3480




9





 





 





 





 





32



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




3481




 





 





 





 





 





 



         qw( 




3482




 





 





 





 





 





 



             opt_front 




3483




 





 





 





 





 





 



             table 




3484




 





 





 





 





 





 



             set 




3485




 





 





 





 





 





 



             from 




3486




 





 





 





 





 





 



             join 




3487




 





 





 





 





 





 



             where 




3488




 





 





 





 





 





 



             order_by 




3489




 





 





 





 





 





 



             limit_cnt 




3490




 





 





 





 





 





 



             limit_offset 




3491




 





 





 





 





 





 



         ) 




3492




 





 





 





 





 





 



     ); 




3493




 





 





 





 





 





 



   




3494




9




  
 50
  




 





 





 





25



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




3495




 





 





 





 





 





 



   




3496




 





 





 





 





 





 



     # PostgreSQL: 




3497




 





 





 





 





 





 



     #    - RETURNING ... 




3498




 





 





 





 





 





 



   




3499




9





 





 





 





 





31



     $r->{opt_front}= []; 




3500




 





 





 





 





 





 



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




3501




 





 





 





 





 





 



         ($read_dialect{mysql} ? 




3502




 





 





 





 





 





 



             ( 




3503




 





 





 





 





 





 



                 'IGNORE', 




3504




 





 





 





 





 





 



                 'LOW_PRIORITY', 




3505




 





 





 





 





 





 



             ) 




3506




 





 





 





 





 





 



         :   () 




3507




 





 





 





 





 





 



         ), 




3508




 





 





 





 





 





 



         ($read_dialect{postgresql} ? 




3509




 





 





 





 





 





 



             ( 




3510




9




  
 50
  




 





 





 





44



                 'ONLY', 




 




 




  
 50
  




 





 





 





 



   




3511




 





 





 





 





 





 



             ) 




3512




 





 





 





 





 





 



         :   () 




3513




 





 





 





 





 





 



         ) 




3514




 





 





 





 





 





 



     ]); 




3515




 





 





 





 





 





 



   




3516




 





 





 





 





 





 



     return unless 




3517




 





 





 





 





 





 



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




3518




 





 





 





 





 





 



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




3519




9




  
 50
  



  
 33
  




 





 





27



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




 




 





 




  
 33
  




 





 





 



   




3520




 





 





 





 





 





 



   




3521




9




  
100
  




 





 





 





20



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




3522




 





 





 





 





 





 



         return unless 




3523




1




  
 50
  




 





 





 





4



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




3524




 





 





 





 





 





 



     } 




3525




 





 





 





 





 





 



     return unless 




3526




9




  
 50
  




 





 





 





23



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




3527




 





 





 





 





 





 



   




3528




9




  
 50
  




 





 





 





20



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




3529




 





 





 





 





 





 



         return unless 




3530




9




  
 50
  




 





 





 





16



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




3531




 





 





 





 





 





 



     } 




3532




9




  
100
  




 





 





 





21



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




3533




 





 





 





 





 





 



         return unless 




3534




1




  
 50
  




 





 





 





5



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




3535




 





 





 





 





 





 



     } 




3536




9




  
100
  




 





 





 





21



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




3537




1





 





 





 





 





4



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




3538




 





 





 





 





 





 



     } 




3539




 





 





 





 





 





 



   




3540




9





 





 





 





 





30



     lock_hash %$r; 




3541




9





 





 





 





 





294



     return $r; 




3542




 





 





 





 





 





 



 } 




3543




 





 





 





 





 





 



   




3544




 





 





 





 





 





 



 sub parse_delete($) 




3545




 





 





 





 





 





 



 { 




3546




4





 





 




  
4
  



  
0
  




10



     my ($lx)= @_; 




3547




4





 





 





 





 





18



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




3548




 





 





 





 





 





 



         qw( 




3549




 





 





 





 





 





 



             opt_front 




3550




 





 





 





 





 





 



             from 




3551




 





 





 





 





 





 



             from_opt_front 




3552




 





 





 





 





 





 



             join 




3553




 





 





 





 





 





 



             using 




3554




 





 





 





 





 





 



             where 




3555




 





 





 





 





 





 



             order_by 




3556




 





 





 





 





 





 



             limit_cnt 




3557




 





 





 





 





 





 



             limit_offset 




3558




 





 





 





 





 





 



         ) 




3559




 





 





 





 





 





 



     ); 




3560




 





 





 





 





 





 



   




3561




4




  
 50
  




 





 





 





12



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




3562




 





 





 





 





 





 



   




3563




 





 





 





 





 





 



     # PostgreSQL: 




3564




 





 





 





 





 





 



     #    - RETURNING ... 




3565




 





 





 





 





 





 



   




3566




4





 





 





 





 





10



     $r->{opt_front}= []; 




3567




 





 





 





 





 





 



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




3568




 





 





 





 





 





 



         ($read_dialect{mysql} ? 




3569




 





 





 





 





 





 



             ( 




3570




4




  
 50
  




 





 





 





23



                 'IGNORE', 




3571




 





 





 





 





 





 



                 'LOW_PRIORITY', 




3572




 





 





 





 





 





 



                 'QUICK' 




3573




 





 





 





 





 





 



             ) 




3574




 





 





 





 





 





 



         :   () 




3575




 





 





 





 





 





 



         ) 




3576




 





 





 





 





 





 



     ]); 




3577




 





 





 





 





 





 



   




3578




4




  
 50
  




 





 





 





15



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




3579




 





 





 





 





 





 



   




3580




4





 





 





 





 





10



     $r->{from_opt_front}= []; 




3581




 





 





 





 





 





 



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




3582




 





 





 





 





 





 



         ($read_dialect{postgresql} ? 




3583




4




  
 50
  




 





 





 





21



             ('ONLY') 




3584




 





 





 





 





 





 



         :   () 




3585




 





 





 





 





 





 



         ) 




3586




 





 





 





 





 





 



     ]); 




3587




 





 





 





 





 





 



   




3588




 





 





 





 





 





 



     return unless 




3589




4




  
 50
  




 





 





 





13



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




3590




 





 





 





 





 





 



   




3591




4




  
100
  




 





 





 





11



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




3592




 





 





 





 





 





 



         return unless 




3593




2




  
 50
  




 





 





 





8



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




3594




 





 





 





 





 





 



     } 




3595




 





 





 





 





 





 



   




3596




 





 





 





 





 





 



     return unless 




3597




4




  
 50
  




 





 





 





14



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




3598




 





 





 





 





 





 



   




3599




4




  
100
  




 





 





 





9



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




3600




 





 





 





 





 





 



         return unless 




3601




3




  
 50
  




 





 





 





12



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




3602




 





 





 





 





 





 



     } 




3603




4




  
 50
  




 





 





 





12



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




3604




 





 





 





 





 





 



         return unless 




3605



  
0
  



  
  0
  




 





 





 





0



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




3606




 





 





 





 





 





 



     } 




3607




4




  
 50
  




 





 





 





11



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




3608



  
0
  




 





 





 





 





0



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




3609




 





 





 





 





 





 



     } 




3610




 





 





 





 





 





 



   




3611




4





 





 





 





 





15



     lock_hash %$r; 




3612




4





 





 





 





 





136



     return $r; 




3613




 





 





 





 





 





 



 } 




3614




 





 





 





 





 





 



   




3615




 





 





 





 





 





 



 sub keyword($$) 




3616




 





 





 





 





 





 



 { 




3617




1





 





 




  
1
  



  
0
  




2



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




3618




 





 





 





 





 





 



     return 




3619




1




  
 50
  




 





 





 





3



         unless $keyword; 




3620




 





 





 





 





 





 



   




3621




1




  
 50
  




 





 





 





3



     return $keyword 




3622




 





 





 





 





 





 



         if ref($keyword); 




3623




 





 





 





 





 





 



          




3624




1





 





 





 





 





2



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




3625




1





 





 





 





 





2



     $r->{keyword}= $keyword; 




3626




1





 





 





 





 





4



     lock_hash %$r; 




3627




1





 





 





 





 





17



     return $r; 




3628




 





 





 





 





 





 



 } 




3629




 





 





 





 





 





 



   




3630




 





 





 





 





 





 



 sub parse_index_option($) 




3631




 





 





 





 





 





 



 { 




3632




1





 





 




  
1
  



  
0
  




3



     my ($lx)= @_; 




3633




1





 





 





 





 





3



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




3634




 





 





 





 





 





 



   




3635




 





 





 





 





 





 



     parse_choice($lx, 




3636




 





 





 





 





 





 



         -default => sub { 




3637




1





 





 




  
1
  




 





2



             $r= undef; 




3638




 





 





 





 





 





 



         }, 




3639




 





 





 





 





 





 



   




3640




 





 





 





 





 





 



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




3641




 





 





 





 





 





 



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




3642




 





 





 





 





 





 



         #'USING' => sub { 




3643




 





 





 





 





 





 



         #    lexer_shift($lx); 




3644




 





 





 





 





 





 



         #    return unless 




3645




 





 





 





 





 





 



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




3646




 





 





 





 





 





 



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




3647




 





 





 





 





 





 



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




3648




 





 





 





 





 





 



         #}, 




3649




1





 





 





 





 





5



     ); 




3650




1




  
 50
  




 





 





 





7



     return unless $r; 




3651



  
0
  



  
  0
  




 





 





 





0



     return if $lx->{error}; 




3652




 





 





 





 





 





 



   




3653



  
0
  




 





 





 





 





0



     lock_hash %$r; 




3654



  
0
  




 





 





 





 





0



     return $r; 




3655




 





 





 





 





 





 



 } 




3656




 





 





 





 





 





 



   




3657




 





 





 





 





 





 



 sub parse_index_type ($) 




3658




 





 





 





 





 





 



 { 




3659




3





 





 




  
3
  



  
0
  




6



     my ($lx)= @_; 




3660




3




  
100
  




 





 





 





15



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




3661




1





 





 





 





 





3



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




3662




 





 





 





 





 





 



     } 




3663




2





 





 





 





 





4



     return; 




3664




 





 





 





 





 





 



 } 




3665




 





 





 





 





 





 



   




3666




 





 





 





 





 





 



 sub parse_table_constraint($) 




3667




 





 





 





 





 





 



 { 




3668




3





 





 




  
3
  



  
0
  




4



     my ($lx)= @_; 




3669




3





 





 





 





 





8



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




3670




3





 





 





 





 





5



     $r->{index_option}= []; 




3671




 





 





 





 





 





 



   




3672




3




  
 50
  




 





 





 





6



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




3673




 





 





 





 





 





 



         return unless 




3674




3




  
 50
  




 





 





 





6



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




3675




 





 





 





 





 





 



     } 




3676




 





 





 





 





 





 



   




3677




 





 





 





 





 





 



     parse_choice($lx, 




3678




 





 





 





 





 





 



         'PRIMARY KEY' => sub { 




3679



  
0
  




 





 




  
0
  




 





0



             lexer_shift($lx); 




3680



  
0
  




 





 





 





 





0



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




3681



  
0
  




 





 





 





 





0



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




3682




 





 





 





 





 





 



             return unless 




3683




 





 





 





 





 





 



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




3684



  
0
  



  
  0
  



  
  0
  




 





 





0



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




3685




 





 





 





 





 





 



         }, 




3686




 





 





 





 





 





 



         'UNIQUE' => sub { 




3687




1





 





 




  
1
  




 





3



             lexer_shift($lx); 




3688




1





 





 





 





 





2



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




3689




1





 





 





 





 





4



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




3690




 





 





 





 





 





 



             return unless 




3691




 





 





 





 





 





 



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




3692




1




  
 50
  



  
 33
  




 





 





4



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




3693




 





 





 





 





 





 



         }, 




3694




 





 





 





 





 





 



         'FULLTEXT' => sub { 




3695



  
0
  




 





 




  
0
  




 





0



             lexer_shift($lx); 




3696



  
0
  




 





 





 





 





0



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




3697



  
0
  




 





 





 





 





0



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




3698




 





 





 





 





 





 



             return unless 




3699




 





 





 





 





 





 



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




3700



  
0
  



  
  0
  



  
  0
  




 





 





0



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




3701




 





 





 





 





 





 



         }, 




3702




 





 





 





 





 





 



         'SPATIAL' => sub { 




3703



  
0
  




 





 




  
0
  




 





0



             lexer_shift($lx); 




3704



  
0
  




 





 





 





 





0



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




3705



  
0
  




 





 





 





 





0



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




3706




 





 





 





 





 





 



             return unless 




3707




 





 





 





 





 





 



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




3708



  
0
  



  
  0
  



  
  0
  




 





 





0



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




3709




 





 





 





 





 





 



         }, 




3710




 





 





 





 





 





 



         'FOREIGN KEY' => sub { 




3711




2





 





 




  
2
  




 





5



             lexer_shift($lx); 




3712




2





 





 





 





 





3



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




3713




2





 





 





 





 





3



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




3714




 





 





 





 





 





 



             return unless 




3715




 





 





 





 





 





 



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




3716




2




  
 50
  



  
 33
  




 





 





5



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




3717




 





 





 





 





 





 



         }, 




3718




 





 





 





 





 





 



         # 'CHECK' => sub { 




3719




 





 





 





 





 





 



         # }, 




3720




 





 





 





 





 





 



         ($read_dialect{mysql} ? 




3721




 





 





 





 





 





 



             ( 




3722




 





 





 





 





 





 



                 'INDEX' => sub { 




3723



  
0
  




 





 




  
0
  




 





0



                     lexer_shift($lx); 




3724



  
0
  




 





 





 





 





0



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




3725




 





 





 





 





 





 



                     # FIXME: mysql allows an index name here 




3726




 





 





 





 





 





 



                     return unless 




3727



  
0
  



  
  0
  




 





 





 





0



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




3728



  
0
  




 





 





 





 





0



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




3729




 





 





 





 





 





 



                 } 




3730




 





 





 





 





 





 



             ) 




3731




3




  
 50
  




 





 





 





34



         :   () 




3732




 





 





 





 





 





 



         ), 




3733




 





 





 





 





 





 



     ); 




3734




3




  
 50
  




 





 





 





48



     return if $lx->{error}; 




3735




 





 





 





 





 





 



   




3736




3





 





 





 





 





9



     lock_hash %$r; 




3737




3





 





 





 





 





68



     return $r; 




3738




 





 





 





 





 





 



 } 




3739




 





 





 





 





 





 



   




3740




 





 





 





 





 





 



 sub parse_table_option1($$$$) 




3741




 





 





 





 





 





 



 { 




3742




6





 





 




  
6
  



  
0
  




14



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




3743




6





 





 





 





 





10



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




3744




6





 





 





 





 





11



     $r->{name}= $name; 




3745




6





 





 





 





 





12



     lexer_shift($lx); 




3746




6





 





 





 





 





13



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




3747




 





 





 





 





 





 



     return unless 




3748




6




  
 50
  




 





 





 





15



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




3749




6





 





 





 





 





15



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




3750




6





 





 





 





 





12



     return $r; 




3751




 





 





 





 





 





 



 } 




3752




 





 





 





 





 





 



   




3753




 





 





 





 





 





 



 sub parse_on_commit_action($) 




3754




 





 





 





 





 





 



 { 




3755




1





 





 




  
1
  



  
0
  




3



     my ($lx)= @_; 




3756




 





 





 





 





 





 



     return keyword ($lx, 




3757




 





 





 





 





 





 



         expect($lx, 




3758




 





 





 





 





 





 



             [ 




3759




 





 





 





 





 





 



                 'PRESERVE ROWS', 




3760




 





 





 





 





 





 



                 'DELETE ROWS', 




3761




 





 





 





 





 





 



                 ($read_dialect{postgresql} ? 




3762




 





 





 





 





 





 



                     ( 




3763




1




  
 50
  




 





 





 





6



                         'DROP' 




3764




 





 





 





 





 





 



                     ) 




3765




 





 





 





 





 





 



                 :   () 




3766




 





 





 





 





 





 



                 ) 




3767




 





 





 





 





 





 



             ], 




3768




 





 





 





 





 





 



             SHIFT 




3769




 





 





 





 





 





 



         ) 




3770




 





 





 





 





 





 



     ); 




3771




 





 





 





 





 





 



 } 




3772




 





 





 





 





 





 



   




3773




 





 





 





 





 





 



 sub parse_table_option($) 




3774




 





 





 





 





 





 



 { 




3775




12





 





 




  
12
  



  
0
  




19



     my ($lx)= @_; 




3776




12





 





 





 





 





22



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




3777




 





 





 





 





 





 



   




3778




 





 





 





 





 





 



     parse_choice($lx, 




3779




 





 





 





 





 





 



         -default => sub { 




3780




4





 





 




  
4
  




 





9



             $r= undef; 




3781




 





 





 





 





 





 



         }, 




3782




 





 





 





 





 





 



   




3783




 





 





 





 





 





 



         ($read_dialect{mysql} ? 




3784




 





 





 





 





 





 



             ( 




3785




 





 





 





 





 





 



                 'ENGINE' => sub { 




3786




2





 





 




  
2
  




 





10



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




3787




 





 





 





 





 





 



                 }, 




3788




 





 





 





 





 





 



          




3789




 





 





 





 





 





 



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




3790




 





 





 





 





 





 



                 'DEFAULT CHARACTER SET' => sub { 




3791




2





 





 




  
2
  




 





4



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




3792




 





 





 





 





 





 



                 }, 




3793




 





 





 





 





 





 



   




3794




 





 





 





 





 





 



                 'COLLATE' => 'DEFAULT COLLATE', 




3795




 





 





 





 





 





 



                 'DEFAULT COLLATE' => sub { 




3796



  
0
  




 





 




  
0
  




 





0



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




3797




 





 





 





 





 





 



                 }, 




3798




 





 





 





 





 





 



   




3799




 





 





 





 





 





 



                 'AUTO_INCREMENT' => sub { 




3800



  
0
  




 





 




  
0
  




 





0



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




3801




 





 





 





 





 





 



                 }, 




3802




 





 





 





 





 





 



   




3803




 





 





 





 





 





 



                 'COMMENT' => sub { 




3804




1





 





 




  
1
  




 





3



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




3805




 





 





 





 





 





 



                 }, 




3806




 





 





 





 





 





 



             ) 




3807




 





 





 





 





 





 



         :   () 




3808




 





 





 





 





 





 



         ), 




3809




 





 





 





 





 





 



   




3810




 





 





 





 





 





 



         'ON COMMIT' => sub { 




3811




1





 





 




  
1
  




 





3



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




3812




 





 





 





 





 





 



         }, 




3813




 





 





 





 





 





 



   




3814




 





 





 





 





 





 



         'interpolTableOption' => 'interpol', 




3815




 





 





 





 





 





 



         'interpol' => sub { 




3816




2





 





 




  
2
  




 





5



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




3817




2





 





 





 





 





3



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




3818




2





 





 





 





 





6



             lexer_shift($lx); 




3819




2





 





 





 





 





5



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




3820




2





 





 





 





 





5



             return $r; 




3821




 





 





 





 





 





 



         }, 




3822




12




  
 50
  




 





 





 





122



     ); 




3823




12




  
100
  




 





 





 





157



     return unless $r; 




3824




8




  
 50
  




 





 





 





17



     return if $lx->{error}; 




3825




8





 





 





 





 





22



     lock_hash %$r; 




3826




8





 





 





 





 





152



     return $r; 




3827




 





 





 





 





 





 



 } 




3828




 





 





 





 





 





 



   




3829




 





 





 





 





 





 



 sub parse_column_def($) 




3830




 





 





 





 





 





 



 { 




3831




6





 





 




  
6
  



  
0
  




10



     my ($lx)= @_; 




3832




6





 





 





 





 





13



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




3833




 





 





 





 





 





 



     return unless 




3834




 





 





 





 





 





 



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




3835




6




  
 50
  



  
 33
  




 





 





24



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




3836




6





 





 





 





 





22



     lock_hash %$r; 




3837




6





 





 





 





 





143



     return $r; 




3838




 





 





 





 





 





 



 } 




3839




 





 





 





 





 





 



   




3840




 





 





 





 





 





 



 sub parse_column_def_or_option($) 




3841




 





 





 





 





 





 



 { 




3842




6





 





 




  
6
  



  
0
  




9



     my ($lx)= @_; 




3843




 





 





 





 





 





 



     return parse_choice($lx, 




3844




 





 





 





 





 





 



         'interpol' => 'ident', 




3845




 





 





 





 





 





 



         'ident' => sub { 




3846




4





 





 




  
4
  




 





9



             return parse_column_def($lx); 




3847




 





 





 





 





 





 



         }, 




3848




 





 





 





 





 





 



         -default => sub { 




3849




2





 





 




  
2
  




 





5



             return parse_table_constraint($lx); 




3850




 





 





 





 





 





 



         }, 




3851




6





 





 





 





 





29



     ); 




3852




 





 





 





 





 





 



 } 




3853




 





 





 





 





 





 



   




3854




 





 





 





 





 





 



 sub parse_create_table($) 




3855




 





 





 





 





 





 



 { 




3856




2





 





 




  
2
  



  
0
  




5



     my ($lx)= @_; 




3857




 





 





 





 





 





 



     return unless 




3858




2




  
 50
  




 





 





 





7



         expect($lx, \@CREATE_TABLE_INITIAL); 




3859




 





 





 





 





 





 



   




3860




2





 





 





 





 





10



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




3861




 





 





 





 





 





 



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




3862




2





 





 





 





 





5



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




3863




 





 





 





 





 





 



   




3864




2




  
100
  



  
 66
  




 





 





12



     if ($read_dialect{mysql} && 




3865




 





 





 





 





 





 



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




3866




 





 





 





 





 





 



     { 




3867




1





 





 





 





 





2



         $r->{if_not_exists}= 1; 




3868




 





 





 





 





 





 



     } 




3869




 





 





 





 





 





 



   




3870




 





 





 





 





 





 



     return unless 




3871




2




  
 50
  




 





 





 





7



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




3872




 





 





 





 





 





 



   




3873




2





 





 





 





 





5



     $r->{column_def}= []; 




3874




2





 





 





 





 





4



     $r->{tabconstr}=  []; 




3875




2




  
 50
  




 





 





 





6



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




3876




 





 





 





 





 





 



         return unless 




3877




2




  
 50
  




 





 





 





9



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




3878




 





 





 





 





 





 



   




3879




2





 





 





 





 





6



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




 




6





 





 





 





 





15



   




3880




2





 





 





 





 





5



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




 




6





 





 





 





 





12



   




3881




 





 





 





 





 





 



     } 




3882




 





 





 





 





 





 



   




3883




 





 





 





 





 





 



     return unless 




3884




2




  
 50
  




 





 





 





6



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




3885




 





 





 





 





 





 



   




3886




2




  
100
  



  
 66
  




 





 





6



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




3887




 





 





 





 





 





 



         looking_at($lx, \@SELECT_INITIAL)) 




3888




 





 





 





 





 





 



     { 




3889




 





 





 





 





 





 



         return unless 




3890




1




  
 50
  




 





 





 





5



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




3891




 





 





 





 





 





 



     } 




3892




 





 





 





 





 





 



   




3893




2




  
  0
  



  
 33
  




 





 





4



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




 




2





 





 





 





 





8



   




3894



  
0
  




 





 





 





 





0



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




3895



  
0
  




 





 





 





 





0



         return; 




3896




 





 





 





 





 





 



     } 




3897




 





 





 





 





 





 



   




3898




2





 





 





 





 





7



     lock_hash %$r; 




3899




2





 





 





 





 





90



     return $r; 




3900




 





 





 





 





 





 



 } 




3901




 





 





 





 





 





 



   




3902




 





 





 





 





 





 



 sub parse_drop_table($) 




3903




 





 





 





 





 





 



 { 




3904




1





 





 




  
1
  



  
0
  




2



     my ($lx)= @_; 




3905




 





 





 





 





 





 



     return unless 




3906




1




  
 50
  




 





 





 





4



         expect($lx, \@DROP_TABLE_INITIAL); 




3907




 





 





 





 





 





 



   




3908




1





 





 





 





 





5



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




3909




 





 





 





 





 





 



                   qw(subtype if_exists table cascade)); 




3910




1





 





 





 





 





3



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




3911




 





 





 





 





 





 



   




3912




1




  
 50
  



  
 33
  




 





 





7



     if ($read_dialect{mysql} && 




3913




 





 





 





 





 





 



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




3914




 





 





 





 





 





 



     { 




3915




1





 





 





 





 





2



         $r->{if_exists}= 1; 




3916




 





 





 





 





 





 



     } 




3917




 





 





 





 





 





 



   




3918




 





 





 





 





 





 



     return unless 




3919




1




  
 50
  




 





 





 





5



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




3920




 





 





 





 





 





 



   




3921




1





 





 





 





 





3



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




3922




 





 





 





 





 





 



   




3923




1





 





 





 





 





5



     lock_hash %$r; 




3924




1





 





 





 





 





29



     return $r; 




3925




 





 





 





 





 





 



 } 




3926




 





 





 





 





 





 



   




3927




 





 





 





 





 





 



 sub parse_column_pos_perhaps($) 




3928




 





 





 





 





 





 



 { 




3929




3





 





 




  
3
  



  
0
  




3



     my ($lx)= @_; 




3930




 





 





 





 





 





 



     return parse_choice($lx, 




3931




 





 





 





 





 





 



         -default => sub { 




3932




1





 





 




  
1
  




 





8



             return; 




3933




 





 





 





 





 





 



         }, 




3934




 





 





 





 





 





 



         'FIRST' => sub { 




3935




1





 





 




  
1
  




 





3



             return lexer_shift($lx); 




3936




 





 





 





 





 





 



         }, 




3937




 





 





 





 





 





 



         'AFTER' => sub { 




3938




1





 





 




  
1
  




 





4



             lexer_shift($lx); 




3939




1





 





 





 





 





2



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




3940




 





 





 





 





 





 



         }, 




3941




3





 





 





 





 





16



     ); 




3942




 





 





 





 





 





 



 } 




3943




 





 





 





 





 





 



   




3944




 





 





 





 





 





 



 sub parse_alter_table($) 




3945




 





 





 





 





 





 



 { 




3946




20





 





 




  
20
  



  
0
  




22



     my ($lx)= @_; 




3947




 





 





 





 





 





 



     return unless 




3948




20




  
 50
  




 





 





 





38



         expect($lx, \@ALTER_TABLE_INITIAL); 




3949




 





 





 





 





 





 



   




3950




20





 





 





 





 





43



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




3951




 





 





 





 





 





 



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




3952




20





 





 





 





 





40



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




3953




20





 





 





 





 





34



     $r->{arg}=     []; 




3954




 





 





 





 





 





 



   




3955




 





 





 





 





 





 



     return unless 




3956




20




  
 50
  




 





 





 





33



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




3957




 





 





 





 





 





 



   




3958




20





 





 





 





 





29



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




3959




 





 





 





 





 





 



   




3960




 





 





 





 





 





 



     parse_choice($lx, 




3961




 





 





 





 





 





 



         'DROP CONSTRAINT' => sub { 




3962




1





 





 




  
1
  




 





3



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




3963




 





 





 





 





 





 



             return unless 




3964




1




  
 50
  




 





 





 





3



                 my $constraint= parse_constraint($lx); 




3965




1





 





 





 





 





1



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




 




1





 





 





 





 





4



   




3966




 





 





 





 





 





 



         }, 




3967




 





 





 





 





 





 



   




3968




 





 





 





 





 





 



         'DROP COLUMN' => sub { 




3969




3





 





 




  
3
  




 





7



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




3970




 





 





 





 





 





 



             return unless 




3971




3




  
 50
  




 





 





 





7



                 my $column= parse_column_name($lx); 




3972




3





 





 





 





 





4



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




 




3





 





 





 





 





8



   




3973




 





 





 





 





 





 



         }, 




3974




 





 





 





 





 





 



   




3975




 





 





 





 





 





 



         'RENAME COLUMN' => sub { 




3976




1





 





 




  
1
  




 





2



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




3977




 





 





 





 





 





 



   




3978




 





 





 





 





 





 



             return unless 




3979




1




  
 50
  



  
 33
  




 





 





4



                 my $column= parse_column_name($lx) 




 




 





 




  
 33
  




 





 





 



   




3980




 





 





 





 





 





 



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




3981




 





 





 





 





 





 



             and my $column2= parse_column_name($lx); 




3982




 





 





 





 





 





 



   




3983




1





 





 





 





 





3



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




 




1





 





 





 





 





4



   




3984




 





 





 





 





 





 



         }, 




3985




 





 





 





 





 





 



   




3986




 





 





 





 





 





 



         'DROP PRIMARY KEY' => sub { 




3987




1





 





 




  
1
  




 





3



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




3988




 





 





 





 





 





 



         }, 




3989




 





 





 





 





 





 



   




3990




 





 





 





 





 





 



         'ALTER COLUMN' => sub { 




3991




6





 





 




  
6
  




 





9



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




3992




6





 





 





 





 





8



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




 




6





 





 





 





 





11



   




3993




6




  
 50
  




 





 





 





13



             return if $lx->{error}; 




3994




 





 





 





 





 





 



   




3995




 





 





 





 





 





 



             parse_choice($lx, 




3996




 





 





 





 





 





 



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




3997




 





 





 





 





 





 



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




3998




 





 





 





 





 





 



                 'SET NOT NULL'  => sub { 




3999




3





 





 





 





 





4



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




 




3





 





 





 





 





6



   




4000




 





 





 





 





 





 



                 }, 




4001




 





 





 





 





 





 



   




4002




 





 





 





 





 





 



                 'SET DEFAULT' => sub { 




4003




1





 





 





 





 





2



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




 




1





 





 





 





 





4



   




4004




1





 





 





 





 





1



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




 




1





 





 





 





 





5



   




4005




 





 





 





 





 





 



                 }, 




4006




 





 





 





 





 





 



   




4007




 





 





 





 





 





 



                 ($read_dialect{postgresql} ? 




4008




 





 





 





 





 





 



                     ( 




4009




 





 





 





 





 





 



                         'TYPE' => sub { 




4010




2





 





 





 





 





3



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




 




2





 





 





 





 





6



   




4011




2





 





 





 





 





4



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




 




2





 





 





 





 





5



   




4012




2




  
 50
  




 





 





 





5



                             return if $lx->{error}; 




4013




2




  
100
  




 





 





 





4



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




4014




1





 





 





 





 





2



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




 




1





 





 





 





 





3



   




4015




 





 





 





 





 





 



                             } 




4016




 





 





 





 





 





 



                         } 




4017




 





 





 





 





 





 



                     ) 




4018




6




  
 50
  




 





 





 





49



                 :   () 




4019




 





 





 





 





 





 



                 ), 




4020




 





 





 





 





 





 



             ); 




4021




 





 





 





 





 





 



         }, 




4022




 





 





 





 





 





 



   




4023




 





 





 





 





 





 



         'RENAME TO' => sub { 




4024




1





 





 




  
1
  




 





4



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




4025




1





 





 





 





 





2



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




 




1





 





 





 





 





3



   




4026




 





 





 





 





 





 



         }, 




4027




 





 





 





 





 





 



   




4028




 





 





 





 





 





 



         'ADD COLUMN' => sub { 




4029




2





 





 




  
2
  




 





3



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




4030




2




  
100
  




 





 





 





4



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




4031




1





 





 





 





 





2



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




 




1





 





 





 





 





18



   




4032




1




  
 50
  




 





 





 





3



                 return if $lx->{error}; 




4033




1





 





 





 





 





2



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




4034




 





 





 





 





 





 



             } 




4035




 





 





 





 





 





 



             else { 




4036




 





 





 





 





 





 



                 return unless 




4037




1




  
 50
  



  
 33
  




 





 





2



                     my $col1= parse_column_name($lx) 




4038




 





 





 





 





 





 



                 and my $spec= parse_column_spec($lx); 




4039




1





 





 





 





 





2



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




 




1





 





 





 





 





4



   




4040




 





 





 





 





 





 



             } 




4041




 





 





 





 





 





 



         }, 




4042




 





 





 





 





 





 



   




4043




 





 





 





 





 





 



         'ADD' => sub { 




4044




1





 





 




  
1
  




 





2



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




4045




1





 





 





 





 





2



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




 




1





 





 





 





 





4



   




4046




 





 





 





 





 





 



         }, 




4047




 





 





 





 





 





 



   




4048




 





 





 





 





 





 



         ($read_dialect{mysql} ? 




4049




 





 





 





 





 





 



             ( 




4050




 





 





 





 





 





 



                 'MODIFY COLUMN' => sub { 




4051




1





 





 




  
1
  




 





3



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




4052




 





 





 





 





 





 



                     return unless 




4053




1




  
 50
  



  
 33
  




 





 





3



                         my $col1= parse_column_name($lx) 




4054




 





 





 





 





 





 



                     and my $spec= parse_column_spec($lx); 




4055




1





 





 





 





 





2



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




 




1





 





 





 





 





3



   




4056




 





 





 





 





 





 



                 }, 




4057




 





 





 





 





 





 



                 'CHANGE COLUMN' => sub { 




4058




1





 





 




  
1
  




 





3



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




4059




 





 





 





 





 





 



                     return unless 




4060




1




  
 50
  



  
 33
  




 





 





3



                         my $col1= parse_column_name($lx) 




 




 





 




  
 33
  




 





 





 



   




4061




 





 





 





 





 





 



                     and my $col2= parse_column_name($lx) 




4062




 





 





 





 





 





 



                     and my $spec= parse_column_spec($lx); 




4063




1





 





 





 





 





2



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




 




1





 





 





 





 





3



   




4064




 





 





 





 





 





 



                 }, 




4065




 





 





 





 





 





 



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




4066




1





 





 




  
1
  




 





2



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




4067




 





 





 





 





 





 



                     return unless 




4068




1




  
 50
  




 





 





 





3



                         my $constraint= parse_constraint($lx); 




4069




1





 





 





 





 





2



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




 




1





 





 





 





 





3



   




4070




 





 





 





 





 





 



                 }, 




4071




 





 





 





 





 





 



                 'DROP INDEX' => sub { 




4072




1





 





 




  
1
  




 





3



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




4073




 





 





 





 





 





 



                     return unless 




4074




1




  
 50
  




 





 





 





5



                         my $index= parse_index($lx); 




4075




1





 





 





 





 





2



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




 




1





 





 





 





 





12



   




4076




 





 





 





 





 





 



                 }, 




4077




 





 





 





 





 





 



             ) 




4078




20




  
 50
  




 





 





 





272



         :   () 




4079




 





 





 





 





 





 



         ), 




4080




 





 





 





 





 





 



     ); 




4081




20




  
 50
  




 





 





 





488



     return if $lx->{error}; 




4082




 





 





 





 





 





 



   




4083




20





 





 





 





 





55



     lock_hash %$r; 




4084




20





 





 





 





 





703



     return $r; 




4085




 





 





 





 





 





 



 } 




4086




 





 





 





 





 





 



   




4087




 





 





 





 





 





 



 sub parse_stmt_interpol($) 




4088




 





 





 





 





 





 



 { 




4089




3





 





 




  
3
  



  
0
  




6



     my ($lx)= @_; 




4090




 





 





 





 





 





 



   




4091




 





 





 





 





 





 



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




4092




 





 





 





 





 





 



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




4093




3




  
 50
  



  
 33
  




 





 





20



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




4094




 





 





 





 





 





 



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




4095




 





 





 





 





 





 



     { 




4096



  
0
  




 





 





 





 





0



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




4097



  
0
  




 





 





 





 





0



         return; 




4098




 





 





 





 





 





 



     } 




4099




 





 





 





 





 





 



   




4100




3




  
 50
  




 





 





 





8



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




4101



  
0
  




 





 





 





 





0



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




4102



  
0
  




 





 





 





 





0



         return; 




4103




 





 





 





 





 





 



     } 




4104




 





 





 





 





 





 



   




4105




3




  
 50
  




 





 





 





8



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




4106



  
0
  




 





 





 





 





0



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




4107



  
0
  




 





 





 





 





0



         return; 




4108




 





 





 





 





 





 



     } 




4109




 





 





 





 





 





 



   




4110




 





 





 





 





 





 



     # But some may be: 




4111




3





 





 





 





 





9



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




4112




3





 





 





 





 





8



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




4113




3





 





 





 





 





10



     lexer_shift($lx); 




4114




 





 





 





 





 





 



   




4115




3





 





 





 





 





10



     lock_hash %$r; 




4116




3





 





 





 





 





88



     return $r; 




4117




 





 





 





 





 





 



 } 




4118




 





 





 





 





 





 



   




4119




 





 





 





 





 





 



 sub parse_select_stmt($) 




4120




 





 





 





 





 





 



 { 




4121




8





 





 




  
8
  



  
0
  




14



     my ($lx)= @_; 




4122




 





 





 





 





 





 



     return parse_choice($lx, 




4123




8





 





 




  
8
  




 





23



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




4124




 





 





 





 





 





 



   




4125




 





 





 





 





 





 



         'interpolStmt' => 'interpol', 




4126



  
0
  




 





 




  
0
  




 





0



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




4127




8





 





 





 





 





38



     ); 




4128




 





 





 





 





 





 



 } 




4129




 





 





 





 





 





 



   




4130




 





 





 





 





 





 



 sub parse_stmt($) 




4131




 





 





 





 





 





 



 { 




4132




228





 





 




  
228
  



  
0
  




341



     my ($lx)= @_; 




4133




 





 





 





 





 





 



     return parse_choice($lx, 




4134




176





 





 




  
176
  




 





293



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




4135




13





 





 




  
13
  




 





33



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




4136




9





 





 




  
9
  




 





23



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




4137




4





 





 




  
4
  




 





11



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




4138




 





 





 





 





 





 



   




4139




1368





 





 





 





 





1872



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




4140




2





 





 




  
2
  




 





6



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




4141




 





 





 





 





 





 



   




4142




456





 





 





 





 





839



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




4143




1





 





 




  
1
  




 





4



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




4144




 





 





 





 





 





 



   




4145




1368





 





 





 





 





2069



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




4146




20





 





 




  
20
  




 





36



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




4147




 





 





 





 





 





 



   




4148




 





 





 





 





 





 



         'interpolStmt' => 'interpol', 




4149




3





 





 




  
3
  




 





9



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




4150




228





 





 





 





 





1191



     ); 




4151




 





 





 





 





 





 



 } 




4152




 





 





 





 





 





 



   




4153




 





 





 





 





 





 



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




4154




 





 





 





 





 





 



 # Perl generation: 




4155




 





 





 





 





 





 



   




4156




 





 





 





 





 





 



   




4157




 





 





 





 





 





 



 ## First: creating a list of strings. 




4158




 





 





 





 





 





 



 # 




4159




 





 





 





 





 





 



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




4160




 





 





 





 





 





 



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




4161




 





 





 





 





 





 



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




4162




 





 





 





 





 





 



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




4163




 





 





 





 





 





 



 # 




4164




 





 





 





 





 





 



 #    my $s= str_new(); 




4165




 





 





 





 





 





 



 #    str_append_str  ($s, "a"); 




4166




 





 





 





 





 





 



 #    str_append_perl ($s, "b"); 




4167




 





 





 





 





 





 



 # 




4168




 





 





 





 





 





 



 # This would result in the following string: 




4169




 





 





 





 





 





 



 # 




4170




 





 





 





 





 





 



 #    'a',b 




4171




 





 





 





 





 





 



 # 




4172




 





 





 





 





 





 



 # Appending the comma separator is done automatically. 




4173




 





 





 





 





 





 



 # 




4174




 





 





 





 





 





 



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




4175




 





 





 





 





 





 



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




4176




 





 





 





 





 





 



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




4177




 





 





 





 





 





 



 # characters is done automatically by the str_ functions. 




4178




 





 





 





 





 





 



 # 




4179




 





 





 





 





 





 



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




4180




 





 





 





 





 





 



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




4181




 





 





 





 





 





 



 # 




4182




 





 





 





 





 





 



 #    my $s= str_new(); 




4183




 





 





 





 





 





 



 #    str_append_str  ($s, 'a'); 




4184




 





 





 





 





 





 



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




4185




 





 





 





 





 





 



 #    str_append_perl ($s, 'b'); 




4186




 





 





 





 





 





 



 #    str_target_line ($s, 2); 




4187




 





 





 





 





 





 



 #    str_append_str  ($s, 'c'); 




4188




 





 





 





 





 





 



 #    str_append_end  ($s); 




4189




 





 





 





 





 





 



 #    str_append_perl ($s, 'd'); 




4190




 





 





 





 





 





 



 # 




4191




 





 





 





 





 





 



 # This results in the following string in $s: 




4192




 





 





 





 





 





 



 # 




4193




 





 





 





 





 





 



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




4194




 





 





 





 





 





 



 #    'c'),d 




4195




 





 





 





 





 





 



 # 




4196




 





 





 





 





 





 



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




4197




 





 





 





 





 





 



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




4198




 





 





 





 





 





 



 # 




4199




 





 





 





 





 





 



 #    str_append_str  ($s, 'a'); 




4200




 





 





 





 





 





 



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




4201




 





 





 





 





 





 



 #    str_append_perl ($s, 'b'); 




4202




 





 





 





 





 





 



 #    str_append_str  ($s, 'c'); 




4203




 





 





 





 





 





 



 #    str_append_end  ($s); 




4204




 





 





 





 





 





 



 #    str_append_perl ($s, 'd'); 




4205




 





 





 





 





 





 



 # 




4206




 





 





 





 





 





 



 # This results in: 




4207




 





 





 





 





 





 



 # 




4208




 





 





 





 





 





 



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




4209




 





 





 





 





 





 



 # 




4210




 





 





 





 





 





 



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




4211




 





 





 





 





 





 



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




4212




 





 





 





 





 





 



 # _max1_if_scalar, are slightly inefficient and should later be eliminated 




4213




 





 





 





 





 





 



 # if possible. 




4214




 





 





 





 





 





 



 # 




4215




 





 





 





 





 





 



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




4216




 





 





 





 





 





 



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




4217




 





 





 





 





 





 



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




4218




 





 





 





 





 





 



 # problems, e.g. after map: 




4219




 





 





 





 





 





 



 # 




4220




 





 





 





 





 





 



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




4221




 





 





 





 





 





 



 # 




4222




 





 





 





 





 





 



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




4223




 





 





 





 





 





 



 # 




4224




 





 





 





 





 





 



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




4225




 





 





 





 





 





 



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




4226




 





 





 





 





 





 



 sub str_new($) 




4227




 





 





 





 





 





 



 { 




4228




278





 





 




  
278
  



  
0
  




364



     my ($line_start)= @_; 




4229




278





 





 





 





 





336



     my $text= []; 




4230




278





 





 





 





 





842



     my $s= { 




4231




 





 





 





 





 





 



         buff        => '', 




4232




 





 





 





 





 





 



         need_comma  => 0, 




4233




 





 





 





 





 





 



         line_is     => 1, 




4234




 





 





 





 





 





 



         line_target => 1, 




4235




 





 





 





 





 





 



         line_start  => $line_start, 




4236




 





 





 





 





 





 



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




4237




 





 





 





 





 





 



     }; 




4238




278





 





 





 





 





582



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




4239




278





 





 





 





 





4116



     return $s; 




4240




 





 





 





 





 





 



 } 




4241




 





 





 





 





 





 



   




4242




 





 





 





 





 





 



 sub str_append_raw($$) 




4243




 





 





 





 





 





 



 { 




4244




11884





 





 




  
11884
  



  
0
  




13996



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




4245




11884





 





 





 





 





13702



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




4246




11884





 





 





 





 





15379



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




4247




 





 





 





 





 





 



 } 




4248




 





 





 





 





 





 



   




4249




 





 





 





 





 





 



 sub str_sync_line($) 




4250




 





 





 





 





 





 



 { 




4251




5929





 





 




  
5929
  



  
0
  




6652



     my ($s)= @_; 




4252




5929





 





 





 





 





9202



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




4253




315





 





 





 





 





432



         str_append_raw ($s, "\n"); 




4254




 





 





 





 





 





 



     } 




4255




 





 





 





 





 





 



 } 




4256




 





 





 





 





 





 



 sub str_target_line($$) 




4257




 





 





 





 





 





 



 { 




4258




2885





 





 




  
2885
  



  
0
  




3749



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




4259




2885




  
 50
  




 





 





 





3950



     my_confess "undefined line number" unless defined $n; 




4260




2885





 





 





 





 





3466



     $s->{line_target}= $n; 




4261




 





 





 





 





 





 



 } 




4262




 





 





 





 





 





 



   




4263




 





 





 





 





 





 



 sub str_append_comma($) 




4264




 





 





 





 





 





 



 { 




4265




7553





 





 




  
7553
  



  
0
  




8085



     my ($s)= @_; 




4266




7553




  
100
  




 





 





 





10715



     if ($s->{need_comma}) { 




4267




3877





 





 





 





 





5975



         str_append_raw ($s, COMMA_STR); 




4268




3877





 





 





 





 





4582



         $s->{need_comma}= 0; 




4269




 





 





 





 





 





 



     } 




4270




 





 





 





 





 





 



 } 




4271




 





 





 





 





 





 



   




4272




 





 





 





 





 





 



 sub str_append_perl($$) 




4273




 





 





 





 





 





 



 { 




4274




4435





 





 




  
4435
  



  
0
  




5687



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




4275




4435




  
 50
  




 





 





 





6441



     if ($perl ne '') { 




4276




4435





 





 





 





 





6503



         str_append_comma($s); 




4277




4435





 





 





 





 





6351



         str_sync_line ($s); 




4278




4435





 





 





 





 





6678



         str_append_raw ($s, $perl); 




4279




4435





 





 





 





 





36657



         $s->{need_comma}= 1; 




4280




 





 





 





 





 





 



     } 




4281




 





 





 





 





 





 



 } 




4282




 





 





 





 





 





 



   




4283




 





 





 





 





 





 



 sub str_append_str($$) 




4284




 





 





 





 





 





 



 { 




4285




2690





 





 




  
2690
  



  
0
  




3213



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




4286




2690





 





 





 





 





3404



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




4287




 





 





 





 





 





 



 } 




4288




 





 





 





 





 





 



   




4289




 





 





 





 





 





 



 sub str_append_join($%) 




4290




 





 





 





 





 





 



 { 




4291




783





 





 




  
783
  



  
0
  




1963



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




4292




783





 




  
100
  




 





 





1993



     $opt{prefix}||=  ''; 




4293




783





 




  
100
  




 





 





2187



     $opt{suffix}||=  ''; 




4294




783





 




  
100
  




 





 





1985



     $opt{sep}||=     ''; 




4295




 





 





 





 





 





 



   




4296




783





 





 





 





 





1276



     str_append_comma($s); 




4297




783





 





 





 





 





1162



     str_sync_line  ($s); 




4298




783




  
100
  



  
 66
  




 





 





2904



     if ($opt{joinfunc}) { 




 




 




  
100
  



  
 66
  




 





 





 



   




 




 




  
100
  



  
 66
  




 





 





 



   




 




 





 




  
 66
  




 





 





 



   




 




 





 




  
 66
  




 





 





 



   




4299




 





 





 





 





 





 



         # special case: ignore all other settings 




4300




94





 





 





 





 





244



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




4301




94





 





 





 





 





128



         $s->{need_comma}= 0; 




4302




94





 





 





 





 





119



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




 




94





 





 





 





 





222



   




4303




 





 





 





 





 





 



     } 




4304




 





 





 





 





 





 



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




4305




 





 





 





 





 





 



            $opt{suffix} eq '' && 




4306




 





 





 





 





 





 



            ( 




4307




 





 





 





 





 





 



                $opt{never_empty} || 




4308




 





 





 





 





 





 



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




4309




 





 





 





 





 





 



            )) 




4310




 





 





 





 





 





 



     { 




4311




 





 





 





 





 





 



         # simple case 1 




4312




262





 





 





 





 





443



         str_append_raw ($s, 'join('); 




4313




262





 





 





 





 





541



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




4314




262





 





 





 





 





355



         $s->{need_comma}= 1; 




4315




262





 





 





 





 





307



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




 




262





 





 





 





 





518



   




4316




 





 





 





 





 





 



     } 




4317




 





 





 





 





 





 



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




4318




 





 





 





 





 





 



            ( 




4319




 





 





 





 





 





 



                $opt{never_empty} || 




4320




 





 





 





 





 





 



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




4321




 





 





 





 





 





 



            )) 




4322




 





 





 





 





 





 



     { 




4323




 





 





 





 





 





 



         # simple case 2 




4324




21





 





 





 





 





34



         str_append_raw ($s, 'join('); 




4325




21





 





 





 





 





36



         str_append_str ($s, ''); 




4326




 





 





 





 





 





 



   




4327




21




  
 50
  




 





 





 





40



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




4328




21





 





 





 





 





41



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




4329




 





 





 





 





 





 



         } 




4330




 





 





 





 





 





 



   




4331




21





 




  
100
  




 





 





26



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




 




21





 





 





 





 





71



   




4332




 





 





 





 





 





 



     } 




4333




 





 





 





 





 





 



     else { 




4334




 





 





 





 





 





 



         # complex case: 




4335




406





 





 





 





 





835



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




4336




406





 





 





 





 





897



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




4337




 





 





 





 





 





 



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




4338




 





 





 





 





 





 



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




4339




 





 





 





 





 





 



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




4340




 





 





 





 





 





 



             # nicer error messages if necessary. 




4341




406





 





 





 





 





579



         str_append_comma($s); 




4342




406





 





 





 





 





741



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




4343




406





 





 





 





 





668



         str_append_comma($s); 




4344




406





 





 





 





 





707



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




4345




406





 





 





 





 





724



         str_append_comma($s); 




4346




406





 





 





 





 





714



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




4347




406





 





 





 





 





699



         str_append_comma($s); 




4348




406





 





 





 





 





705



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




4349




406





 





 





 





 





468



         $s->{need_comma}= 1; 




4350




406





 





 





 





 





431



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




 




406





 





 





 





 





816



   




4351




 





 





 





 





 





 



     } 




4352




 





 





 





 





 





 



 } 




4353




 





 





 





 





 





 



   




4354




 





 





 





 





 





 



 sub str_append_map($$) 




4355




 





 





 





 





 





 



 { 




4356




178





 





 




  
178
  



  
0
  




338



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




4357




178





 





 





 





 





399



     str_append_comma($s); 




4358




178





 





 





 





 





314



     str_sync_line  ($s); 




4359




178





 





 





 





 





431



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




4360




178





 





 





 





 





269



     $s->{need_comma}= 0; 




4361




178





 





 





 





 





194



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




 




178





 





 





 





 





303



   




4362




 





 





 





 





 





 



 } 




4363




 





 





 





 





 





 



   




4364




 





 





 





 





 





 



 sub str_append_funcall_begin($$$) 




4365




 





 





 





 





 





 



 { 




4366




532





 





 




  
532
  



  
0
  




686



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




4367




532





 





 





 





 





908



     str_append_comma($s); 




4368




532





 





 





 





 





878



     str_sync_line  ($s); 




4369




532




  
100
  




 





 





 





724



     if ($in_list) { 




4370




280





 





 





 





 





564



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




4371




 





 





 





 





 





 



     } 




4372




 





 





 





 





 





 



     else { 




4373




252





 





 





 





 





470



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




4374




 





 





 





 





 





 



     } 




4375




532





 





 





 





 





707



     $s->{need_comma}= 0; 




4376




532





 





 





 





 





552



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




 




532





 





 





 





 





1020



   




4377




 





 





 





 





 





 



 } 




4378




 





 





 





 





 





 



   




4379




 





 





 





 





 





 



 sub str_append_funcall_end($$) 




4380




 





 





 





 





 





 



 { 




4381




532





 





 




  
532
  



  
0
  




708



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




4382




532




  
100
  




 





 





 





812



     if ($in_list) { 




4383




280





 





 





 





 





458



         str_append_perl ($s, '$_'); 




4384




280





 





 





 





 





459



         str_append_raw ($s, ') }'); 




4385




280





 





 





 





 





415



         $s->{need_comma}= 0; 




4386




 





 





 





 





 





 



     } 




4387




 





 





 





 





 





 



 } 




4388




 





 





 





 





 





 



   




4389




 





 





 





 





 





 



 sub str_append_funcall($$$) 




4390




 





 





 





 





 





 



 { 




4391




454





 





 




  
454
  



  
0
  




706



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




4392




454





 





 





 





 





840



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




4393




454





 





 





 





 





641



     str_append_funcall_end   ($s, $in_list); 




4394




 





 





 





 





 





 



 } 




4395




 





 





 





 





 





 



   




4396




 





 





 





 





 





 



 sub str_append_end($) 




4397




 





 





 





 





 





 



 # Terminator for: 




4398




 





 





 





 





 





 



 #   str_append_map 




4399




 





 





 





 





 





 



 #   str_append_funcall 




4400




 





 





 





 





 





 



 #   str_append_join 




4401




 





 





 





 





 





 



 { 




4402




1483





 





 




  
1483
  



  
0
  




1942



     my ($s)= @_; 




4403




1483





 





 





 





 





1436



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




 




1483





 





 





 





 





2231



   




4404




1483




  
100
  




 





 





 





2370



     if (defined $end_str) { 




4405




18





 





 





 





 





33



         str_append_str($s, $end_str); 




4406




 





 





 





 





 





 



     } 




4407




1483





 





 





 





 





2365



     str_append_raw ($s, ')'); 




4408




1483





 





 





 





 





35465



     $s->{need_comma}= 1; 




4409




 





 





 





 





 





 



 } 




4410




 





 





 





 





 





 



   




4411




 





 





 





 





 





 



 sub str_get_string($) 




4412




 





 





 





 





 





 



 { 




4413




275





 





 




  
275
  



  
0
  




397



     my ($s)= @_; 




4414




275




  
 50
  




 





 





 





554



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




4415




275





 





 





 





 





580



     return $s->{buff}; 




4416




 





 





 





 





 





 



 } 




4417




 





 





 





 





 





 



   




4418




 





 





 





 





 





 



 # Now start appending more complex things: 




4419




 





 





 





 





 





 



   




4420




 





 





 





 





 





 



 sub str_append_thing($$$$); 




4421




 





 





 





 





 





 



   




4422




 





 





 





 





 





 



 sub str_append_list($$$;%) 




4423




 





 





 





 





 





 



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




4424




 





 





 





 





 





 



 # so str_append_join() can optimise. 




4425




 





 





 





 





 





 



 { 




4426




365





 





 




  
365
  



  
0
  




784



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




4427




365





 





 





 





 





969



     local $SIG{__DIE__}= \&my_confess; 




4428




 





 





 





 





 





 



   




4429




 





 





 





 





 





 



     # set line to first element (if any): 




4430




365




  
 50
  




 





 





 





688



     if (scalar(@$list)) { 




4431




365





 





 





 





 





668



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




4432




 





 





 





 





 





 



     } 




4433




 





 





 





 





 





 



   




4434




 





 





 





 





 





 



     # joining, delimiters, result if empty: 




4435




 





 





 





 





 





 



     str_append_join($str, 




4436




 





 





 





 





 





 



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




4437




 





 





 





 





 





 



         prefix   => $opt{prefix}, 




4438




 





 





 





 





 





 



         suffix   => $opt{suffix}, 




4439




 





 





 





 





 





 



         result0  => $opt{result0}, 




4440




365




  
100
  




 





 





 





1338



     ); 




4441




 





 





 





 





 





 



   




4442




 





 





 





 





 





 



     # map? 




4443




365




  
100
  




 





 





 





851



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




4444




1





 





 





 





 





3



         str_append_comma ($str); 




4445




1





 





 





 





 





2



         str_sync_line    ($str); 




4446




1





 





 





 





 





3



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




4447




1





 





 





 





 





1



         $str->{need_comma}= 0; 




4448




 





 





 





 





 





 



     }; 




4449




 





 





 





 





 





 



   




4450




 





 





 





 





 





 



     # the list: 




4451




365





 





 





 





 





524



     for my $l (@$list) { 




4452




439





 





 





 





 





749



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




4453




 





 





 





 





 





 



     } 




4454




 





 





 





 





 





 



   




4455




 





 





 





 





 





 



     # end: 




4456




363





 





 





 





 





805



     str_append_end($str); 




4457




 





 





 





 





 





 



 } 




4458




 





 





 





 





 





 



   




4459




 





 





 





 





 





 



 sub interpol_set_context ($$); 




4460




 





 





 





 





 





 



   




4461




 





 





 





 





 





 



 sub perl_val($$$) 




4462




 





 





 





 





 





 



 { 




4463




1068





 





 




  
1068
  



  
0
  




1497



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




4464




 





 





 





 





 





 



   




4465




 





 





 





 





 





 



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




4466




 





 





 





 





 





 



         if $allow && 




4467




1068




  
 50
  



  
 66
  




 





 





2164



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




 




96





 





 





 





 





211



   




4468




 





 





 





 





 





 



   




4469




 





 





 





 





 





 



     return switch($token->{kind}, 




4470




535





 





 




  
535
  




 





867



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




4471




12





 





 




  
12
  




 





49



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




4472




2





 





 




  
2
  




 





8



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




4473




2





 





 




  
2
  




 





7



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




4474




1





 





 




  
1
  




 





4



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




4475



  
0
  




 





 




  
0
  




 





0



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




4476



  
0
  




 





 




  
0
  




 





0



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




4477




1





 





 




  
1
  




 





4



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




4478




 





 





 





 





 





 



         -default => sub { 




4479




515




  
 50
  




 




  
515
  




 





1581



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




4480




515





 





 





 





 





975



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




4481




 





 





 





 





 





 



             } 




4482




 





 





 





 





 





 



             else { 




4483



  
0
  




 





 





 





 





0



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




4484




 





 





 





 





 





 



             } 




4485




 





 





 





 





 





 



         } 




4486




1068





 





 





 





 





8125



     ); 




4487




 





 





 





 





 





 



 } 




4488




 





 





 





 





 





 



   




4489




 





 





 





 





 





 



 sub perl_val_list($$$) 




4490




 





 





 





 





 





 



 { 




4491




46





 





 




  
46
  



  
0
  




87



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




4492




46





 





 





 





 





119



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




4493




 





 





 





 





 





 



   




4494




46




  
100
  




 





 





 





303



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




4495




9





 





 





 





 





35



         return "sort keys $s"; 




4496




 





 





 





 





 





 



     } 




4497




 





 





 





 





 





 



     else { 




4498




37





 





 





 





 





115



         return $s; 




4499




 





 





 





 





 





 



     } 




4500




 





 





 





 





 





 



 } 




4501




 





 





 





 





 





 



   




4502




 





 





 





 





 





 



 sub token_pos($) 




4503




 





 





 





 





 





 



 { 




4504




3





 





 




  
3
  



  
0
  




8



     my ($token)= @_; 




4505




3





 





 





 





 





32



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




4506




 





 





 





 





 





 



 } 




4507




 





 





 





 





 





 



   




4508




 





 





 





 





 





 



 sub lx_pos($) 




4509




 





 





 





 





 





 



 { 




4510




2





 





 




  
2
  



  
0
  




4



     my ($lx)= @_; 




4511




2





 





 





 





 





21



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




4512




 





 





 





 





 





 



 } 




4513




 





 





 





 





 





 



   




4514




 





 





 





 





 





 



 sub croak_unless_scalar($) 




4515




 





 





 





 





 





 



 { 




4516




870





 





 




  
870
  



  
0
  




1293



     my ($token)= @_; 




4517




 





 





 





 





 





 



     die token_pos($token).": ". 




4518




 





 





 





 





 





 



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




4519




870




  
100
  



  
 66
  




 





 





2687



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




4520




 





 





 





 





 





 



 } 




4521




 





 





 





 





 





 



   




4522




 





 





 





 





 





 



 sub str_append_typed($$$$$%) 




4523




 





 





 





 





 





 



 { 




4524




476





 





 




  
476
  



  
0
  




963



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




4525




476





 





 





 





 





849



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




4526




 





 





 





 





 





 



   




4527




476




  
100
  



  
100
  




 





 





3291



     if (!$in_list || 




 




 




  
100
  




 





 





 





 



   




4528




 





 





 





 





 





 



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




4529




 





 





 





 





 





 



     { 




4530




360





 





 





 





 





706



         croak_unless_scalar ($thing->{token}); 




4531




358





 





 





 





 





902



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




4532




 





 





 





 





 





 



     } 




4533




 





 





 





 





 





 



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




4534




19




  
100
  




 





 





 





49



         if ($opt{hash}) { 




 




 




  
 50
  




 





 





 





 



   




4535




16





 





 





 





 





61



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




4536




 





 





 





 





 





 



         } 




4537




 





 





 





 





 





 



         elsif ($opt{hashkeys}) { 




4538




3





 





 





 





 





14



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




4539




3





 





 





 





 





10



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




4540




3





 





 





 





 





7



             str_append_end  ($str); 




4541




 





 





 





 





 





 



         } 




4542




 





 





 





 





 





 



         else { 




4543



  
0
  




 





 





 





 





0



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




4544




 





 





 





 





 





 



         } 




4545




 





 





 





 





 





 



     } 




4546




 





 





 





 





 





 



     else { 




4547




97





 





 





 





 





352



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




4548




97





 





 





 





 





193



         str_append_perl ($str, $q_val); 




4549




97





 





 





 





 





185



         str_append_end  ($str); 




4550




 





 





 





 





 





 



     } 




4551




 





 





 





 





 





 



 } 




4552




 





 





 





 





 





 



   




4553




 





 





 





 





 





 



 sub is_multicol($); 




4554




 





 





 





 





 





 



 sub is_multicol($) 




4555




 





 





 





 





 





 



 { 




4556




526





 





 




  
526
  



  
0
  




686



     my ($thing) = @_; 




4557




 





 





 





 





 





 



     return switch ($thing->{kind}, 




4558




 





 





 





 





 





 



         'ExprAs' => sub{ 




4559




170





 





 




  
170
  




 





283



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




4560




 





 





 





 





 





 



         }, 




4561




 





 





 





 





 





 



         'Expr' => sub { 




4562




170




  
100
  




 




  
170
  




 





355



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




4563




93





 





 





 





 





161



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




4564




 





 





 





 





 





 



             } 




4565




77





 





 





 





 





567



             return 0; 




4566




 





 





 





 





 





 



         }, 




4567




 





 





 





 





 





 



         'Column' => sub { 




4568




93





 





 




  
93
  




 





173



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




4569




 





 





 





 





 





 



         }, 




4570




 





 





 





 





 





 



         '*' => sub { 




4571




7





 





 




  
7
  




 





115



             return 1; 




4572




 





 





 





 





 





 



         }, 




4573




 





 





 





 





 





 



         'interpol' => sub { 




4574




21





 





 




  
21
  




 





268



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




4575




 





 





 





 





 





 



         }, 




4576




 





 





 





 





 





 



         -default => sub { 




4577




65





 





 




  
65
  




 





861



             return 0; 




4578




 





 





 





 





 





 



         }, 




4579




526





 





 





 





 





3023



     ); 




4580




 





 





 





 





 





 



 } 




4581




 





 





 





 





 





 



   




4582




 





 





 





 





 





 



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




4583




 





 





 





 





 





 



 my %ident_context= ( 




4584




 





 





 





 





 





 



     'Column' => { 




4585




 





 





 





 





 





 



         1 => [ 'Column' ], 




4586




 





 





 





 





 





 



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




4587




 





 





 





 





 





 



     }, 




4588




 





 





 





 





 





 



 ); 




4589




 





 





 





 





 





 



   




4590




 





 





 





 





 





 



 sub str_append_ident_chain($$$@) 




4591




 





 





 





 





 





 



 { 




4592




519





 





 




  
519
  



  
0
  




854



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




4593




519





 





 





 





 





811



     my $func= lc($family); 




4594




 





 





 





 





 





 



   




4595




519





 




  
 66
  




 





 





1669



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




4596




 





 





 





 





 





 



               (scalar(@token) == 1 ? 




4597




 





 





 





 





 





 



                   [ $family ] 




4598




 





 





 





 





 





 



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




4599




 





 





 





 





 





 



               ); 




4600




 





 





 





 





 





 



   




4601




519





 





 





 





 





764



     my $n= scalar(@token); 




4602




519





 





 





 





 





991



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




 




561





 





 





 





 





1393



   




4603




 





 





 





 





 





 



   




4604




519




  
100
  



  
100
  




 





 





1413



     if (!$in_list || 




 




 




  
100
  




 





 





 





 



   




4605




 





 





 





 





 





 



         scalar(@non_scalar_i) == 0) 




4606




 





 





 





 





 





 



     { 




4607




477





 





 





 





 





717



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




 




510





 





 





 





 





756



   




4608




 





 





 





 





 





 



         my $q_vals= join(",", 




4609




 





 





 





 





 





 



                         map 




4610




476





 





 





 





 





745



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




 




509





 





 





 





 





884



   




4611




 





 





 





 





 





 



                         0..$n-1 




4612




 





 





 





 





 





 



                     ); 




4613




476





 





 





 





 





1433



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




4614




 





 





 





 





 





 



     } 




4615




 





 





 





 





 





 



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




4616




 





 





 





 





 





 



         str_append_map ($str, 




4617




 





 





 





 





 





 



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




4618




 





 





 





 





 





 



                 join(",", 




4619




 





 





 





 





 





 



                     map { 




4620




38




  
100
  




 





 





 





131



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




 




43





 





 





 





 





202



   




4621




 





 





 





 





 





 



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




4622




 





 





 





 





 





 



                         :   '$_' 




4623




 





 





 





 





 





 



                         ) 




4624




 





 





 





 





 





 



                     } 




4625




 





 





 





 





 





 



                     0..$n-1 




4626




 





 





 





 





 





 



                 ). 




4627




 





 





 





 





 





 



             ")" 




4628




 





 





 





 





 





 



         ); 




4629




38





 





 





 





 





114



         my ($i)= @non_scalar_i; 




4630




38





 





 





 





 





91



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




4631




38





 





 





 





 





69



         str_append_end  ($str); 




4632




 





 





 





 





 





 



     } 




4633




 





 





 





 





 





 



     else { 




4634




4




  
 50
  




 





 





 





13



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




 




8





 





 





 





 





22



   




4635




 





 





 





 





 





 



         str_append_perl ($str, 




4636




 





 





 





 





 





 



             __PACKAGE__."::$f_ident(". 




4637




 





 





 





 





 





 



                 join(",", 




4638




 





 





 





 





 





 



                     map { 




4639




4




  
 50
  




 





 





 





15



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




 




8





 





 





 





 





23



   




4640




 





 





 





 





 





 



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




4641




 





 





 





 





 





 



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




4642




 





 





 





 





 





 



                         ) 




4643




 





 





 





 





 





 



                     } 




4644




 





 





 





 





 





 



                     0..$n-1 




4645




 





 





 





 





 





 



                 ). 




4646




 





 





 





 





 





 



             ")" 




4647




 





 





 





 





 





 



         ); 




4648




 





 





 





 





 





 



     } 




4649




 





 





 





 





 





 



 } 




4650




 





 





 





 





 





 



   




4651




 





 





 





 





 





 



 sub str_append_limit ($$$) 




4652




 





 





 





 





 





 



 { 




4653




111





 





 




  
111
  



  
0
  




189



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




4654




 





 





 





 





 





 



   




4655




111




  
100
  



  
 66
  




 





 





401



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




4656




5





 





 





 





 





10



         my $limit_cnt_str= 'undef'; 




4657




5




  
 50
  




 





 





 





13



         if ($limit_cnt) { 




4658




5





 





 





 





 





17



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




4659




 





 





 





 





 





 



         } 




4660




 





 





 





 





 





 



   




4661




5





 





 





 





 





40



         my $limit_offset_str= 'undef'; 




4662




5




  
100
  




 





 





 





41



         if ($limit_offset) { 




4663




3





 





 





 





 





11



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




4664




 





 





 





 





 





 



         } 




4665




 





 





 





 





 





 



   




4666




5





 





 





 





 





37



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




4667




 





 





 





 





 





 



     } 




4668




 





 





 





 





 





 



 } 




4669




 





 





 





 





 





 



   




4670




 





 





 





 





 





 



 sub str_append_parens($$$) 




4671




 





 





 





 





 





 



 { 




4672




18





 





 




  
18
  



  
0
  




31



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




4673




18




  
 50
  




 





 





 





51



     if ($in_list) { 




4674



  
0
  




 





 





 





 





0



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




4675



  
0
  




 





 





 





 





0



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




4676



  
0
  




 





 





 





 





0



         str_append_end ($str); 




4677




 





 





 





 





 





 



     } 




4678




 





 





 





 





 





 



     else { 




4679




18





 





 





 





 





50



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




4680




18





 





 





 





 





43



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




4681




18





 





 





 





 





723



         str_append_end   ($str); 




4682




 





 





 





 





 





 



     } 




4683




 





 





 





 





 





 



 } 




4684




 





 





 





 





 





 



   




4685




 





 





 





 





 





 



 sub str_append_table_key($$$) 




4686




 





 





 





 





 





 



 { 




4687




3





 





 




  
3
  



  
0
  




6



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




4688




3





 





 





 





 





7



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




4689




3




  
 50
  




 





 





 





8



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




4690




3





 





 





 





 





8



         str_append_str   ($str, 'CONSTRAINT'); 




4691




3





 





 





 





 





5



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




4692




 





 





 





 





 





 



     } 




4693




3





 





 





 





 





74



     str_append_str  ($str, $type); 




4694




3




  
100
  




 





 





 





8



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




4695




1





 





 





 





 





4



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




4696




 





 





 





 





 





 



     } 




4697




3





 





 





 





 





9



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




4698




3





 





 





 





 





5



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




 




3





 





 





 





 





6



   




4699



  
0
  




 





 





 





 





0



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




4700




 





 





 





 





 





 



     } 




4701




3




  
100
  




 





 





 





7



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




4702




2





 





 





 





 





3



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




4703




 





 





 





 





 





 



     } 




4704




3





 





 





 





 





58



     str_append_end ($str); 




4705




 





 





 





 





 





 



 } 




4706




 





 





 





 





 





 



   




4707




 





 





 





 





 





 



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




4708




 





 





 





 





 





 



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




4709




 





 





 





 





 





 



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




4710




 





 





 





 





 





 



 # objects of the correct type. 




4711




 





 





 





 





 





 



 # 




4712




 





 





 





 





 





 



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




4713




 





 





 





 





 





 



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




4714




 





 





 





 





 





 



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




4715




 





 





 





 





 





 



 # 




4716




 





 





 





 





 





 



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




4717




 





 





 





 





 





 



 # each represent a small piece of the SQL command. 




4718




 





 





 





 





 





 



 # 




4719




 





 





 





 





 





 



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




4720




 





 





 





 





 





 



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




4721




 





 





 





 





 





 



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




4722




 





 





 





 





 





 



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




4723




 





 





 





 





 





 



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




4724




 





 





 





 





 





 



 # the code that generates a SELECT statement from scratch appends 




4725




 





 





 





 





 





 



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




4726




 





 





 





 





 





 



 # join() is generated. 




4727




 





 





 





 





 





 



 # 




4728




 





 





 





 





 





 



 sub str_append_thing($$$$) 




4729




 





 





 





 





 





 



 { 




4730




2864





 





 




  
2864
  



  
0
  




4086



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




4731




2864





 





 





 





 





6941



     local $SIG{__DIE__}= \&my_confess; 




4732




 





 





 





 





 





 



   




4733




 





 





 





 





 





 



     # simple things to append: 




4734




2864




  
100
  




 





 





 





4978



     unless (defined $thing) { 




4735




16





 





 





 





 





32



         str_append_perl ($str, 'undef'); 




4736




16





 





 





 





 





35



         return; 




4737




 





 





 





 





 





 



     } 




4738




2848




  
100
  




 





 





 





4377



     unless (ref $thing) { 




4739




384





 





 





 





 





627



         str_append_str ($str, $thing); 




4740




384





 





 





 





 





791



         return; 




4741




 





 





 





 





 





 



     } 




4742




2464




  
100
  




 





 





 





3926



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




4743




1





 





 





 





 





3



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




4744




1





 





 





 





 





3



         return; 




4745




 





 





 





 





 





 



     } 




4746




 





 





 





 





 





 



   




4747




 





 





 





 





 





 



     # normal structure: 




4748




2463





 





 





 





 





4749



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




4749




 





 





 





 





 





 



   




4750




 





 





 





 





 





 



     switch($thing->{kind}, 




4751




 





 





 





 





 





 



         'Stmt' => sub { 




4752




 





 





 





 





 





 



             switch($thing->{type}, 




4753




 





 





 





 





 





 



                 'Select' => sub { 




4754




 





 





 





 





 





 



                     # find out type name depending on number of columns: 




4755




183





 





 





 





 





214



                     my $type_name = 'SelectStmt'; 




4756




183




  
100
  




 





 





 





200



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




 




183





 





 





 





 





443



   




4757




170




  
100
  




 





 





 





339



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




4758




151





 





 





 





 





223



                             $type_name = 'SelectStmtSingle'; 




4759




 





 





 





 





 





 



                         } 




4760




 





 





 





 





 





 



                     } 




4761




 





 





 





 





 





 



   




4762




 





 





 





 





 





 



                     # generate: 




4763




183





 





 





 





 





1032



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




4764




183





 





 





 





 





336



                     str_append_join ($str, never_empty => 1); 




4765




 





 





 





 





 





 



   




4766




 





 





 





 





 





 



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




4767




 





 





 





 





 





 



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




4768




183





 





 





 





 





282



                                             @{ $thing->{opt_front} } 




 




183





 





 





 





 





660



   




4769




 





 





 





 





 





 



                                   ).' ' 




4770




 





 





 





 





 





 



                     ); 




4771




 





 





 





 





 





 



   




4772




181




  
100
  




 





 





 





427



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




4773




99





 





 





 





 





212



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




4774




 





 





 





 





 





 



   




4775




99




  
 50
  




 





 





 





224



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




4776




99




  
100
  




 





 





 





184



                             if (@$x) { 




4777




5





 





 





 





 





15



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




4778




5





 





 





 





 





10



                                 for my $xi (@$x) { 




4779




6





 





 





 





 





16



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




4780




 





 





 





 





 





 



                                 } 




4781




5





 





 





 





 





15



                                 str_append_end ($str); 




4782




 





 





 





 





 





 



                             } 




4783




 





 





 





 





 





 



                         } 




4784




99




  
100
  




 





 





 





205



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




4785




44





 





 





 





 





100



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




4786




44





 





 





 





 





87



                             str_append_str   ($str, ' WHERE '); 




4787




44





 





 





 





 





87



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




4788




 





 





 





 





 





 



                         } 




4789




98




  
100
  




 





 





 





2093



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




4790




6





 





 





 





 





11



                             my $suffix= ''; 




4791




6




  
100
  




 





 





 





12



                             if ($thing->{group_by_with_rollup}) { 




4792




1





 





 





 





 





2



                                 $suffix= ' WITH ROLLUP'; 




4793




 





 





 





 





 





 



                             } 




4794




6





 





 





 





 





15



                             str_append_list ($str, $x, NO_PARENS, 




4795




 





 





 





 





 





 



                                 prefix  => ' GROUP BY ', 




4796




 





 





 





 





 





 



                                 suffix  => $suffix, 




4797




 





 





 





 





 





 



                                 result0 => '', 




4798




 





 





 





 





 





 



                             ); 




4799




 





 





 





 





 





 



                         } 




4800




98




  
100
  




 





 





 





206



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




4801




1





 





 





 





 





4



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




4802




1





 





 





 





 





2



                             str_append_str   ($str, ' HAVING '); 




4803




1





 





 





 





 





3



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




4804




 





 





 





 





 





 



                         } 




4805




98




  
100
  




 





 





 





270



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




4806




8





 





 





 





 





17



                             str_append_list ($str, $x, NO_PARENS, 




4807




 





 





 





 





 





 



                                 prefix  => ' ORDER BY ', 




4808




 





 





 





 





 





 



                                 result0 => '' 




4809




 





 





 





 





 





 



                             ); 




4810




 





 





 





 





 





 



                         } 




4811




98





 





 





 





 





239



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




4812




 





 





 





 





 





 



   




4813




98





 





 





 





 





128



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




 




98





 





 





 





 





267



   




4814




 





 





 





 





 





 



                     } 




4815




 





 





 





 





 





 



   




4816




180





 





 





 





 





347



                     str_append_end ($str); 




4817




180





 





 





 





 





236



                     str_append_end ($str); 




4818




 





 





 





 





 





 



                 }, 




4819




 





 





 





 





 





 



                 'Delete' => sub { 




4820




4





 





 





 





 





11



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




4821




4





 





 





 





 





10



                     str_append_join ($str, never_empty => 1); 




4822




 





 





 





 





 





 



   




4823




 





 





 





 





 





 



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




4824




 





 





 





 





 





 



                         prefix => 




4825




 





 





 





 





 





 



                             join(' ', 




4826




 





 





 





 





 





 



                                 'DELETE', 




4827




4





 





 





 





 





8



                                 @{ $thing->{opt_front} }, 




4828




 





 





 





 





 





 



                                 'FROM', 




4829




4





 





 





 





 





8



                                 @{ $thing->{from_opt_front} }, 




 




4





 





 





 





 





17



   




4830




 





 





 





 





 





 



                             ).' ' 




4831




 





 





 





 





 





 



                     ); 




4832




 





 





 





 





 





 



   




4833




4




  
100
  




 





 





 





14



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




4834




2





 





 





 





 





5



                         str_append_list ($str, $x, NO_PARENS, 




4835




 





 





 





 





 





 



                             prefix => ' USING ', 




4836




 





 





 





 





 





 



                             result0 => '' 




4837




 





 





 





 





 





 



                         ); 




4838




 





 





 





 





 





 



                     } 




4839




 





 





 





 





 





 



   




4840




4




  
 50
  




 





 





 





21



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




4841




4




  
100
  




 





 





 





12



                         if (@$x) { 




4842




2





 





 





 





 





7



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




4843




2





 





 





 





 





4



                             for my $xi (@$x) { 




4844




3





 





 





 





 





8



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




4845




 





 





 





 





 





 



                             } 




4846




2





 





 





 





 





6



                             str_append_end ($str); 




4847




 





 





 





 





 





 



                         } 




4848




 





 





 





 





 





 



                     } 




4849




4




  
100
  




 





 





 





10



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




4850




3





 





 





 





 





9



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




4851




3





 





 





 





 





6



                         str_append_str   ($str, ' WHERE '); 




4852




3





 





 





 





 





8



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




4853




 





 





 





 





 





 



                     } 




4854




4




  
 50
  




 





 





 





126



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




4855



  
0
  




 





 





 





 





0



                         str_append_list ($str, $x, NO_PARENS, 




4856




 





 





 





 





 





 



                             prefix  => ' ORDER BY ', 




4857




 





 





 





 





 





 



                             result0 => '' 




4858




 





 





 





 





 





 



                         ); 




4859




 





 





 





 





 





 



                     } 




4860




4





 





 





 





 





21



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




4861




 





 





 





 





 





 



   




4862




4





 





 





 





 





19



                     str_append_end ($str); 




4863




4





 





 





 





 





8



                     str_append_end ($str); 




4864




 





 





 





 





 





 



                 }, 




4865




 





 





 





 





 





 



                 'Insert' => sub { 




4866




13





 





 





 





 





34



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




4867




13





 





 





 





 





31



                     str_append_join ($str, never_empty => 1); 




4868




 





 





 





 





 





 



   




4869




 





 





 





 





 





 



                     str_append_str ($str, 




4870




 





 





 





 





 





 



                         join(' ', 




4871




 





 





 





 





 





 



                             'INSERT', 




4872




13





 





 





 





 





18



                             @{ $thing->{opt_front} }, 




 




13





 





 





 





 





51



   




4873




 





 





 





 





 





 



                             'INTO', 




4874




 





 





 





 





 





 



                         ).' ' 




4875




 





 





 





 





 





 



                     ); 




4876




 





 





 





 





 





 



   




4877




13





 





 





 





 





33



                     str_append_thing ($str, $thing->{into}, NOT_IN_LIST, NO_PARENS); 




4878




 





 





 





 





 





 



   




4879




13




  
100
  




 





 





 





429



                     if (my $col= $thing->{column}) { 




4880




5





 





 





 





 





16



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




4881




 





 





 





 





 





 



                     } 




4882




 





 





 





 





 





 



   




4883




13




  
100
  




 





 





 





49



                     if (my $val= $thing->{value}) { 




 




 




  
 50
  




 





 





 





 



   




 




 




  
  0
  




 





 





 





 



   




 




 




  
  0
  




 





 





 





 



   




4884




5





 





 





 





 





14



                         str_append_str  ($str, ' VALUES '); 




4885




5





 





 





 





 





16



                         str_append_list ($str, $val, NO_PARENS); 




4886




 





 





 





 





 





 



                     } 




4887




 





 





 





 





 





 



                     elsif (my $set= $thing->{set}) { 




4888




8





 





 





 





 





24



                         str_append_funcall ($str, __PACKAGE__."::set2values", NOT_IN_LIST); 




4889




8





 





 





 





 





14



                         for my $l (@$set) { 




4890




16





 





 





 





 





33



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




4891




 





 





 





 





 





 



                         } 




4892




8





 





 





 





 





208



                         str_append_end ($str); 




4893




 





 





 





 





 





 



                     } 




4894




 





 





 





 





 





 



                     elsif (my $sel= $thing->{select}) { 




4895



  
0
  




 





 





 





 





0



                         str_append_str   ($str, ' '); 




4896



  
0
  




 





 





 





 





0



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




4897




 





 





 





 





 





 



                     } 




4898




 





 





 





 





 





 



                     elsif ($thing->{default_values}) { 




4899



  
0
  




 





 





 





 





0



                         str_append_str ($str, ' DEFAULT VALUES'); 




4900




 





 





 





 





 





 



                     } 




4901




 





 





 





 





 





 



                     else { 




4902



  
0
  




 





 





 





 





0



                         die; 




4903




 





 





 





 





 





 



                     } 




4904




 





 





 





 





 





 



   




4905




13




  
100
  




 





 





 





40



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




4906




1





 





 





 





 





2



                         str_append_str  ($str, ' ON DUPLICATE KEY UPDATE '); 




4907




1





 





 





 





 





130



                         str_append_list ($str, $x, NO_PARENS, map => __PACKAGE__.'::assign($_)'); 




4908




 





 





 





 





 





 



                     } 




4909




 





 





 





 





 





 



   




4910




13





 





 





 





 





23



                     str_append_end ($str); 




4911




13





 





 





 





 





23



                     str_append_end ($str); 




4912




 





 





 





 





 





 



                 }, 




4913




 





 





 





 





 





 



                 'Update' => sub { 




4914




9





 





 





 





 





20



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




4915




9





 





 





 





 





18



                     str_append_join ($str, never_empty => 1); 




4916




 





 





 





 





 





 



   




4917




 





 





 





 





 





 



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




4918




 





 





 





 





 





 



                         prefix => join(' ', 'UPDATE', 




4919




9





 





 





 





 





15



                                             @{ $thing->{opt_front} } 




 




9





 





 





 





 





31



   




4920




 





 





 





 





 





 



                                   ).' ' 




4921




 





 





 





 





 





 



                     ); 




4922




 





 





 





 





 





 



   




4923




9




  
100
  




 





 





 





28



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




4924




1





 





 





 





 





2



                         str_append_list ($str, $x, NO_PARENS, 




4925




 





 





 





 





 





 



                             prefix => ' FROM ', 




4926




 





 





 





 





 





 



                             result0 => '' 




4927




 





 





 





 





 





 



                         ); 




4928




 





 





 





 





 





 



                     } 




4929




9




  
 50
  




 





 





 





23



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




4930




9




  
 50
  




 





 





 





17



                         if (@$x) { 




4931



  
0
  




 





 





 





 





0



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




4932



  
0
  




 





 





 





 





0



                             for my $xi (@$x) { 




4933



  
0
  




 





 





 





 





0



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




4934




 





 





 





 





 





 



                             } 




4935



  
0
  




 





 





 





 





0



                             str_append_end ($str); 




4936




 





 





 





 





 





 



                         } 




4937




 





 





 





 





 





 



                     } 




4938




9




  
 50
  




 





 





 





18



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




4939




9





 





 





 





 





15



                         str_append_list ($str, $x, NO_PARENS, 




4940




 





 





 





 





 





 



                             prefix => ' SET ', 




4941




 





 





 





 





 





 



                             result0 => ''  # this is an error. 




4942




 





 





 





 





 





 



                         ); 




4943




 





 





 





 





 





 



                     } 




4944




9




  
 50
  




 





 





 





23



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




4945




9





 





 





 





 





153



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




4946




9





 





 





 





 





17



                         str_append_str   ($str, ' WHERE '); 




4947




9





 





 





 





 





19



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




4948




 





 





 





 





 





 



                     } 




4949




9




  
100
  




 





 





 





363



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




4950




1





 





 





 





 





3



                         str_append_list ($str, $x, NO_PARENS, 




4951




 





 





 





 





 





 



                             prefix  => ' ORDER BY ', 




4952




 





 





 





 





 





 



                             result0 => '' 




4953




 





 





 





 





 





 



                         ); 




4954




 





 





 





 





 





 



                     } 




4955




9





 





 





 





 





27



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




4956




 





 





 





 





 





 



   




4957




9





 





 





 





 





19



                     str_append_end ($str); 




4958




9





 





 





 





 





16



                     str_append_end ($str); 




4959




 





 





 





 





 





 



                 }, 




4960




 





 





 





 





 





 



                 'CreateTable' => sub { 




4961




2





 





 





 





 





6



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




4962




2





 





 





 





 





5



                     str_append_join ($str, never_empty => 1); 




4963




 





 





 





 





 





 



   




4964




2





 





 





 





 





8



                     str_append_str ($str, "$thing->{subtype} "); 




4965




2




  
100
  




 





 





 





5



                     if ($thing->{if_not_exists}) { 




4966




1





 





 





 





 





3



                         str_append_str ($str, 'IF NOT EXISTS '); 




4967




 





 





 





 





 





 



                     } 




4968




2





 





 





 





 





7



                     str_append_thing ($str, $thing->{table}, NOT_IN_LIST, NO_PARENS); 




4969




 





 





 





 





 





 



   




4970




 





 





 





 





 





 



                     my @tabspec= ( 




4971




2





 





 





 





 





5



                         @{ $thing->{column_def} }, 




4972




2





 





 





 





 





56



                         @{ $thing->{tabconstr} } 




 




2





 





 





 





 





6



   




4973




 





 





 





 





 





 



                     ); 




4974




2





 





 





 





 





7



                     str_append_list ($str, \@tabspec, NO_PARENS, 




4975




 





 





 





 





 





 



                         result0 => '', 




4976




 





 





 





 





 





 



                         prefix  => ' (', 




4977




 





 





 





 





 





 



                         suffix  => ')' 




4978




 





 





 





 





 





 



                     ); 




4979




 





 





 





 





 





 



   




4980




2





 





 





 





 





20



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




4981




 





 





 





 





 





 



                         result0 => '', 




4982




 





 





 





 





 





 



                         prefix  => ' ', 




4983




 





 





 





 





 





 



                         sep     => ' ', 




4984




 





 





 





 





 





 



                     ); 




4985




 





 





 





 





 





 



   




4986




2




  
100
  




 





 





 





7



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




4987




1





 





 





 





 





2



                         str_append_str   ($str, ' AS '); 




4988




1





 





 





 





 





2



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




4989




 





 





 





 





 





 



                     } 




4990




 





 





 





 





 





 



   




4991




2





 





 





 





 





69



                     str_append_end ($str); 




4992




2





 





 





 





 





5



                     str_append_end ($str); 




4993




 





 





 





 





 





 



                 }, 




4994




 





 





 





 





 





 



                 'DropTable' => sub { 




4995




1





 





 





 





 





4



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




4996




1





 





 





 





 





3



                     str_append_join ($str, never_empty => 1); 




4997




 





 





 





 





 





 



   




4998




1





 





 





 





 





3



                     str_append_str ($str, "$thing->{subtype} "); 




4999




1




  
 50
  




 





 





 





3



                     if ($thing->{if_exists}) { 




5000




1





 





 





 





 





4



                         str_append_str ($str, 'IF EXISTS '); 




5001




 





 





 





 





 





 



                     } 




5002




1





 





 





 





 





3



                     str_append_list ($str, $thing->{table}, NO_PARENS); 




5003




 





 





 





 





 





 



   




5004




1




  
 50
  




 





 





 





5



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




5005




1





 





 





 





 





3



                         str_append_str ($str, " $x"); 




5006




 





 





 





 





 





 



                     } 




5007




1





 





 





 





 





2



                     str_append_end ($str); 




5008




1





 





 





 





 





2



                     str_append_end ($str); 




5009




 





 





 





 





 





 



                 }, 




5010




 





 





 





 





 





 



                 'AlterTable' => sub { 




5011




20





 





 





 





 





43



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




5012




20





 





 





 





 





34



                     str_append_join ($str, never_empty => 1); 




5013




 





 





 





 





 





 



   




5014




20





 





 





 





 





69



                     str_append_str ($str, "$thing->{subtype} "); 




5015




20




  
 50
  




 





 





 





39



                     if ($thing->{only}) { 




5016



  
0
  




 





 





 





 





0



                         str_append_str ($str, 'ONLY '); 




5017




 





 





 





 





 





 



                     } 




5018




20





 





 





 





 





40



                     str_append_thing ($str, $thing->{table}, NOT_IN_LIST, NO_PARENS); 




5019




 





 





 





 





 





 



   




5020




20





 





 





 





 





553



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




5021




20





 





 





 





 





28



                     for my $l ($thing->{functor}, @{ $thing->{arg} }) { 




 




20





 





 





 





 





37



   




5022




61





 





 





 





 





85



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




5023




 





 





 





 





 





 



                     } 




5024




20





 





 





 





 





40



                     str_append_end ($str); 




5025




 





 





 





 





 





 



   




5026




20





 





 





 





 





31



                     str_append_end ($str); 




5027




20





 





 





 





 





28



                     str_append_end ($str); 




5028




 





 





 





 





 





 



                 }, 




5029




 





 





 





 





 





 



                 'Interpol' => sub { 




5030




3





 





 





 





 





9



                     str_append_typed ($str, 'stmt', 'Stmt', $thing, $in_list); 




5031




 





 





 





 





 





 



                 }, 




5032




235





 





 




  
141
  




 





2572



             ); 




5033




 





 





 





 





 





 



         }, 




5034




 





 





 





 





 





 



   




5035




 





 





 





 





 





 



         'TableOption' => sub { 




5036




 





 





 





 





 





 



             switch ($thing->{type}, 




5037




 





 





 





 





 





 



                'interpol' => sub { 




5038




2





 





 





 





 





6



                     str_append_typed ($str, 'tableopt', 'TableOption', $thing, $in_list); 




5039




 





 





 





 





 





 



                }, 




5040




 





 





 





 





 





 



                'literal' => sub { 




5041




6





 





 





 





 





13



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




5042




6





 





 





 





 





15



                     str_append_str   ($str, $thing->{name}); 




5043




6





 





 





 





 





22



                     str_append_thing ($str, $thing->{value}, NOT_IN_LIST, NO_PARENS); 




5044




6





 





 





 





 





175



                     str_append_end   ($str); 




5045




 





 





 





 





 





 



                } 




5046




8





 





 




  
3
  




 





30



             ); 




5047




 





 





 





 





 





 



         }, 




5048




 





 





 





 





 





 



   




5049




 





 





 





 





 





 



         'Keyword' => sub { 




5050




1





 





 




  
0
  




 





4



             str_append_str ($str, $thing->{keyword}); 




5051




 





 





 





 





 





 



         }, 




5052




 





 





 





 





 





 



   




5053




 





 





 





 





 





 



         'Join' => sub { 




5054




16




  
100
  




 




  
9
  




 





35



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




5055




5





 





 





 





 





11



                 str_append_typed ($str, 'joinclause', 'Join', $thing, $in_list); 




5056




 





 





 





 





 





 



             } 




5057




 





 





 





 





 





 



             else { 




5058




11





 





 





 





 





25



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




5059




 





 





 





 





 





 



   




5060




11




  
100
  




 





 





 





22



                 if ($thing->{natural}) { 




5061




3




  
 50
  




 





 





 





14



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




5062




3





 





 





 





 





6



                         str_append_str ($str, "NATURAL JOIN "); 




5063




 





 





 





 





 





 



                     } 




5064




 





 





 





 





 





 



                     else { 




5065



  
0
  




 





 





 





 





0



                         str_append_str ($str, "NATURAL $thing->{type} JOIN "); 




5066




 





 





 





 





 





 



                     } 




5067




 





 





 





 





 





 



                 } 




5068




 





 





 





 





 





 



                 else { 




5069




8





 





 





 





 





19



                     str_append_str ($str, "$thing->{type} JOIN "); 




5070




 





 





 





 





 





 



                 } 




5071




 





 





 





 





 





 



   




5072




11





 





 





 





 





31



                 str_append_list ($str, $thing->{table}, NO_PARENS); 




5073




 





 





 





 





 





 



   




5074




11




  
100
  




 





 





 





36



                 if (my $on= $thing->{on}) { 




 




 




  
100
  




 





 





 





 



   




5075




3





 





 





 





 





7



                     str_append_str ($str, ' ON '); 




5076




3





 





 





 





 





8



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




5077




 





 





 





 





 





 



                 } 




5078




 





 





 





 





 





 



                 elsif (my $using= $thing->{using}) { 




5079




2





 





 





 





 





6



                     str_append_str  ($str, ' USING ('); 




5080




2





 





 





 





 





5



                     str_append_list ($str, $using, NO_PARENS); 




5081




2





 





 





 





 





3



                     str_append_str  ($str, ')'); 




5082




 





 





 





 





 





 



                 }; 




5083




 





 





 





 





 





 



   




5084




11





 





 





 





 





150



                 str_append_end ($str); 




5085




 





 





 





 





 





 



             } 




5086




 





 





 





 





 





 



         }, 




5087




 





 





 





 





 





 



   




5088




 





 





 





 





 





 



         'Table' => 'Column', 




5089




 





 





 





 





 





 



         'CharSet' => 'Column', 




5090




 





 





 





 





 





 



         'Collate' => 'Column', 




5091




 





 





 





 





 





 



         'Index' => 'Column', 




5092




 





 





 





 





 





 



         'Constraint' => 'Column', 




5093




 





 





 





 





 





 



         'Transliteration' => 'Column', 




5094




 





 





 





 





 





 



         'Transcoding' => 'Column', 




5095




 





 





 





 





 





 



         'Engine' => 'Column', 




5096




 





 





 





 





 





 



         'Column' => sub { 




5097




519





 





 




  
355
  




 





701



             str_append_ident_chain ($str, $in_list, $thing->{kind}, @{ $thing->{ident_chain} }); 




 




519





 





 





 





 





1072



   




5098




 





 





 





 





 





 



         }, 




5099




 





 





 





 





 





 



   




5100




 





 





 





 





 





 



         'TableAs' => sub { 




5101




128




  
100
  




 




  
102
  




 





241



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




5102




 





 





 





 





 





 



                 # Oracle does not allow AS in table aliases.  But this module 




5103




 





 





 





 





 





 



                 # does not allow leaving it out.  To avoid generating what 




5104




 





 





 





 





 





 



                 # this module cannot read back in the default case, check for 




5105




 





 





 





 





 





 



                 # the write dialect. 




5106




5




  
 50
  




 





 





 





10



                 if ($write_dialect eq 'oracle') { 




5107



  
0
  




 





 





 





 





0



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




5108




 





 





 





 





 





 



                 } 




5109




 





 





 





 





 





 



                 else { 




5110




5





 





 





 





 





9



                     str_append_join  ($str, sep => ' AS ', never_empty => 1); 




5111




 





 





 





 





 





 



                 } 




5112




5





 





 





 





 





14



                 str_append_thing ($str, $thing->{table}, NOT_IN_LIST, NO_PARENS); 




5113




5





 





 





 





 





161



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




5114




5





 





 





 





 





124



                 str_append_end   ($str); 




5115




 





 





 





 





 





 



             } 




5116




 





 





 





 





 





 



             else { 




5117




123





 





 





 





 





210



                 str_append_thing ($str, $thing->{table}, $in_list, NO_PARENS); 




5118




 





 





 





 





 





 



             } 




5119




 





 





 





 





 





 



         }, 




5120




 





 





 





 





 





 



   




5121




 





 





 





 





 





 



         'ExprAs' => sub { 




5122




229




  
100
  




 




  
123
  




 





384



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




5123




4





 





 





 





 





11



                 str_append_join  ($str, sep => ' AS ', never_empty => 1); 




5124




4





 





 





 





 





13



                 str_append_thing ($str, $thing->{expr}, NOT_IN_LIST, NO_PARENS); 




5125




3





 





 





 





 





214



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




5126




3





 





 





 





 





79



                 str_append_end   ($str); 




5127




 





 





 





 





 





 



             } 




5128




 





 





 





 





 





 



             else { 




5129




225





 





 





 





 





417



                 str_append_thing ($str, $thing->{expr}, $in_list, $parens); 




5130




 





 





 





 





 





 



             } 




5131




 





 





 





 





 





 



         }, 




5132




 





 





 





 





 





 



         'Order' => sub { 




5133




 





 





 





 





 





 



             switch($thing->{type}, 




5134




 





 





 





 





 





 



                 'interpol' => sub { 




5135




18




  
100
  




 





 





 





39



                     if ($thing->{desc}) { 




5136




5





 





 





 





 





10



                         str_append_typed ($str, 'desc', 'Order', $thing, $in_list, hashkeys => 1); 




5137




 





 





 





 





 





 



                     } 




5138




 





 





 





 





 





 



                     else { 




5139




13





 





 





 





 





25



                         str_append_typed ($str, 'asc', 'Order', $thing, $in_list, hashkeys => 1); 




5140




 





 





 





 





 





 



                     } 




5141




 





 





 





 





 





 



                 }, 




5142




 





 





 





 





 





 



                 'expr' => sub { 




5143




17




  
100
  




 





 





 





32



                     if ($thing->{desc}) { 




5144




5





 





 





 





 





15



                         str_append_map   ($str, __PACKAGE__.'::desc($_)'); 




5145




5





 





 





 





 





14



                         str_append_thing ($str, $thing->{expr}, $in_list, NO_PARENS); 




5146




5





 





 





 





 





346



                         str_append_end   ($str); 




5147




 





 





 





 





 





 



                     } 




5148




 





 





 





 





 





 



                     else { 




5149




12





 





 





 





 





27



                         str_append_thing ($str, $thing->{expr}, $in_list, NO_PARENS); 




5150




 





 





 





 





 





 



                     } 




5151




 





 





 





 





 





 



                 }, 




5152




35





 





 




  
17
  




 





122



             ); 




5153




 





 





 





 





 





 



         }, 




5154




 





 





 





 





 





 



         'TypeList' => sub { 




5155




 





 





 





 





 





 



             switch($thing->{type}, 




5156




 





 





 





 





 





 



                 'interpol' => sub { 




5157



  
0
  




 





 





 





 





0



                     str_append_typed ($str, 'typelist', 'Type', $thing, $in_list); 




5158




 





 





 





 





 





 



                 }, 




5159




 





 





 





 





 





 



   




5160




 





 





 





 





 





 



                 'explicit' => sub { 




5161




1





 





 





 





 





3



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




5162




 





 





 





 





 





 



                         # may not be empty! 




5163




 





 





 





 





 





 



                 }, 




5164




1





 





 




  
0
  




 





5



             ); 




5165




 





 





 





 





 





 



         }, 




5166




 





 





 





 





 





 



         'Type' => sub { 




5167




 





 





 





 





 





 



             switch ($thing->{type}, 




5168




 





 





 





 





 





 



                 'interpol' => sub { 




5169




8





 





 





 





 





13



                     str_append_typed ($str, 'type', 'Type', $thing, $in_list); 




5170




 





 





 





 





 





 



                 }, 




5171




 





 





 





 





 





 



                 'base' => sub { 




5172




22





 





 





 





 





43



                     str_append_perl ($str, __PACKAGE__.'::Type->new()'); 




5173




 





 





 





 





 





 



                 }, 




5174




30





 





 




  
15
  




 





108



             ); 




5175




 





 





 





 





 





 



         }, 




5176




 





 





 





 





 





 



         'TypePost' => sub { 




5177




56




  
 50
  




 




  
23
  




 





92



             return str_append_parens ($str, $thing, NOT_IN_LIST) 




5178




 





 





 





 





 





 



                 if $parens; 




5179




 





 





 





 





 





 



   




5180




56





 





 





 





 





173



             str_append_funcall_begin ($str, __PACKAGE__.'::type_'.$thing->{functor}, $in_list); 




5181




56





 





 





 





 





65



             for my $arg (@{ $thing->{arg} }) { 




 




56





 





 





 





 





96



   




5182




68





 





 





 





 





131



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




5183




 





 





 





 





 





 



             } 




5184




56





 





 





 





 





123



             str_append_funcall_end ($str, $in_list); 




5185




56





 





 





 





 





106



             str_append_thing ($str, $thing->{base}, $in_list, NO_PARENS); 




5186




56





 





 





 





 





1345



             str_append_end ($str); 




5187




 





 





 





 





 





 



         }, 




5188




 





 





 





 





 





 



         'ColumnDef' => sub { 




5189




6





 





 




  
1
  




 





11



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




5190




6





 





 





 





 





16



             str_append_thing ($str, $thing->{name},        NOT_IN_LIST, NO_PARENS); 




5191




6





 





 





 





 





169



             str_append_thing ($str, $thing->{column_spec}, NOT_IN_LIST, NO_PARENS); 




5192




6





 





 





 





 





142



             str_append_end   ($str); 




5193




 





 





 





 





 





 



         }, 




5194




 





 





 





 





 





 



   




5195




 





 





 





 





 





 



         'ColumnSpec' => sub { 




5196




 





 





 





 





 





 



             switch ($thing->{type}, 




5197




 





 





 





 





 





 



                 'interpol' => sub { 




5198




7





 





 





 





 





16



                     str_append_typed ($str, 'colspec', 'ColumnSpec', $thing, $in_list); 




5199




 





 





 





 





 





 



                 }, 




5200




 





 





 





 





 





 



                 'base' => sub { 




5201




9





 





 





 





 





25



                     str_append_funcall ($str, __PACKAGE__.'::ColumnSpec->new', $in_list); 




5202




9





 





 





 





 





37



                     str_append_thing ($str, $thing->{datatype}, $in_list, NO_PARENS); 




5203




9





 





 





 





 





378



                     str_append_end ($str); 




5204




 





 





 





 





 





 



                 } 




5205




16





 





 




  
4
  




 





69



             ); 




5206




 





 





 





 





 





 



         }, 




5207




 





 





 





 





 





 



         'ColumnSpecPost' => sub { 




5208




22




  
 50
  




 




  
4
  




 





40



             return str_append_parens ($str, $thing, NOT_IN_LIST) 




5209




 





 





 





 





 





 



                 if $parens; 




5210




 





 





 





 





 





 



   




5211




22





 





 





 





 





69



             str_append_funcall_begin ($str, __PACKAGE__.'::colspec_'.$thing->{functor}, $in_list); 




5212




22





 





 





 





 





32



             for my $arg (@{ $thing->{arg} }) { 




 




22





 





 





 





 





38



   




5213




61





 





 





 





 





94



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




5214




 





 





 





 





 





 



             } 




5215




22





 





 





 





 





52



             str_append_funcall_end ($str, $in_list); 




5216




22





 





 





 





 





47



             str_append_thing ($str, $thing->{base}, $in_list, NO_PARENS); 




5217




22





 





 





 





 





520



             str_append_end ($str); 




5218




 





 





 





 





 





 



         }, 




5219




 





 





 





 





 





 



   




5220




 





 





 





 





 





 



         'TableConstraint' => sub { 




5221




 





 





 





 





 





 



             switch($thing->{type}, 




5222




 





 





 





 





 





 



                 'primary_key' => sub { 




5223



  
0
  




 





 





 





 





0



                     str_append_table_key ($str, $thing, 'PRIMARY KEY'); 




5224




 





 





 





 





 





 



                 }, 




5225




 





 





 





 





 





 



                 'unique' => sub { 




5226




1





 





 





 





 





4



                     str_append_table_key ($str, $thing, 'UNIQUE'); 




5227




 





 





 





 





 





 



                 }, 




5228




 





 





 





 





 





 



                 'fulltext' => sub { 




5229



  
0
  




 





 





 





 





0



                     str_append_table_key ($str, $thing, 'FULLTEXT'); 




5230




 





 





 





 





 





 



                 }, 




5231




 





 





 





 





 





 



                 'spatial' => sub { 




5232



  
0
  




 





 





 





 





0



                     str_append_table_key ($str, $thing, 'SPATIAL'); 




5233




 





 





 





 





 





 



                 }, 




5234




 





 





 





 





 





 



                 'index' => sub { 




5235



  
0
  




 





 





 





 





0



                     str_append_table_key ($str, $thing, 'INDEX'); 




5236




 





 





 





 





 





 



                 }, 




5237




 





 





 





 





 





 



                 'foreign_key' => sub { 




5238




2





 





 





 





 





4



                     str_append_table_key ($str, $thing, 'FOREIGN KEY'); 




5239




 





 





 





 





 





 



                 }, 




5240




3





 





 




  
0
  




 





17



             ); 




5241




 





 





 





 





 





 



         }, 




5242




 





 





 





 





 





 



   




5243




 





 





 





 





 





 



         'IndexOption' => sub { 




5244




 





 





 





 





 





 



             switch($thing->{type}, 




5245




 





 





 





 





 





 



                 'using' => sub { 




5246



  
0
  




 





 





 





 





0



                     str_append_str ($str, "USING $thing->{arg}"); 




5247




 





 





 





 





 





 



                 } 




5248



  
0
  




 





 




  
0
  




 





0



             ); 




5249




 





 





 





 





 





 



         }, 




5250




 





 





 





 





 





 



   




5251




 





 





 





 





 





 



         'References' => sub { 




5252




 





 





 





 





 





 



             # table column match on_delete on_update)); 




5253




 





 





 





 





 





 



             str_append_join  ($str, sep => ' ', 




5254




 





 





 





 





 





 



                 prefix => 'REFERENCES ', 




5255




 





 





 





 





 





 



                 suffix => 




5256




4





 





 





 





 





10



                     join('', map { " $_" } 




5257




 





 





 





 





 





 



                         ($thing->{match} ? 




5258




 





 





 





 





 





 



                             ('MATCH', $thing->{match}) 




5259




 





 





 





 





 





 



                         :   () 




5260




 





 





 





 





 





 



                         ), 




5261




 





 





 





 





 





 



                         ($thing->{on_delete} ? 




5262




 





 





 





 





 





 



                             ('ON DELETE', $thing->{on_delete}) 




5263




 





 





 





 





 





 



                         :   () 




5264




 





 





 





 





 





 



                         ), 




5265




 





 





 





 





 





 



                         ($thing->{on_update} ? 




5266




 





 





 





 





 





 



                             ('ON UPDATE', $thing->{on_update}) 




5267




3




  
100
  




 




  
0
  




 





14



                         :   () 




 




 




  
100
  




 





 





 





 



   




 




 




  
 50
  




 





 





 





 



   




5268




 





 





 





 





 





 



                         ), 




5269




 





 





 





 





 





 



                     ) 




5270




 





 





 





 





 





 



             ); 




5271




3





 





 





 





 





8



             str_append_thing ($str, $thing->{table}, NOT_IN_LIST, NO_PARENS); 




5272




3





 





 





 





 





74



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




5273




 





 





 





 





 





 



                  prefix => '(', suffix => ')', result0 => ''); 




5274




3





 





 





 





 





5



             str_append_end   ($str); 




5275




 





 





 





 





 





 



         }, 




5276




 





 





 





 





 





 



   




5277




 





 





 





 





 





 



         'CharUnit' => sub { 




5278




1





 





 




  
0
  




 





2



             str_append_str ($str, $thing->{name}); 




5279




 





 





 





 





 





 



         }, 




5280




 





 





 





 





 





 



   




5281




 





 





 





 





 





 



         'ExprList' => sub { 




5282




 





 





 





 





 





 



             switch($thing->{type}, 




5283




 





 





 





 





 





 



                 'interpol' => sub { 




5284




5





 





 





 





 





10



                     str_append_typed ($str, 'exprlist', 'Expr', $thing, $in_list); 




5285




 





 





 





 





 





 



                 }, 




5286




 





 





 





 





 





 



   




5287




 





 





 





 





 





 



                 'explicit' => sub { 




5288




6





 





 





 





 





17



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




5289




 





 





 





 





 





 



                         # may not be empty! 




5290




 





 





 





 





 





 



                 }, 




5291




11





 





 




  
8
  




 





40



             ); 




5292




 





 





 





 





 





 



         }, 




5293




 





 





 





 





 





 



         'ExprEmpty' => sub { 




5294




 





 





 





 





 





 



             # Append an empty string.  Must have an operand here, otherwise 




5295




 





 





 





 





 





 



             # parameters might get mixed up. 




5296




18





 





 




  
10
  




 





30



             str_append_str($str, ''); 




5297




 





 





 





 





 





 



         }, 




5298




 





 





 





 





 





 



         'Check' => sub { 




5299




9





 





 




  
9
  




 





21



             str_append_join  ($str, joinfunc => __PACKAGE__.'::Check->obj'); 




5300




9





 





 





 





 





23



             str_append_thing ($str, $thing->{expr}, NOT_IN_LIST, NO_PARENS); 




5301




9





 





 





 





 





379



             str_append_end   ($str); 




5302




 





 





 





 





 





 



         }, 




5303




 





 





 





 





 





 



         'Expr' => sub { 




5304




 





 





 





 





 





 



             switch($thing->{type}, 




5305




 





 





 





 





 





 



                 'limit' => sub { 




5306




24





 





 





 





 





68



                     my $limit_cnt_str= perl_val($thing->{arg}, 'Expr', 




5307




 





 





 





 





 





 



                                              ['interpol', 'interpolExpr', '?']); 




5308




24





 





 





 





 





219



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




5309




 





 





 





 





 





 



                 }, 




5310




 





 





 





 





 





 



                 'interpol' => sub { 




5311




 





 





 





 





 





 



                     my $func= $thing->{maybe_check} ? 




5312




 





 





 





 





 





 



                                    'expr_or_check' 




5313




 





 





 





 





 





 



                               : ($thing->{token}{type} eq 'num' || 




5314




375




  
100
  



  
100
  




 





 





1570



                                  $thing->{token}{type} eq 'string' || 




 




 




  
100
  




 





 





 





 



   




5315




 





 





 





 





 





 



                                  !$parens) ? 




5316




 





 





 





 





 





 



                                    'expr' 




5317




 





 





 





 





 





 



                               :    'exprparen'; 




5318




375





 





 





 





 





654



                     str_append_typed ($str, $func, 'Expr', $thing, $in_list, hash => 1); 




5319




 





 





 





 





 





 



                 }, 




5320




 





 





 





 





 





 



                 'column' => sub { 




5321




320





 





 





 





 





606



                     str_append_thing ($str, $thing->{arg}, $in_list, NO_PARENS); 




5322




 





 





 





 





 





 



                 }, 




5323




 





 





 





 





 





 



                 '()' => sub { 




5324




11





 





 





 





 





25



                     str_append_thing ($str, $thing->{arg}, $in_list, PARENS); 




5325




 





 





 





 





 





 



                 }, 




5326




 





 





 





 





 





 



                 'subquery' => sub { 




5327




8





 





 





 





 





19



                     str_append_funcall ($str, __PACKAGE__.'::subquery', $in_list); 




5328




8





 





 





 





 





20



                     str_append_thing ($str, $thing->{arg}, $in_list, NO_PARENS); 




5329




8





 





 





 





 





446



                     str_append_end   ($str); 




5330




 





 





 





 





 





 



                 }, 




5331




 





 





 





 





 





 



                 'prefix1' => sub { 




5332




2





 





 





 





 





4



                     $in_list= NOT_IN_LIST; # just to be sure 




5333




2




  
 50
  




 





 





 





5



                     return str_append_parens ($str, $thing, NOT_IN_LIST) 




5334




 





 





 





 





 





 



                         if $parens; 




5335




2




  
 50
  




 





 





 





3



                     die 'Expected exactly 1 argument' unless scalar(@{ $thing->{arg} }) == 1; 




 




2





 





 





 





 





7



   




5336




 





 





 





 





 





 



   




5337




2





 





 





 





 





9



                     str_append_join ($str, 




5338




 





 





 





 





 





 



                         prefix => "$thing->{functor}{value} ", 




5339




 





 





 





 





 





 



                         never_empty => 1 




5340




 





 





 





 





 





 



                     ); 




5341




2





 





 





 





 





7



                     str_append_thing ($str, $thing->{arg}[0], NOT_IN_LIST, PARENS); 




5342




1





 





 





 





 





40



                     str_append_end ($str); 




5343




 





 





 





 





 





 



                 }, 




5344




 





 





 





 





 





 



                 'prefixn' => sub { 




5345




2





 





 





 





 





3



                     $parens= NO_PARENS; # just to be sure 




5346




2




  
 50
  




 





 





 





2



                     die 'Expected exactly 1 argument' unless scalar(@{ $thing->{arg} }) == 1; 




 




2





 





 





 





 





7



   




5347




 





 





 





 





 





 



   




5348




2




  
100
  




 





 





 





5



                     if ($in_list) { 




5349




1





 





 





 





 





5



                         str_append_map ($str, "'$thing->{functor}{value} '.(\$_)"); 




5350




 





 





 





 





 





 



                     } 




5351




 





 





 





 





 





 



                     else { 




5352




1





 





 





 





 





4



                         str_append_join ($str, 




5353




 





 





 





 





 





 



                             prefix => "$thing->{functor}{value} ", 




5354




 





 





 





 





 





 



                             never_empty => 1 




5355




 





 





 





 





 





 



                         ); 




5356




 





 





 





 





 





 



                     } 




5357




2





 





 





 





 





7



                     str_append_thing ($str, $thing->{arg}[0], $in_list, PARENS); 




5358




2





 





 





 





 





103



                     str_append_end ($str); 




5359




 





 





 





 





 





 



                 }, 




5360




 





 





 





 





 





 



   




5361




 





 





 





 





 





 



                 'infix2' => sub { 




5362




89





 





 





 





 





100



                     $in_list= NOT_IN_LIST; # just to be sure 




5363




89




  
100
  




 





 





 





155



                     return str_append_parens ($str, $thing, NOT_IN_LIST) 




5364




 





 





 





 





 





 



                         if $parens; 




5365




 





 





 





 





 





 



   




5366




85





 





 





 





 





128



                     my $f= $thing->{functor}; 




5367




85





 





 





 





 





176



                     str_append_join  ($str, joinfunc => __PACKAGE__.'::Infix->obj'); 




5368




85





 





 





 





 





198



                     str_append_str   ($str, $thing->{functor}{value}); 




5369




85





 





 





 





 





236



                     str_append_thing ($str, $thing->{arg}[0], NOT_IN_LIST, PARENS); 




5370




85





 





 





 





 





5140



                     str_append_thing ($str, $thing->{arg}[1], NOT_IN_LIST, PARENS); 




5371




85





 





 





 





 





3651



                     str_append_end   ($str); 




5372




 





 





 





 





 





 



                 }, 




5373




 





 





 





 





 





 



   




5374




 





 





 





 





 





 



                 'infix23' => 'infix3', 




5375




 





 





 





 





 





 



                 'infix3' => sub { 




5376




5





 





 





 





 





8



                     $in_list= NOT_IN_LIST; # just to be sure 




5377




5




  
100
  




 





 





 





14



                     return str_append_parens ($str, $thing, NOT_IN_LIST) 




5378




 





 





 





 





 





 



                         if $parens; 




5379




 





 





 





 





 





 



   




5380




4





 





 





 





 





6



                     my $f= $thing->{functor}; 




5381




4





 





 





 





 





9



                     str_append_join  ($str, never_empty => 1); 




5382




4





 





 





 





 





11



                     str_append_thing ($str, $thing->{arg}[0], NOT_IN_LIST, PARENS); 




5383




4





 





 





 





 





272



                     str_append_str   ($str, " $thing->{functor}{value} "); 




5384




4





 





 





 





 





11



                     str_append_thing ($str, $thing->{arg}[1], NOT_IN_LIST, PARENS); 




5385




4




  
100
  




 





 





 





207



                     if (scalar(@{ $thing->{arg} }) == 3) { 




 




4





 





 





 





 





18



   




5386




2





 





 





 





 





7



                         str_append_str   ($str, " $thing->{functor}{value2} "); 




5387




2





 





 





 





 





6



                         str_append_thing ($str, $thing->{arg}[2], NOT_IN_LIST, PARENS); 




5388




 





 





 





 





 





 



                     } 




5389




4





 





 





 





 





121



                     str_append_end   ($str); 




5390




 





 





 





 





 





 



                 }, 




5391




 





 





 





 





 





 



   




5392




 





 





 





 





 





 



                 # prefix and suffix allow bitwise application: 




5393




 





 





 





 





 





 



                 # Currently not supported via _prefix() and _suffix() helper 




5394




 





 





 





 





 





 



                 # functions, but may be later.  (Needs only a little rewrite 




5395




 





 





 





 





 





 



                 # here.  The helper functions don't need to be changed.) 




5396




 





 





 





 





 





 



                 'prefix()' => 'prefix', 




5397




 





 





 





 





 





 



                 'suffix' => 'prefix', 




5398




 





 





 





 





 





 



                 'prefix' => sub { 




5399




63




  
100
  




 





 





 





114



                     if ($thing->{type} eq 'prefix()') { # for AND() and OR() as functors 




5400




20





 





 





 





 





24



                         $in_list = NOT_IN_LIST; 




5401




 





 





 





 





 





 



                     } 




5402




63





 





 





 





 





81



                     my $f= $thing->{functor}; 




5403




63




  
 50
  



  
 50
  




 





 





197



                     my $fk= $functor_kind{$f->{type} || ''} 




5404




 





 





 





 





 





 



                             or die "Expected $thing->{type} to be mapped by \%functor_kind"; 




5405




63




  
100
  




 





 





 





102



                     if ($in_list) { 




5406




27





 





 





 





 





52



                         my $qt= quote_perl($f->{value}); 




5407




27




  
100
  




 





 





 





119



                         str_append_map ($str, __PACKAGE__."::_".$fk."($qt,".($parens?1:0).",\$_)"); 




5408




27





 





 





 





 





29



                         for my $l (@{ $thing->{arg} }) { 




 




27





 





 





 





 





48



   




5409




35





 





 





 





 





75



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




5410




 





 





 





 





 





 



                         } 




5411




27





 





 





 





 





60



                         str_append_end ($str); 




5412




 





 





 





 





 





 



                     } 




5413




 





 





 





 





 





 



                     else { 




5414




36





 





 





 





 





100



                         str_append_funcall($str, __PACKAGE__."::_".$fk, NOT_IN_LIST); 




5415




36





 





 





 





 





107



                         str_append_thing ($str, $f->{value}, IN_LIST, NO_PARENS); 




5416




36




  
100
  




 





 





 





79



                         str_append_thing ($str, $parens?1:0, IN_LIST, NO_PARENS); 




5417




36





 





 





 





 





41



                         for my $l (@{ $thing->{arg} }) { 




 




36





 





 





 





 





63



   




5418




46





 





 





 





 





80



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




5419




 





 





 





 





 





 



                         } 




5420




36





 





 





 





 





78



                         str_append_end ($str); 




5421




 





 





 





 





 





 



                     } 




5422




 





 





 





 





 





 



                 }, 




5423




 





 





 





 





 





 



   




5424




 





 





 





 





 





 



                 # funcall and infix use args inline if they are in list context. 




5425




 





 





 





 





 





 



                 # They are handled by _prefix() and _suffix() helper functions in order 




5426




 





 





 





 





 





 



                 # to allow dialect conversion: 




5427




 





 





 





 





 





 



                 'funcall' => 'infix()', 




5428




 





 





 





 





 





 



                 'infix()' => sub { 




5429




97





 





 





 





 





109



                     $in_list= NOT_IN_LIST; # just to be sure 




5430




97





 





 





 





 





140



                     my $f= $thing->{functor}; 




5431




97




  
 50
  



  
 50
  




 





 





298



                     my $fk= $functor_kind{$f->{type} || ''} 




5432




 





 





 





 





 





 



                             or die 'Expected $thing->{type} to be mapped by %functor_kind'; 




5433




 





 





 





 





 





 



   




5434




97





 





 





 





 





275



                     str_append_funcall($str, __PACKAGE__."::_".$fk, NOT_IN_LIST); 




5435




97





 





 





 





 





214



                     str_append_thing ($str, $f->{value}, IN_LIST, NO_PARENS); 




5436




97




  
100
  




 





 





 





228



                     str_append_thing ($str, $parens?1:0, IN_LIST, NO_PARENS); 




5437




97





 





 





 





 





104



                     for my $l (@{ $thing->{arg} }) { 




 




97





 





 





 





 





187



   




5438




188





 





 





 





 





308



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




5439




 





 





 





 





 





 



                     } 




5440




97





 





 





 





 





205



                     str_append_end ($str); 




5441




 





 





 





 





 





 



                 }, 




5442




 





 





 





 





 





 



   




5443




 





 





 





 





 





 



                 'funcsep' => sub { 




5444




6





 





 





 





 





8



                     $in_list= NOT_IN_LIST; # just to be sure 




5445




6





 





 





 





 





11



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




5446




6





 





 





 





 





20



                     str_append_str  ($str, "$thing->{functor}{value}("); 




5447




6





 





 





 





 





7



                     for my $t (@{ $thing->{arg} }) { 




 




6





 





 





 





 





13



   




5448




27





 





 





 





 





60



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




5449




 





 





 





 





 





 



                     } 




5450




6





 





 





 





 





10



                     str_append_end  ($str); 




5451




 





 





 





 





 





 



                 }, 




5452




 





 





 





 





 





 



   




5453




 





 





 





 





 





 



                 'case' => sub { 




5454




47





 





 





 





 





76



                     $in_list= NOT_IN_LIST; # just to be sure 




5455




 





 





 





 





 





 



   




5456




 





 





 





 





 





 



                     # FIXME (maybe): we add parens here, so if there are no 




5457




 





 





 





 





 





 



                     # when-then pairs at all and only the else part is printed, 




5458




 





 





 





 





 





 



                     # it will get parens, too, no matter what.  That's ok, 




5459




 





 





 





 





 





 



                     # since it's a non-standard, marginal special case. 




5460




47




  
100
  




 





 





 





94



                     return str_append_parens ($str, $thing, NOT_IN_LIST) 




5461




 





 





 





 





 





 



                         if $parens; 




5462




 





 





 





 





 





 



   




5463




34





 





 





 





 





44



                     my $sw= $thing->{switchval}; 




5464




34




  
100
  




 





 





 





53



                     if ($sw) { 




5465




22





 





 





 





 





52



                         str_append_funcall ($str, __PACKAGE__."::caseswitch", NOT_IN_LIST); 




5466




22





 





 





 





 





43



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




5467




 





 





 





 





 





 



                     } 




5468




 





 





 





 





 





 



                     else { 




5469




12





 





 





 





 





19



                         str_append_funcall ($str, __PACKAGE__."::casecond", NOT_IN_LIST); 




5470




 





 





 





 





 





 



                     } 




5471




 





 





 





 





 





 



   




5472




34




  
100
  




 





 





 





1478



                     if (my $e= $thing->{otherwise}) { 




5473




24





 





 





 





 





51



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




5474




 





 





 





 





 





 



                     } 




5475




 





 





 





 





 





 



                     else { 




5476




10





 





 





 





 





17



                         str_append_str ($str, 'NULL'); 




5477




 





 





 





 





 





 



                     } 




5478




 





 





 





 





 





 



   




5479




34





 





 





 





 





990



                     for my $wh (@{ $thing->{arg} }) { 




 




34





 





 





 





 





76



   




5480




30




  
 50
  




 





 





 





1060



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




5481




30





 





 





 





 





61



                             my ($when,$expr)= @$wh; 




5482




30





 





 





 





 





66



                             str_append_funcall ($str, __PACKAGE__.'::whenthen', NOT_IN_LIST); 




5483




30





 





 





 





 





65



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




5484




30





 





 





 





 





1220



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




5485




30





 





 





 





 





1210



                             str_append_end ($str); 




5486




 





 





 





 





 





 



                         } 




5487




 





 





 





 





 





 



                         else { 




5488



  
0
  




 





 





 





 





0



                             die 'expected array'; 




5489




 





 





 





 





 





 



                         } 




5490




 





 





 





 





 





 



                     } 




5491




 





 





 





 





 





 



   




5492




34





 





 





 





 





55



                     str_append_end ($str); 




5493




 





 





 





 





 





 



                 }, 




5494




1049





 





 




  
618
  




 





13182



             ); 




5495




 





 





 





 





 





 



         }, 




5496




 





 





 





 





 





 



   




5497




 





 





 





 





 





 



         'ColumnName' => sub { 




5498




 





 





 





 





 





 



             switch ($thing->{type}, 




5499




 





 





 





 





 





 



                 'interpol' => 'ident', 




5500




 





 





 





 





 





 



                 'ident' => sub { 




5501




48





 





 





 





 





82



                     str_append_typed ($str, 'colname', 'none', $thing, $in_list, hashkeys => 1); 




5502




 





 





 





 





 





 



                 } 




5503




48





 





 




  
11
  




 





156



             ); 




5504




 





 





 





 





 





 



         }, 




5505




 





 





 





 





 





 



   




5506




 





 





 





 





 





 



         'ColumnIndex' => sub { 




5507




2




  
 50
  



  
 66
  



  
0
  




 





10



             if (defined $thing->{length} || $thing->{desc}) { 




5508




2





 





 





 





 





4



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




5509




2





 





 





 





 





5



                 str_append_thing ($str, $thing->{name}, NOT_IN_LIST, NO_PARENS); 




5510




2




  
100
  




 





 





 





50



                 if (defined $thing->{length}) { 




5511




1





 





 





 





 





2



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




5512




1





 





 





 





 





2



                     str_append_thing ($str, $thing->{length}, NOT_IN_LIST, NO_PARENS); 




5513




1





 





 





 





 





44



                     str_append_end   ($str); 




5514




 





 





 





 





 





 



                 } 




5515




2




  
100
  




 





 





 





7



                 if ($thing->{desc}) { 




5516




1





 





 





 





 





3



                     str_append_str ($str, 'DESC'); 




5517




 





 





 





 





 





 



                 } 




5518




2





 





 





 





 





4



                 str_append_end   ($str); 




5519




 





 





 





 





 





 



             } 




5520




 





 





 





 





 





 



             else { 




5521



  
0
  




 





 





 





 





0



                 str_append_thing ($str, $thing->{name}, $in_list, $parens); 




5522




 





 





 





 





 





 



             } 




5523




 





 





 





 





 





 



         }, 




5524




 





 





 





 





 





 



   




5525




 





 





 





 





 





 



         'TableName' => sub { 




5526




 





 





 





 





 





 



             switch ($thing->{type}, 




5527




 





 





 





 





 





 



                 'interpol' => 'ident', 




5528




 





 





 





 





 





 



                 'ident' => sub { 




5529




5





 





 





 





 





11



                     str_append_typed ($str, 'tabname', 'none', $thing, $in_list, hashkeys => 1); 




5530




 





 





 





 





 





 



                 } 




5531




5





 





 




  
1
  




 





17



             ); 




5532




 





 





 





 





 





 



         }, 




5533




 





 





 





 





 





 



   




5534




 





 





 





 





 





 



         'Fetch' => 'Do', 




5535




 





 





 





 





 





 



         'Do' => sub { 




5536




12





 





 




  
12
  




 





27



             str_append_thing ($str, $thing->{stmt}, $in_list, $parens); 




5537




 





 





 





 





 





 



         }, 




5538




2463





 





 





 





 





49184



     ); 




5539




 





 





 





 





 





 



 } 




5540




 





 





 





 





 





 



   




5541




 





 





 





 





 





 



 sub to_perl($$\@) 




5542




 





 





 





 





 





 



 { 




5543




278





 





 




  
278
  



  
0
  




414



     my ($line_start, $kind, $things)= @_; 




5544




278





 





 





 





 





443



     my $str= str_new($line_start); 




5545




278





 





 





 





 





475



     for my $thing (@$things) { 




5546




386





 





 





 





 





722



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




5547




 





 





 





 





 





 



     } 




5548




275





 





 





 





 





654



     my $text= str_get_string($str); 




5549




275





 





 





 





 





1494



     return "do{".__PACKAGE__."::_max1_if_scalar map{".__PACKAGE__."::${kind}->obj(\$_)} $text}", 




5550




 





 





 





 





 





 



 } 




5551




 





 





 





 





 





 



   




5552




 





 





 





 





 





 



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




5553




 





 





 





 





 





 



 # Top-level parser interface: 




5554




 





 





 





 





 





 



   




5555




 





 





 





 





 





 



 sub lx_die_perhaps($;$) 




5556




 





 





 





 





 





 



 { 




5557




559





 





 




  
559
  



  
0
  




622



     my $lx= shift; 




5558




 





 





 





 





 





 



   




5559




 





 





 





 





 





 



     # if a test value is given, check that it is defined: 




5560




559




  
100
  




 





 





 





859



     if (scalar(@_)) { 




5561




280





 





 





 





 





354



         my ($check_val)= @_; 




5562




280




  
100
  




 





 





 





442



         unless (defined $check_val) { 




5563




1





 




  
 50
  




 





 





4



             $lx->{error}||= 'Unknown error'; 




5564




 





 





 





 





 





 



         } 




5565




 





 





 





 





 





 



     } 




5566




 





 





 





 





 





 



   




5567




 





 





 





 





 





 



     # if an error is set, then die: 




5568




559




  
100
  




 





 





 





914



     if ($lx->{error}) { 




5569




2





 





 





 





 





6



         die lx_pos($lx).": Error: $lx->{error}\n"; 




5570




 





 





 





 





 





 



     } 




5571




 





 





 





 





 





 



 } 




5572




 





 





 





 





 





 



   




5573




 





 





 





 





 





 



   




5574




 





 





 





 





 





 



 sub parse_1_or_list($$$;$) 




5575




 





 





 





 





 





 



 { 




5576




273





 





 




  
273
  



  
0
  




439



     my ($lx, $parse_elem, $list_sep, $end)= @_; 




5577




273





 





 





 





 





450



     my $r= parse_list([], $lx, $parse_elem, $list_sep, $end); 




5578




273





 





 





 





 





617



     lx_die_perhaps($lx, $r); 




5579




272





 





 





 





 





617



     return @$r; 




5580




 





 





 





 





 





 



 } 




5581




 





 





 





 





 





 



   




5582




 





 





 





 





 





 



 sub parse_0_try_list($$) 




5583




 





 





 





 





 





 



 { 




5584




7





 





 




  
7
  



  
0
  




14



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




5585




7





 





 





 





 





14



     my $r= parse_try_list([], $lx, $parse_elem); 




5586




7





 





 





 





 





20



     lx_die_perhaps($lx, $r); 




5587




7





 





 





 





 





32



     return @$r; 




5588




 





 





 





 





 





 



 } 




5589




 





 





 





 





 





 



   




5590




 





 





 





 





 





 



 sub parse_stmt_list($) 




5591




 





 





 





 





 





 



 { 




5592




137





 





 




  
137
  



  
0
  




390



     parse_1_or_list ($_[0], \&parse_stmt,  ';', ['}',')',']']); 




5593




 





 





 





 





 





 



 } 




5594




 





 





 





 





 





 



   




5595




 





 





 





 





 





 



 sub parse_do_stmt($) 




5596




 





 





 





 





 





 



 { 




5597




2





 





 




  
2
  



  
0
  




7



     my ($lx) = @_; 




5598




 





 





 





 





 





 



     map { 




5599




2





 





 





 





 





7



         my $stmt = $_; 




 




2





 





 





 





 





6



   




5600




2





 





 





 





 





7



         my $r = create($lx, 'Do', qw(stmt)); 




5601




2





 





 





 





 





7



         $r->{stmt} = $stmt; 




5602




2





 





 





 





 





10



         $r; 




5603




 





 





 





 





 





 



     } 




5604




 





 





 





 





 





 



     parse_stmt_list($lx); 




5605




 





 





 





 





 





 



 } 




5606




 





 





 





 





 





 



   




5607




 





 





 





 





 





 



 sub parse_fetch_stmt($) 




5608




 





 





 





 





 





 



 { 




5609




10





 





 




  
10
  



  
0
  




16



     my ($lx) = @_; 




5610




 





 





 





 





 





 



     map { 




5611




10





 





 





 





 





22



         my $stmt = $_; 




 




10





 





 





 





 





13



   




5612




10





 





 





 





 





20



         my $r = create($lx, 'Fetch', qw(stmt)); 




5613




10





 





 





 





 





15



         $r->{stmt} = $stmt; 




5614




10





 





 





 





 





35



         $r; 




5615




 





 





 





 





 





 



     } 




5616




 





 





 





 





 





 



     parse_stmt_list($lx); 




5617




 





 





 





 





 





 



 } 




5618




 





 





 





 





 





 



   




5619




 





 





 





 





 





 



 my %top_parse= ( 




5620




 





 





 





 





 





 



     # pure parse actions: 




5621




 





 





 





 





 





 



     'Stmt'            => \&parse_stmt_list, 




5622




 





 





 





 





 





 



   




5623




 





 





 





 





 





 



     'Join'            => sub { parse_0_try_list($_[0], \&parse_join)                 }, 




5624




 





 





 





 





 





 



     'TableOption'     => sub { parse_0_try_list($_[0], \&parse_table_option)         }, 




5625




 





 





 





 





 





 



   




5626




 





 





 





 





 





 



     'Expr'            => sub { parse_1_or_list ($_[0], \&parse_expr,            ',') }, 




5627




 





 





 





 





 





 



     'Check'           => sub { parse_1_or_list ($_[0], \&parse_check,           ',') }, 




5628




 





 





 





 





 





 



     'Type'            => sub { parse_1_or_list ($_[0], \&parse_type,            ',') }, 




5629




 





 





 





 





 





 



     'Column'          => sub { parse_1_or_list ($_[0], \&parse_column,          ',') }, 




5630




 





 





 





 





 





 



     'Table'           => sub { parse_1_or_list ($_[0], \&parse_table,           ',') }, 




5631




 





 





 





 





 





 



     'Index'           => sub { parse_1_or_list ($_[0], \&parse_index,           ',') }, 




5632




 





 





 





 





 





 



     'CharSet'         => sub { parse_1_or_list ($_[0], \&parse_charset,         ',') }, 




5633




 





 





 





 





 





 



     'Collate'         => sub { parse_1_or_list ($_[0], \&parse_collate,         ',') }, 




5634




 





 





 





 





 





 



     'Constraint'      => sub { parse_1_or_list ($_[0], \&parse_constraint,      ',') }, 




5635




 





 





 





 





 





 



     'Transliteration' => sub { parse_1_or_list ($_[0], \&parse_transliteration, ',') }, 




5636




 





 





 





 





 





 



     'Transcoding'     => sub { parse_1_or_list ($_[0], \&parse_transcoding,     ',') }, 




5637




 





 





 





 





 





 



     'Order'           => sub { parse_1_or_list ($_[0], \&parse_order,           ',') }, 




5638




 





 





 





 





 





 



     'ColumnSpec'      => sub { parse_1_or_list ($_[0], \&parse_column_spec,     ',') }, 




5639




 





 





 





 





 





 



   




5640




 





 





 





 





 





 



     # parse & execute actions: 




5641




 





 





 





 





 





 



     'Do'              => sub { parse_do_stmt   ($_[0]) }, 




5642




 





 





 





 





 





 



     'Fetch'           => sub { parse_fetch_stmt($_[0]) }, 




5643




 





 





 





 





 





 



 ); 




5644




 





 





 





 





 





 



 my $top_parse_re=  '(?:'.join('|', sort { length($b) <=> length($a) } '',     keys %top_parse).')'; 




5645




 





 





 





 





 





 



 my $top_parse_re2= '(?:'.join('|', sort { length($b) <=> length($a) } 'none', keys %top_parse).')'; 




5646




 





 





 





 





 





 



   




5647




 





 





 





 





 





 



 sub interpol_set_context ($$) 




5648




 





 





 





 





 





 



 { 




5649




515





 





 




  
515
  



  
0
  




807



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




5650




515





 





 





 





 





655



     $text=~ s/(\Q${\SQL_MARK}\E$top_parse_re)(?::$top_parse_re2)?(\s*\{)/$1:$ctxt$2/gs; 




 




515





 





 





 





 





2768



   




5651




515





 





 





 





 





2453



     return $text; 




5652




 





 





 





 





 





 



 } 




5653




 





 





 





 





 





 



   




5654




 





 





 





 





 





 



 sub good_interpol_type($) 




5655




 





 





 





 





 





 



 { 




5656




8





 





 




  
8
  



  
0
  




16



     my ($type)= @_; 




5657




8





 





 





 





 





30



     return !!$top_parse{$type}; 




5658




 





 





 





 





 





 



 } 




5659




 





 





 





 





 





 



   




5660




 





 





 





 





 





 



 sub mark_sql() 




5661




 





 





 





 





 





 



 { 




5662




 





 





 





 





 





 



     # Step 1: 




5663




 





 





 





 





 





 



     # This function will get the text without comments, strings, etc., 




5664




 





 





 





 





 





 



     # and replace the initial SQL marking the start of SQL syntax by 




5665




 





 





 





 





 





 



     # our special SQL_MARK.  Then, the unprocessed text will be 




5666




 





 





 





 





 





 



     # processed by replace_sql(). 




5667




5





 





 




  
5
  



  
0
  




340



     s/\b\Q$sql_marker\E($top_parse_re\s*\{)/${\SQL_MARK}$1/gs; 




 




259





 





 





 





 





643



   




5668




 





 





 





 





 





 



   




5669




 





 





 





 





 





 



     # Step 2: 




5670




 





 





 





 





 





 



     # Unmark false positives.  The above finds false matches in 




5671




 





 





 





 





 





 



     # variables: 




5672




 





 





 





 





 





 



     # 




5673




 





 





 





 





 





 



     #    $sql{...} 




5674




 





 





 





 





 





 



     # 




5675




 





 





 





 





 





 



     # We cannot(?) do this in one go, as we'd need a variable-width 




5676




 





 





 





 





 





 



     # negative look-behind regexp, which Perl does not have.  This 




5677




 





 





 





 





 





 



     # is because there can be arbitrary white space between $ and 




5678




 





 





 





 





 





 



     # a variable name. 




5679




5





 





 





 





 





11



     s/([\$\@\%]\s*)\Q${\SQL_MARK}\E/$1$sql_marker/gs; 




 




5





 





 





 





 





242



   




5680




 





 





 





 





 





 



   




5681




 





 





 





 





 





 



     # Note that there are still false positives, which are really hard 




5682




 





 





 





 





 





 



     # to find unless we start parsing Perl completely: 




5683




 





 





 





 





 





 



     # 




5684




 





 





 





 





 





 



     #   ${ sql{blah} } 




5685




 





 





 





 





 





 



 } 




5686




 





 





 





 





 





 



   




5687




 





 





 





 





 





 



 sub parse($$) 




5688




 





 





 





 





 





 



 { 




5689




22





 





 




  
22
  



  
0
  




15465



     my ($kind, $str)= @_; 




5690




22





 





 





 





 





61



     my $lx= lexer_new ($str, "", 0); 




5691




22





 





 





 





 





49



     my $func= $top_parse{$kind}; 




5692




22




  
 50
  




 





 





 





48



     return undef unless $func; 




5693




22




  
 50
  




 





 





 





49



     return () if looking_at($lx, ''); 




5694




22





 





 





 





 





61



     my @thing= $func->($lx); 




5695




21





 





 





 





 





70



     expect($lx, '', SHIFT); 




5696




21





 





 





 





 





49



     lx_die_perhaps ($lx); 




5697




20





 





 





 





 





47



     return to_perl(1, $kind, @thing); 




5698




 





 





 





 





 





 



 } 




5699




 





 





 





 





 





 



   




5700




 





 





 





 





 





 



 sub replace_sql() 




5701




 





 





 





 





 





 



 { 




5702




5





 





 




  
5
  



  
0
  




10286



     my ($module, $file, $line)= caller(4); # find our from where we were invoked 




5703




 





 





 





 





 





 



   




5704




5





 





 





 





 





14



     mark_sql(); 




5705




 





 





 





 





 





 



     #print STDERR "DEBUG: BEFORE: $_\n"; 




5706




 





 





 





 





 





 



   




5707




5





 





 





 





 





14



     pos($_)= 0; 




5708




5





 





 





 





 





10



     REPLACEMENT: while (/(\Q${\SQL_MARK}\E($top_parse_re)(?::($top_parse_re2))?\s*\{)/gs) { 




 




263





 





 





 





 





5334



   




5709




 





 





 





 





 





 



         # prepare lexer: 




5710




258





 




  
100
  




 





 





996



         my $ctxt=     $3 || 'Stmt'; 




5711




258





 





 





 





 





408



         my $speckind= $2; 




5712




258





 




  
 66
  




 





 





538



         my $kind=     $speckind || $ctxt; 




5713




258





 





 





 





 





420



         my $start=    pos($_) - length($1); 




5714




258





 





 





 





 





1536



         my $prefix=   substr($_, 0, $start); 




5715




258





 





 





 





 





5160



         my $line_rel= ($prefix =~ tr/\n//); 




5716




258





 





 





 





 





533



         my $lx=       lexer_new ($_, $file, $line + $line_rel); 




5717




 





 





 





 





 





 



   




5718




 





 





 





 





 





 



         # select parser: 




5719




258





 





 





 





 





419



         my $func= $top_parse{$kind}; 




5720




258




  
 50
  




 





 





 





451



         unless ($func) { 




5721



  
0
  




 





 





 





 





0



             die "$file:".($line+$line_rel+1). 




5722




 





 





 





 





 





 



                   ": Error: Plain ${sql_marker}${speckind}{...} is illegal, because the ". 




5723




 





 





 





 





 





 



                   "surrounding block must not return an object.\n\tPlease use ". 




5724




 





 





 





 





 





 



                   (english_or map "${sql_marker}${_}{...}", keys %top_parse)." to disambiguate.\n"; 




5725



  
0
  




 





 





 





 





0



             last REPLACEMENT; 




5726




 





 





 





 





 





 



         } 




5727




 





 





 





 





 





 



   




5728




 





 





 





 





 





 



         # parse (including closing brace): 




5729




258





 





 





 





 





414



         my @thing= $func->($lx); 




5730




258





 





 





 





 





549



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




5731




258





 





 





 





 





509



         lx_die_perhaps ($lx); 




5732




 





 





 





 





 





 



   




5733




258





 





 





 





 





318



         my $end= $lx->{token}{pos}; 




5734




258




  
 50
  



  
 33
  




 





 





805



         my_confess unless defined $end && $start < $end; 




5735




 





 





 





 





 





 



   




5736




 





 





 





 





 





 



         # Make Perl code: 




5737




 





 





 





 





 





 



         # Represent the parse result as a list in Perl (if it's only 




5738




 





 





 





 





 





 



         # one element, the parens don't hurt).  Each thing is 




5739




 





 





 





 





 





 



         # handled individually by to_perl(): 




5740




258





 





 





 





 





467



         my $perl= to_perl($line + $line_rel, $kind, @thing); 




5741




 





 





 





 





 





 



   




5742




 





 





 





 





 





 



         # replace: 




5743




258




  
 50
  




 





 





 





484



         print STDERR "$file:".($line+$line_rel+1).': DEBUG: '.__PACKAGE__." replacement: $perl\n" 




5744




 





 





 





 





 





 



             if $debug; 




5745




 





 





 





 





 





 



   




5746




258





 





 





 





 





12141



         my $old_text= substr($_, $start, $end-$start, $perl); # extract and replace text 




5747




 





 





 





 





 





 



             # pos($_) is now undef, which is ok, we will 




5748




 





 





 





 





 





 



             # rescan the text anyway. 




5749




 





 





 





 





 





 



   




5750




 





 





 





 





 





 



         # Insert newlines at the end that have been dropped so that the line 




5751




 





 





 





 





 





 



         # count does not change and Perl's error messages are useful: 




5752




258





 





 





 





 





573



         my $line_cnt_old= ($old_text =~ tr/\n//); 




5753




258





 





 





 





 





443



         my $line_cnt_new= ($perl     =~ tr/\n//); 




5754




258




  
 50
  




 





 





 





447



         my_confess "More newlines than before" #.": \n###\n$old_text\n###$perl\n###\n" 




5755




 





 





 





 





 





 



             if $line_cnt_new > $line_cnt_old; 




5756




 





 





 





 





 





 



   




5757




258




  
100
  




 





 





 





444



         if (my $line_cnt_less= $line_cnt_old - $line_cnt_new) { 




5758




101





 





 





 





 





1288



             substr($_, $start + length($perl), 0, "\n" x $line_cnt_less); 




5759




 





 





 





 





 





 



         } 




5760




 





 





 





 





 





 



   




5761




 





 





 





 





 





 



         # rescan everything in order to recurse into embedded sql{...}: 




5762




258





 





 





 





 





4145



         pos($_)= 0; 




5763




 





 





 





 





 





 



     } 




5764




5





 





 





 





 





23



     pos($_)= undef; 




5765




 





 





 





 





 





 



   




5766




 





 





 





 





 





 



     #print STDERR "DEBUG: AFTER: $_\n"; 




5767




 





 





 





 





 





 



 }; 




5768




 





 





 





 





 





 



   




5769




 





 





 





 





 





 



 FILTER_ONLY 




5770




 





 





 





 





 





 



     # code_no_comments => \&mark_sql,    # This is way to slow. 




5771




 





 





 





 





 





 



     all  => \&replace_sql; 




5772




 





 





 





 





 





 



   




5773




 





 





 





 





 





 



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




5774




 





 





 





 





 





 



 # Functions used in generated code: 




5775




 





 





 





 





 





 



   




5776




 





 





 





 





 





 



 # Obj: 




5777




 





 





 





 





 





 



 { 




5778




 





 





 





 





 





 



     package SQL::Yapp::Obj; 




5779




 





 





 





 





 





 



   




5780




5





 





 




  
5
  




 





46



     use strict; 




 




5





 





 





 





 





8



   




 




5





 





 





 





 





146



   




5781




5





 





 




  
5
  




 





27



     use warnings; 




 




5





 





 





 





 





7



   




 




5





 





 





 





 





180



   




5782




5





 





 




  
5
  




 





24



     use Carp qw(croak); 




 




5





 





 





 





 





7



   




 




5





 





 





 





 





561



   




5783




 





 





 





 





 





 



   




5784



  
0
  




 





 




  
0
  




 





0



     sub op($) { return ''; } 




5785




 





 





 





 





 





 



   




5786




 





 





 





 





 





 



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




5787




 





 





 





 





 





 



     # stringify: simply return second entry in array, the string: 




5788




 





 





 





 





 





 



     use overload '""' => 'value', 




5789




5





 





 




  
5
  




 





33



                  cmp  => sub { "$_[0]" cmp "$_[1]" }; 




 




5





 





 




  
173
  




 





16



   




 




5





 





 





 





 





58



   




 




173





 





 





 





 





33514



   




5790




 





 





 





 





 





 



   




5791




 





 





 





 





 





 



     sub type_error($$) 




5792




 





 





 





 





 





 



     { 




5793




3





 





 




  
3
  




 





10



         my ($x, $want)= @_; 




5794




3





 





 





 





 





6



         my $r= ref($x); 




5795




3





 





 





 





 





13



         $r=~ s/^SQL::Yapp:://; 




5796




3





 





 





 





 





389



         croak "Error: Expected $want, but found ".$r; 




5797




 





 





 





 





 





 



     } 




5798




 





 





 





 





 





 



   




5799



  
0
  




 





 




  
0
  




 





0



     sub asc($)              { $_[0]->type_error('Asc');             } 




5800



  
0
  




 





 




  
0
  




 





0



     sub assign($)           { $_[0]->type_error('assignment');      } 




5801



  
0
  




 





 




  
0
  




 





0



     sub charset($)          { $_[0]->type_error('CharSet');         } 




5802



  
0
  




 





 




  
0
  




 





0



     sub constraint($)       { $_[0]->type_error('Constraint');      } 




5803



  
0
  




 





 




  
0
  




 





0



     sub charset1($)         { $_[0]->type_error('CharSet');         } 




5804



  
0
  




 





 




  
0
  




 





0



     sub collate1($)         { $_[0]->type_error('Collate');         } 




5805



  
0
  




 





 




  
0
  




 





0



     sub colname($)          { $_[0]->type_error('ColumnName');      } 




5806



  
0
  




 





 




  
0
  




 





0



     sub colspec($)          { $_[0]->type_error('ColumnSpec');      } 




5807



  
0
  




 





 




  
0
  




 





0



     sub column1($)          { $_[0]->type_error('Column');          } 




5808




1





 





 




  
1
  




 





8



     sub column1_single($)   { $_[0]->type_error('Column');          } 




5809



  
0
  




 





 




  
0
  




 





0



     sub constraint1($)      { $_[0]->type_error('Constraint');      } 




5810



  
0
  




 





 




  
0
  




 





0



     sub desc($)             { $_[0]->type_error('Desc');            } 




5811



  
0
  




 





 




  
0
  




 





0



     sub engine1($)          { $_[0]->type_error('Engine');          } 




5812



  
0
  




 





 




  
0
  




 





0



     sub expr($)             { $_[0]->type_error('Expr');            } 




5813



  
0
  




 





 




  
0
  




 





0



     sub expr_or_check($)    { $_[0]->type_error('Expr or Check');   } 




5814



  
0
  




 





 




  
0
  




 





0



     sub check($)            { $_[0]->type_error('Check');           } 




5815




1





 





 




  
1
  




 





4



     sub exprparen($)        { $_[0]->type_error('Expr');            } 




5816



  
0
  




 





 




  
0
  




 





0



     sub index1($)           { $_[0]->type_error('Index');           } 




5817



  
0
  




 





 




  
0
  




 





0



     sub joinclause($)       { $_[0]->type_error('JOIN clause');     } 




5818



  
0
  




 





 




  
0
  




 





0



     sub limit_number($)     { $_[0]->type_error('number or ?');     } 




5819



  
0
  




 





 




  
0
  




 





0



     sub stmt($)             { $_[0]->type_error('Stmt');            } 




5820



  
0
  




 





 




  
0
  




 





0



     sub subquery($)         { $_[0]->type_error('subquery');        } 




5821



  
0
  




 





 




  
0
  




 





0



     sub table1($)           { $_[0]->type_error('Table');           } 




5822



  
0
  




 





 




  
0
  




 





0



     sub tabname($)          { $_[0]->type_error('TableName');       } 




5823



  
0
  




 





 




  
0
  




 





0



     sub tableopt($)         { $_[0]->type_error('TableOption');     } 




5824



  
0
  




 





 




  
0
  




 





0



     sub transcoding($)      { $_[0]->type_error('Transcoding');     } 




5825



  
0
  




 





 




  
0
  




 





0



     sub transliteration1($) { $_[0]->type_error('Transliteration'); } 




5826



  
0
  




 





 




  
0
  




 





0



     sub type($)             { $_[0]->type_error('Type');            } 




5827




 





 





 





 





 





 



   




5828



  
0
  




 





 




  
0
  




 





0



     sub do($)               { $_[0]->type_error('Do');              } 




5829



  
0
  




 





 




  
0
  




 





0



     sub fetch($)            { $_[0]->type_error('Fetch');           } 




5830




 





 





 





 





 





 



 } 




5831




 





 





 





 





 





 



   




5832




 





 





 





 





 





 



 # Obj1: 




5833




 





 





 





 





 





 



 { 




5834




 





 





 





 





 





 



     package SQL::Yapp::Obj1; 




5835




 





 





 





 





 





 



   




5836




5





 





 




  
5
  




 





3864



     use strict; 




 




5





 





 





 





 





7



   




 




5





 





 





 





 





99



   




5837




5





 





 




  
5
  




 





19



     use warnings; 




 




5





 





 





 





 





25



   




 




5





 





 





 





 





148



   




5838




5





 





 




  
5
  




 





24



     use base qw(SQL::Yapp::Obj); 




 




5





 





 





 





 





6



   




 




5





 





 





 





 





1656



   




5839




5





 





 




  
5
  




 





29



     use Scalar::Util qw(blessed); 




 




5





 





 





 





 





10



   




 




5





 





 





 





 





724



   




5840




 





 





 





 





 





 



   




5841




 





 





 





 





 





 



     sub obj($$) 




5842




 





 





 





 





 





 



     { 




5843




890





 





 




  
890
  




 





4271



         my ($class,$x)= @_; 




5844




890




  
100
  



  
 66
  




 





 





2430



         return $x 




5845




 





 





 





 





 





 



             if blessed($x) && $x->isa(__PACKAGE__); 




5846




731





 





 





 





 





2369



         return bless([$x], $class); 




5847




 





 





 





 





 





 



     } 




5848




 





 





 





 





 





 



   




5849




817





 





 




  
817
  




 





3875



     sub value($) { return $_[0][0]; } 




5850




 





 





 





 





 





 



 } 




5851




 





 





 





 





 





 



   




5852




 





 





 





 





 





 



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




5853




 





 





 





 





 





 



 # Asterisk: 




5854




 





 





 





 





 





 



 { 




5855




 





 





 





 





 





 



     package SQL::Yapp::Asterisk; 




5856




 





 





 





 





 





 



   




5857




5





 





 




  
5
  




 





25



     use strict; 




 




5





 





 





 





 





7



   




 




5





 





 





 





 





116



   




5858




5





 





 




  
5
  




 





19



     use warnings; 




 




5





 





 





 





 





6



   




 




5





 





 





 





 





146



   




5859




5





 





 




  
5
  




 





20



     use base qw(SQL::Yapp::Obj); 




 




5





 





 





 





 





9



   




 




5





 





 





 





 





1777



   




5860




 





 





 





 





 





 



   




5861




 





 





 





 





 





 



     sub obj($) 




5862




 





 





 





 





 





 



     { 




5863




2





 





 




  
2
  




 





180



         my ($class)= @_; 




5864




2





 





 





 





 





9



         return bless([], $class); 




5865




 





 





 





 





 





 



     } 




5866




 





 





 





 





 





 



   




5867




2





 





 




  
2
  




 





117



     sub value($)          { return '*'; } 




5868




 





 





 





 





 





 



   




5869




2





 





 




  
2
  




 





8



     sub column1($)        { return $_[0]; } 




5870



  
0
  




 





 




  
0
  




 





0



     sub column1_single($) { return $_[0]; } 




5871



  
0
  




 





 




  
0
  




 





0



     sub expr($)           { return $_[0]; } 




5872



  
0
  




 





 




  
0
  




 





0



     sub expr_or_check($)  { return $_[0]; } 




5873




 





 





 





 





 





 



   




5874



  
0
  




 





 




  
0
  




 





0



     sub asterisk($)       { return $_[0]; } 




5875




 





 





 





 





 





 



 } 




5876




 





 





 





 





 





 



   




5877




 





 





 





 





 





 



 # Question: 




5878




 





 





 





 





 





 



 { 




5879




 





 





 





 





 





 



     package SQL::Yapp::Question; 




5880




 





 





 





 





 





 



   




5881




5





 





 




  
5
  




 





27



     use strict; 




 




5





 





 





 





 





13



   




 




5





 





 





 





 





123



   




5882




5





 





 




  
5
  




 





21



     use warnings; 




 




5





 





 





 





 





7



   




 




5





 





 





 





 





120



   




5883




5





 





 




  
5
  




 





21



     use base qw(SQL::Yapp::Obj); 




 




5





 





 





 





 





6



   




 




5





 





 





 





 





1861



   




5884




 





 





 





 





 





 



   




5885




 





 





 





 





 





 



     sub obj($) 




5886




 





 





 





 





 





 



     { 




5887




1





 





 




  
1
  




 





3



         my ($class)= @_; 




5888




1





 





 





 





 





4



         return bless([], $class); 




5889




 





 





 





 





 





 



     } 




5890




 





 





 





 





 





 



   




5891




1





 





 




  
1
  




 





4



     sub value($)         { return '?' } 




5892




 





 





 





 





 





 



   




5893



  
0
  




 





 




  
0
  




 





0



     sub limit_number($)  { return $_[0]; } 




5894




1





 





 




  
1
  




 





3



     sub exprparen($)     { return $_[0]; } 




5895



  
0
  




 





 




  
0
  




 





0



     sub expr($)          { return $_[0]; } 




5896



  
0
  




 





 




  
0
  




 





0



     sub expr_or_check($) { return $_[0]; } 




5897



  
0
  




 





 




  
0
  




 





0



     sub asc($)           { return $_[0]; } 




5898



  
0
  




 





 




  
0
  




 





0



     sub desc($)          { return SQL::Yapp::Desc->obj($_[0]); } 




5899




 





 





 





 





 





 



 } 




5900




 





 





 





 





 





 



   




5901




 





 





 





 





 





 



 # ExprSpecial: 




5902




 





 





 





 





 





 



 { 




5903




 





 





 





 





 





 



     package SQL::Yapp::ExprSpecial; 




5904




 





 





 





 





 





 



   




5905




5





 





 




  
5
  




 





31



     use strict; 




 




5





 





 





 





 





6



   




 




5





 





 





 





 





100



   




5906




5





 





 




  
5
  




 





18



     use warnings; 




 




5





 





 





 





 





9



   




 




5





 





 





 





 





153



   




5907




5





 





 




  
5
  




 





22



     use base qw(SQL::Yapp::Obj1); 




 




5





 





 





 





 





7



   




 




5





 





 





 





 





1654



   




5908




 





 





 





 





 





 



   




5909



  
0
  




 





 




  
0
  




 





0



     sub exprparen($)     { return $_[0]; } 




5910



  
0
  




 





 




  
0
  




 





0



     sub expr($)          { return $_[0]; } 




5911



  
0
  




 





 




  
0
  




 





0



     sub expr_or_check($) { return $_[0]; } 




5912



  
0
  




 





 




  
0
  




 





0



     sub asc($)           { return $_[0]; } 




5913



  
0
  




 





 




  
0
  




 





0



     sub desc($)          { return SQL::Yapp::Desc->obj($_[0]); } 




5914




 





 





 





 





 





 



 } 




5915




 





 





 





 





 





 



   




5916




 





 





 





 





 





 



 # Stmt: 




5917




 





 





 





 





 





 



 { 




5918




 





 





 





 





 





 



     package SQL::Yapp::Stmt; 




5919




 





 





 





 





 





 



   




5920




5





 





 




  
5
  




 





27



     use strict; 




 




5





 





 





 





 





8



   




 




5





 





 





 





 





104



   




5921




5





 





 




  
5
  




 





31



     use warnings; 




 




5





 





 





 





 





5



   




 




5





 





 





 





 





133



   




5922




5





 





 




  
5
  




 





19



     use Carp qw(croak); 




 




5





 





 





 





 





9



   




 




5





 





 





 





 





200



   




5923




5





 





 




  
5
  




 





23



     use base qw(SQL::Yapp::Obj1); 




 




5





 





 





 





 





12



   




 




5





 





 





 





 





1796



   




5924




 





 





 





 





 





 



   




5925




1





 





 




  
1
  




 





8



     sub subquery($)      { $_[0]->type_error('SELECT statement'); } 




5926



  
0
  




 





 




  
0
  




 





0



     sub exprparen($)     { $_[0]->subquery(); } 




5927




2





 





 




  
2
  




 





7



     sub expr($)          { $_[0]->subquery(); } 




5928



  
0
  




 





 




  
0
  




 





0



     sub expr_or_check($) { $_[0]->subquery(); } 




5929



  
0
  




 





 




  
0
  




 





0



     sub table1($)        { $_[0]->subquery(); } 




5930




 





 





 





 





 





 



   




5931




3





 





 




  
3
  




 





7



     sub stmt($)          { return $_[0]; } 




5932




 





 





 





 





 





 



   




5933




 





 





 





 





 





 



     sub do($) 




5934




 





 





 





 





 





 



     { 




5935



  
0
  




 





 




  
0
  




 





0



         my ($stmt) = @_; 




5936



  
0
  




 





 





 





 





0



         my $dbh = SQL::Yapp::get_dbh(); 




5937



  
0
  




 





 





 





 





0



         $dbh->do($stmt); 




5938



  
0
  




 





 





 





 





0



         return; # return no statements so that _max1_if_scalar is ok with void context 




5939




 





 





 





 





 





 



     } 




5940




 





 





 





 





 





 



 } 




5941




 





 





 





 





 





 



   




5942




 





 





 





 





 





 



 # SelectStmt: 




5943




 





 





 





 





 





 



 { 




5944




 





 





 





 





 





 



     package SQL::Yapp::SelectStmt; 




5945




 





 





 





 





 





 



   




5946




5





 





 




  
5
  




 





26



     use strict; 




 




5





 





 





 





 





13



   




 




5





 





 





 





 





126



   




5947




5





 





 




  
5
  




 





20



     use warnings; 




 




5





 





 





 





 





5



   




 




5





 





 





 





 





131



   




5948




5





 





 




  
5
  




 





21



     use Carp qw(croak); 




 




5





 





 





 





 





6



   




 




5





 





 





 





 





199



   




5949




5





 





 




  
5
  




 





22



     use base qw(SQL::Yapp::Stmt); 




 




5





 





 





 





 





8



   




 




5





 





 





 





 





1663



   




5950




 





 





 





 





 





 



   




5951




2





 





 




  
2
  




 





9



     sub subquery($)      { return '('.($_[0]->value).')'; } 




5952




 





 





 





 





 





 



   




5953




 





 





 





 





 





 



     sub fetch($) 




5954




 





 





 





 





 





 



     { 




5955



  
0
  




 





 




  
0
  




 





0



         my ($stmt) = @_; 




5956



  
0
  




 





 





 





 





0



         my $dbh = SQL::Yapp::get_dbh(); 




5957



  
0
  




 





 





 





 





0



         my $sth = $dbh->prepare($stmt); 




5958



  
0
  




 





 





 





 





0



         my $aref = $dbh->selectall_arrayref($sth, { Slice => {} }); 




5959



  
0
  



  
  0
  




 





 





 





0



         return unless $aref; 




5960



  
0
  




 





 





 





 





0



         return @$aref; 




5961




 





 





 





 





 





 



     } 




5962




 





 





 





 





 





 



 } 




5963




 





 





 





 





 





 



   




5964




 





 





 





 





 





 



 # SelectStmtSingle: 




5965




 





 





 





 





 





 



 { 




5966




 





 





 





 





 





 



     package SQL::Yapp::SelectStmtSingle; 




5967




 





 





 





 





 





 



   




5968




5





 





 




  
5
  




 





28



     use strict; 




 




5





 





 





 





 





7



   




 




5





 





 





 





 





123



   




5969




5





 





 




  
5
  




 





20



     use warnings; 




 




5





 





 





 





 





8



   




 




5





 





 





 





 





149



   




5970




5





 





 




  
5
  




 





20



     use Carp qw(croak); 




 




5





 





 





 





 





7



   




 




5





 





 





 





 





195



   




5971




5





 





 




  
5
  




 





25



     use base qw(SQL::Yapp::SelectStmt); 




 




5





 





 





 





 





12



   




 




5





 





 





 





 





1704



   




5972




 





 





 





 





 





 



   




5973




 





 





 





 





 





 



     sub fetch($) 




5974




 





 





 





 





 





 



     { 




5975



  
0
  




 





 




  
0
  




 





0



         my ($stmt) = @_; 




5976



  
0
  




 





 





 





 





0



         my $dbh = SQL::Yapp::get_dbh(); 




5977



  
0
  




 





 





 





 





0



         my $sth = $dbh->prepare($stmt); 




5978



  
0
  



  
  0
  




 





 





 





0



         return unless $sth->execute; 




5979



  
0
  




 





 





 





 





0



         my @r= (); 




5980



  
0
  




 





 





 





 





0



         while (my $a= $sth->fetchrow_arrayref) { 




5981



  
0
  



  
  0
  




 





 





 





0



             die unless scalar(@$a) == 1; 




5982



  
0
  




 





 





 





 





0



             push @r, $a->[0]; 




5983




 





 





 





 





 





 



         } 




5984



  
0
  




 





 





 





 





0



         return @r; 




5985




 





 





 





 





 





 



     } 




5986




 





 





 





 





 





 



 } 




5987




 





 





 





 





 





 



   




5988




 





 





 





 





 





 



 # Do: 




5989




 





 





 





 





 





 



 # This is a bit different, since the obj() method will actually execute the statement. 




5990




 





 





 





 





 





 



 { 




5991




 





 





 





 





 





 



     package SQL::Yapp::Do; 




5992




 





 





 





 





 





 



   




5993




5





 





 




  
5
  




 





28



     use strict; 




 




5





 





 





 





 





8



   




 




5





 





 





 





 





125



   




5994




5





 





 




  
5
  




 





27



     use warnings; 




 




5





 





 





 





 





7



   




 




5





 





 





 





 





149



   




5995




5





 





 




  
5
  




 





20



     use Carp qw(confess); 




 




5





 





 





 





 





9



   




 




5





 





 





 





 





414



   




5996




 





 





 





 





 





 



   




5997




 





 





 





 





 





 



     sub obj($$) 




5998




 





 





 





 





 





 



     { 




5999



  
0
  




 





 




  
0
  




 





0



         my ($class, $stmt) = @_; 




6000



  
0
  




 





 





 





 





0



         return $stmt->do; 




6001




 





 





 





 





 





 



     } 




6002




 





 





 





 





 





 



 } 




6003




 





 





 





 





 





 



   




6004




 





 





 





 





 





 



 # Fetch: 




6005




 





 





 





 





 





 



 # This is a bit different, since the obj() method will actually execute the statement. 




6006




 





 





 





 





 





 



 { 




6007




 





 





 





 





 





 



     package SQL::Yapp::Fetch; 




6008




 





 





 





 





 





 



   




6009




5





 





 




  
5
  




 





26



     use strict; 




 




5





 





 





 





 





7



   




 




5





 





 





 





 





105



   




6010




5





 





 




  
5
  




 





19



     use warnings; 




 




5





 





 





 





 





7



   




 




5





 





 





 





 





323



   




6011




 





 





 





 





 





 



   




6012




 





 





 





 





 





 



     sub obj($$) 




6013




 





 





 





 





 





 



     { 




6014



  
0
  




 





 




  
0
  




 





0



         my ($class, $stmt) = @_; 




6015



  
0
  




 





 





 





 





0



         return $stmt->fetch; 




6016




 





 





 





 





 





 



     } 




6017




 





 





 





 





 





 



 } 




6018




 





 





 





 





 





 



   




6019




 





 





 





 





 





 



 # ColumnName: 




6020




 





 





 





 





 





 



 { 




6021




 





 





 





 





 





 



     package SQL::Yapp::ColumnName; 




6022




 





 





 





 





 





 



   




6023




5





 





 




  
5
  




 





29



     use strict; 




 




5





 





 





 





 





13



   




 




5





 





 





 





 





100



   




6024




5





 





 




  
5
  




 





20



     use warnings; 




 




5





 





 





 





 





6



   




 




5





 





 





 





 





115



   




6025




5





 





 




  
5
  




 





18



     use base qw(SQL::Yapp::Obj1); 




 




5





 





 





 





 





7



   




 




5





 





 





 





 





1245



   




6026




 





 





 





 





 





 



   




6027



  
0
  




 





 




  
0
  




 





0



     sub colname($) { return $_[0]; } 




6028




 





 





 





 





 





 



 } 




6029




 





 





 





 





 





 



   




6030




 





 





 





 





 





 



 # TableName: 




6031




 





 





 





 





 





 



 { 




6032




 





 





 





 





 





 



     package SQL::Yapp::TableName; 




6033




 





 





 





 





 





 



   




6034




5





 





 




  
5
  




 





25



     use strict; 




 




5





 





 





 





 





9



   




 




5





 





 





 





 





77



   




6035




5





 





 




  
5
  




 





18



     use warnings; 




 




5





 





 





 





 





7



   




 




5





 





 





 





 





127



   




6036




5





 





 




  
5
  




 





19



     use base qw(SQL::Yapp::Obj1); 




 




5





 





 





 





 





112



   




 




5





 





 





 





 





1133



   




6037




 





 





 





 





 





 



   




6038



  
0
  




 





 




  
0
  




 





0



     sub tabname($) { return $_[0]; } 




6039




 





 





 





 





 





 



 } 




6040




 





 





 





 





 





 



   




6041




 





 





 





 





 





 



 # Column: 




6042




 





 





 





 





 





 



 { 




6043




 





 





 





 





 





 



     package SQL::Yapp::Column; 




6044




 





 





 





 





 





 



   




6045




5





 





 




  
5
  




 





40



     use strict; 




 




5





 





 





 





 





7



   




 




5





 





 





 





 





125



   




6046




5





 





 




  
5
  




 





30



     use warnings; 




 




5





 





 





 





 





8



   




 




5





 





 





 





 





157



   




6047




5





 





 




  
5
  




 





29



     use base qw(SQL::Yapp::Obj1); 




 




5





 





 





 





 





6



   




 




5





 





 





 





 





1790



   




6048




 





 





 





 





 





 



   




6049




2





 





 




  
2
  




 





6



     sub column1($)       { return $_[0]; } 




6050




3





 





 




  
3
  




 





9



     sub exprparen($)     { return $_[0]; } 




6051




1





 





 




  
1
  




 





4



     sub expr($)          { return $_[0]; } 




6052



  
0
  




 





 




  
0
  




 





0



     sub expr_or_check($) { return $_[0]; } 




6053




2





 





 




  
2
  




 





4



     sub asc($)           { return $_[0]; } 




6054




5





 





 




  
5
  




 





18



     sub desc($)          { return SQL::Yapp::Desc->obj($_[0]); } 




6055




 





 





 





 





 





 



 } 




6056




 





 





 





 





 





 



   




6057




 





 





 





 





 





 



 # Table: 




6058




 





 





 





 





 





 



 { 




6059




 





 





 





 





 





 



     package SQL::Yapp::Table; 




6060




5





 





 




  
5
  




 





28



     use strict; 




 




5





 





 





 





 





7



   




 




5





 





 





 





 





101



   




6061




5





 





 




  
5
  




 





18



     use warnings; 




 




5





 





 





 





 





15



   




 




5





 





 





 





 





121



   




6062




5





 





 




  
5
  




 





18



     use base qw(SQL::Yapp::Obj1); 




 




5





 





 





 





 





8



   




 




5





 





 





 





 





1066



   




6063




5





 





 




  
5
  




 





14



     sub table1($) { return $_[0]; } 




6064




 





 





 





 





 





 



 } 




6065




 





 





 





 





 





 



   




6066




 





 





 





 





 





 



 # CharSet: 




6067




 





 





 





 





 





 



 { 




6068




 





 





 





 





 





 



     package SQL::Yapp::CharSet; 




6069




5





 





 




  
5
  




 





32



     use strict; 




 




5





 





 





 





 





6



   




 




5





 





 





 





 





93



   




6070




5





 





 




  
5
  




 





18



     use warnings; 




 




5





 





 





 





 





12



   




 




5





 





 





 





 





138



   




6071




5





 





 




  
5
  




 





62



     use base qw(SQL::Yapp::Obj1); 




 




5





 





 





 





 





13



   




 




5





 





 





 





 





1043



   




6072



  
0
  




 





 




  
0
  




 





0



     sub charset1($) { return $_[0]; } 




6073




 





 





 





 





 





 



 } 




6074




 





 





 





 





 





 



   




6075




 





 





 





 





 





 



 # Collate: 




6076




 





 





 





 





 





 



 { 




6077




 





 





 





 





 





 



     package SQL::Yapp::Collate; 




6078




5





 





 




  
5
  




 





34



     use strict; 




 




5





 





 





 





 





8



   




 




5





 





 





 





 





125



   




6079




5





 





 




  
5
  




 





25



     use warnings; 




 




5





 





 





 





 





7



   




 




5





 





 





 





 





135



   




6080




5





 





 




  
5
  




 





21



     use base qw(SQL::Yapp::Obj1); 




 




5





 





 





 





 





6



   




 




5





 





 





 





 





1069



   




6081



  
0
  




 





 




  
0
  




 





0



     sub collate1($) { return $_[0]; } 




6082




 





 





 





 





 





 



 } 




6083




 





 





 





 





 





 



   




6084




 





 





 





 





 





 



 # Constraint: 




6085




 





 





 





 





 





 



 { 




6086




 





 





 





 





 





 



     package SQL::Yapp::Constraint; 




6087




5





 





 




  
5
  




 





25



     use strict; 




 




5





 





 





 





 





14



   




 




5





 





 





 





 





107



   




6088




5





 





 




  
5
  




 





17



     use warnings; 




 




5





 





 





 





 





15



   




 




5





 





 





 





 





137



   




6089




5





 





 




  
5
  




 





22



     use base qw(SQL::Yapp::Obj1); 




 




5





 





 





 





 





7



   




 




5





 





 





 





 





1075



   




6090



  
0
  




 





 




  
0
  




 





0



     sub constraint1($) { return $_[0]; } 




6091




 





 





 





 





 





 



 } 




6092




 





 





 





 





 





 



   




6093




 





 





 





 





 





 



 # Index: 




6094




 





 





 





 





 





 



 { 




6095




 





 





 





 





 





 



     package SQL::Yapp::Index; 




6096




5





 





 




  
5
  




 





27



     use strict; 




 




5





 





 





 





 





8



   




 




5





 





 





 





 





106



   




6097




5





 





 




  
5
  




 





23



     use warnings; 




 




5





 





 





 





 





17



   




 




5





 





 





 





 





125



   




6098




5





 





 




  
5
  




 





26



     use base qw(SQL::Yapp::Obj1); 




 




5





 





 





 





 





7



   




 




5





 





 





 





 





1058



   




6099



  
0
  




 





 




  
0
  




 





0



     sub index1($) { return $_[0]; } 




6100




 





 





 





 





 





 



 } 




6101




 





 





 





 





 





 



   




6102




 





 





 





 





 





 



 # Transliteration: 




6103




 





 





 





 





 





 



 { 




6104




 





 





 





 





 





 



     package SQL::Yapp::Transliteration; 




6105




5





 





 




  
5
  




 





26



     use strict; 




 




5





 





 





 





 





5



   




 




5





 





 





 





 





96



   




6106




5





 





 




  
5
  




 





18



     use warnings; 




 




5





 





 





 





 





6



   




 




5





 





 





 





 





121



   




6107




5





 





 




  
5
  




 





29



     use base qw(SQL::Yapp::Obj1); 




 




5





 





 





 





 





9



   




 




5





 





 





 





 





1059



   




6108



  
0
  




 





 




  
0
  




 





0



     sub transliteration($) { return $_[0]; } 




6109




 





 





 





 





 





 



 } 




6110




 





 





 





 





 





 



   




6111




 





 





 





 





 





 



 # Transcoding: 




6112




 





 





 





 





 





 



 { 




6113




 





 





 





 





 





 



     package SQL::Yapp::Transcoding; 




6114




5





 





 




  
5
  




 





28



     use strict; 




 




5





 





 





 





 





6



   




 




5





 





 





 





 





96



   




6115




5





 





 




  
5
  




 





18



     use warnings; 




 




5





 





 





 





 





8



   




 




5





 





 





 





 





175



   




6116




5





 





 




  
5
  




 





27



     use base qw(SQL::Yapp::Obj1); 




 




5





 





 





 





 





8



   




 




5





 





 





 





 





1077



   




6117



  
0
  




 





 




  
0
  




 





0



     sub transcoding($) { return $_[0]; } 




6118




 





 





 





 





 





 



 } 




6119




 





 





 





 





 





 



   




6120




 





 





 





 





 





 



 # TableOption: 




6121




 





 





 





 





 





 



 { 




6122




 





 





 





 





 





 



     package SQL::Yapp::TableOption; 




6123




5





 





 




  
5
  




 





30



     use strict; 




 




5





 





 





 





 





7



   




 




5





 





 





 





 





91



   




6124




5





 





 




  
5
  




 





19



     use warnings; 




 




5





 





 





 





 





8



   




 




5





 





 





 





 





117



   




6125




5





 





 




  
5
  




 





25



     use base qw(SQL::Yapp::Obj1); 




 




5





 





 





 





 





8



   




 




5





 





 





 





 





1032



   




6126




2





 





 




  
2
  




 





6



     sub tableopt($) { return $_[0]; } 




6127




 





 





 





 





 





 



 } 




6128




 





 





 





 





 





 



   




6129




 





 





 





 





 





 



 # Engine: 




6130




 





 





 





 





 





 



 { 




6131




 





 





 





 





 





 



     package SQL::Yapp::Engine; 




6132




5





 





 




  
5
  




 





34



     use strict; 




 




5





 





 





 





 





7



   




 




5





 





 





 





 





90



   




6133




5





 





 




  
5
  




 





25



     use warnings; 




 




5





 





 





 





 





7



   




 




5





 





 





 





 





119



   




6134




5





 





 




  
5
  




 





21



     use base qw(SQL::Yapp::Obj1); 




 




5





 





 





 





 





8



   




 




5





 





 





 





 





1073



   




6135



  
0
  




 





 




  
0
  




 





0



     sub engine1($) { return $_[0]; } 




6136




 





 





 





 





 





 



 } 




6137




 





 





 





 





 





 



   




6138




 





 





 





 





 





 



   




6139




 





 





 





 





 





 



 # Join: 




6140




 





 





 





 





 





 



 { 




6141




 





 





 





 





 





 



     package SQL::Yapp::Join; 




6142




 





 





 





 





 





 



   




6143




5





 





 




  
5
  




 





25



     use strict; 




 




5





 





 





 





 





8



   




 




5





 





 





 





 





96



   




6144




5





 





 




  
5
  




 





26



     use warnings; 




 




5





 





 





 





 





8



   




 




5





 





 





 





 





127



   




6145




5





 





 




  
5
  




 





27



     use base qw(SQL::Yapp::Obj1); 




 




5





 





 





 





 





6



   




 




5





 





 





 





 





1068



   




6146




 





 





 





 





 





 



   




6147




4





 





 




  
4
  




 





10



     sub joinclause($) { return $_[0]; } 




6148




 





 





 





 





 





 



 } 




6149




 





 





 





 





 





 



   




6150




 





 





 





 





 





 



 # Check: 




6151




 





 





 





 





 





 



 { 




6152




 





 





 





 





 





 



     package SQL::Yapp::Check; 




6153




 





 





 





 





 





 



   




6154




5





 





 




  
5
  




 





24



     use strict; 




 




5





 





 





 





 





8



   




 




5





 





 





 





 





86



   




6155




5





 





 




  
5
  




 





17



     use warnings; 




 




5





 





 





 





 





14



   




 




5





 





 





 





 





125



   




6156




5





 





 




  
5
  




 





20



     use base qw(SQL::Yapp::Obj1); 




 




5





 





 





 





 





7



   




 




5





 





 





 





 





1509



   




6157




 





 





 





 





 





 



   




6158




3





 





 




  
3
  




 





23



     sub check($)         { return $_[0]; } 




6159




3





 





 




  
3
  




 





8



     sub expr_or_check($) { return $_[0]; } 




6160




 





 





 





 





 





 



   




6161




 





 





 





 





 





 



     sub obj($$) 




6162




 





 





 





 





 





 



     { 




6163




18




  
100
  




 




  
18
  




 





54



         if (ref($_[1]) eq $_[0]) { 




 




 




  
100
  




 





 





 





 



   




6164




9





 





 





 





 





31



             return $_[1]; 




6165




 





 





 





 





 





 



         } 




6166




 





 





 





 





 





 



         elsif (ref($_[1])) { 




6167




7





 





 





 





 





18



             bless($_[1], $_[0]); 




6168




 





 





 





 





 





 



         } 




6169




 





 





 





 





 





 



         else { 




6170




2





 





 





 





 





9



             $_[0]->SUPER::obj($_[1]); 




6171




 





 





 





 





 





 



         } 




6172




 





 





 





 





 





 



     } 




6173




 





 





 





 





 





 



 } 




6174




 





 





 





 





 





 



   




6175




 





 





 





 





 





 



 # Expr: 




6176




 





 





 





 





 





 



 { 




6177




 





 





 





 





 





 



     package SQL::Yapp::Expr; 




6178




 





 





 





 





 





 



   




6179




5





 





 




  
5
  




 





26



     use strict; 




 




5





 





 





 





 





11



   




 




5





 





 





 





 





108



   




6180




5





 





 




  
5
  




 





18



     use warnings; 




 




5





 





 





 





 





12



   




 




5





 





 





 





 





136



   




6181




5





 





 




  
5
  




 





19



     use base qw(SQL::Yapp::Obj1); 




 




5





 





 





 





 





11



   




 




5





 





 





 





 





1540



   




6182




 





 





 





 





 





 



   




6183



  
0
  




 





 




  
0
  




 





0



     sub exprparen($)     { return '('.($_[0]->value).')'; } 




6184




18





 





 




  
18
  




 





54



     sub expr($)          { return $_[0]; } 




6185



  
0
  




 





 




  
0
  




 





0



     sub expr_or_check($) { return $_[0]; } 




6186



  
0
  




 





 




  
0
  




 





0



     sub asc($)           { return $_[0]; } 




6187



  
0
  




 





 




  
0
  




 





0



     sub desc($)          { return SQL::Yapp::Desc->obj($_[0]); } 




6188




 





 





 





 





 





 



 } 




6189




 





 





 





 





 





 



   




6190




 





 





 





 





 





 



 # Infix: 




6191




 





 





 





 





 





 



 { 




6192




 





 





 





 





 





 



     package SQL::Yapp::Infix; 




6193




 





 





 





 





 





 



   




6194




5





 





 




  
5
  




 





27



     use strict; 




 




5





 





 





 





 





7



   




 




5





 





 





 





 





96



   




6195




5





 





 




  
5
  




 





18



     use warnings; 




 




5





 





 





 





 





20



   




 




5





 





 





 





 





148



   




6196




5





 





 




  
5
  




 





20



     use base qw(SQL::Yapp::Expr); 




 




5





 





 





 





 





7



   




 




5





 





 





 





 





1234



   




6197




5





 





 




  
5
  




 





28



     use Carp qw(croak); 




 




5





 





 





 





 





7



   




 




5





 





 





 





 





1138



   




6198




 





 





 





 





 





 



   




6199




 





 





 





 





 





 



     sub obj($$$$) 




6200




 





 





 





 





 





 



     { 




6201




56





 





 




  
56
  




 





112



         my ($class, $op, $a1, $a2)= @_; 




6202




56





 





 





 





 





144



         return bless(["$a1 $op $a2", $op, $a1, $a2], $class); 




6203




 





 





 





 





 





 



     } 




6204




 





 





 





 





 





 



   




6205




14





 





 




  
14
  




 





31



     sub op($)     { return $_[0][1]; } 




6206




14





 





 




  
14
  




 





33



     sub arg1($)   { return $_[0][2]; } 




6207




14





 





 




  
14
  




 





22



     sub arg2($)   { return $_[0][3]; } 




6208




 





 





 





 





 





 



   




6209




 





 





 





 





 





 



     sub assign($) 




6210




 





 





 





 





 





 



     { 




6211




14





 





 




  
14
  




 





17



         my ($self)= @_; 




6212




14




  
 50
  




 





 





 





20



         if ($self->op() eq '=') { # we're not checking everything, just whether it's an assignment 




6213




14





 





 





 





 





27



             return $self; 




6214




 





 





 





 





 





 



         } 




6215



  
0
  




 





 





 





 





0



         croak "Assignment expected, but found top-level operator '".($self->op)."'."; 




6216




 





 





 





 





 





 



     } 




6217




 





 





 





 





 





 



 } 




6218




 





 





 





 





 





 



   




6219




 





 





 





 





 





 



 # Order: 




6220




 





 





 





 





 





 



 { 




6221




 





 





 





 





 





 



     package SQL::Yapp::Order; 




6222




 





 





 





 





 





 



   




6223




5





 





 




  
5
  




 





27



     use strict; 




 




5





 





 





 





 





6



   




 




5





 





 





 





 





99



   




6224




5





 





 




  
5
  




 





17



     use warnings; 




 




5





 





 





 





 





9



   




 




5





 





 





 





 





126



   




6225




5





 





 




  
5
  




 





20



     use base qw(SQL::Yapp::Obj1); 




 




5





 





 





 





 





7



   




 




5





 





 





 





 





1170



   




6226




5





 





 




  
5
  




 





31



     use Scalar::Util qw(blessed); 




 




5





 





 





 





 





8



   




 




5





 





 





 





 





483



   




6227




 





 





 





 





 





 



   




6228




 





 





 





 





 





 



     sub obj($$) 




6229




 





 





 





 





 





 



     { 




6230




7





 





 




  
7
  




 





41



         my ($class,$x)= @_; 




6231




7




  
 50
  



  
 33
  




 





 





68



         return $x 




6232




 





 





 





 





 





 



             if blessed($x) && $x->isa('SQL::Yapp::Obj'); 




6233



  
0
  




 





 





 





 





0



         return bless([$x], 'SQL::Yapp::Asc'); # not Order, but Asc. 




6234




 





 





 





 





 





 



     } 




6235




 





 





 





 





 





 



 } 




6236




 





 





 





 





 





 



   




6237




 





 





 





 





 





 



 # Asc: 




6238




 





 





 





 





 





 



 { 




6239




 





 





 





 





 





 



     package SQL::Yapp::Asc; 




6240




 





 





 





 





 





 



   




6241




5





 





 




  
5
  




 





25



     use strict; 




 




5





 





 





 





 





6



   




 




5





 





 





 





 





131



   




6242




5





 





 




  
5
  




 





22



     use warnings; 




 




5





 





 





 





 





6



   




 




5





 





 





 





 





124



   




6243




5





 





 




  
5
  




 





20



     use base qw(SQL::Yapp::Order); 




 




5





 





 





 





 





14



   




 




5





 





 





 





 





1406



   




6244




 





 





 





 





 





 



   




6245



  
0
  




 





 




  
0
  




 





0



     sub asc($)  { return $_[0]; } 




6246



  
0
  




 





 




  
0
  




 





0



     sub desc($) { return SQL::Yapp::Desc->obj($_[0]); } 




6247




 





 





 





 





 





 



 } 




6248




 





 





 





 





 





 



   




6249




 





 





 





 





 





 



 # Desc: 




6250




 





 





 





 





 





 



 { 




6251




 





 





 





 





 





 



     package SQL::Yapp::Desc; 




6252




 





 





 





 





 





 



   




6253




5





 





 




  
5
  




 





28



     use strict; 




 




5





 





 





 





 





7



   




 




5





 





 





 





 





93



   




6254




5





 





 




  
5
  




 





27



     use warnings; 




 




5





 





 





 





 





8



   




 




5





 





 





 





 





126



   




6255




5





 





 




  
5
  




 





21



     use base qw(SQL::Yapp::Order); 




 




5





 





 





 





 





7



   




 




5





 





 





 





 





1508



   




6256




 





 





 





 





 





 



   




6257




 





 





 





 





 





 



     sub obj($$) 




6258




 





 





 





 





 





 



     { 




6259




9





 





 




  
9
  




 





15



         my ($class, $orig)= @_; 




6260




9





 





 





 





 





17



         return bless(["$orig DESC",$orig],$class); 




6261




 





 





 





 





 





 



     } 




6262




 





 





 





 





 





 



   




6263




1





 





 




  
1
  




 





3



     sub orig($) { return $_[0][1]; } 




6264




 





 





 





 





 





 



   




6265




2





 





 




  
2
  




 





7



     sub asc($)  { return $_[0]; } 




6266




1





 





 




  
1
  




 





3



     sub desc($) { return &orig; } 




6267




 





 





 





 





 





 



 } 




6268




 





 





 





 





 





 



   




6269




 





 





 





 





 





 



 # Type: 




6270




 





 





 





 





 





 



 { 




6271




 





 





 





 





 





 



     package SQL::Yapp::Type; 




6272




 





 





 





 





 





 



   




6273




5





 





 




  
5
  




 





27



     use strict; 




 




5





 





 





 





 





6



   




 




5





 





 





 





 





114



   




6274




5





 





 




  
5
  




 





21



     use warnings; 




 




5





 





 





 





 





13



   




 




5





 





 





 





 





151



   




6275




5





 





 




  
5
  




 





21



     use base qw(SQL::Yapp::Obj); 




 




5





 





 





 





 





9



   




 




5





 





 





 





 





1092



   




6276




5





 





 




  
5
  




 





27



     use Hash::Util qw(lock_keys); 




 




5





 





 





 





 





8



   




 




5





 





 





 





 





35



   




6277




5





 





 




  
5
  




 





247



     use Carp qw(croak); 




 




5





 





 





 





 





6



   




 




5





 





 





 





 





3222



   




6278




 





 





 





 





 





 



   




6279




 





 





 





 





 





 



     sub set_base($$$) 




6280




 





 





 





 





 





 



     { 




6281




11





 





 




  
11
  




 





22



         my ($self, $base, $spec)= @_; 




6282




 





 





 





 





 





 



   




6283




 





 





 





 





 





 



         # set new spec: 




6284




11





 





 





 





 





19



         $self->{base}= $base; 




6285




11





 





 





 





 





17



         $self->{spec}= $spec; 




6286




 





 





 





 





 





 



   




6287




 





 





 





 





 





 



         # filter options by new spec: 




6288




11





 





 





 





 





12



         for my $o (keys %{ $self->{option} }) { 




 




11





 





 





 





 





30



   




6289




3




  
100
  




 





 





 





10



             unless ($spec->{$o}) { 




6290




1





 





 





 





 





2



                 delete $self->{option}{$o}; 




6291




 





 





 





 





 





 



             } 




6292




 





 





 





 





 





 



         } 




6293




 





 





 





 





 





 



   




6294




11





 





 





 





 





93



         return $self; 




6295




 





 





 





 





 





 



     } 




6296




 





 





 





 





 





 



   




6297




 





 





 





 





 





 



     sub set_property($$$) 




6298




 





 





 





 





 





 



     { 




6299




13





 





 




  
13
  




 





21



         my ($self, $key, $value)= @_; 




6300




13





 





 





 





 





41



         my %a= %$self; 




6301




13




  
 50
  




 





 





 





34



         croak "No $key for $self->{base} allowed." unless $self->{spec}{$key}; 




6302




13





 





 





 





 





25



         $self->{option}{$key}= $value; 




6303




13





 





 





 





 





23



         return $self; 




6304




 





 





 





 





 





 



     } 




6305




 





 





 





 





 





 



   




6306




 





 





 





 





 





 



     sub new($) 




6307




 





 





 





 





 





 



     { 




6308




9





 





 




  
9
  




 





1517



         my $r= bless({ base => undef, spec => undef, option => {} }, $_[0]); 




6309




9





 





 





 





 





85



         lock_keys %$r; 




6310




9





 





 





 





 





128



         return $r; 




6311




 





 





 





 





 





 



     } 




6312




 





 





 





 





 





 



   




6313




 





 





 





 





 





 



     sub obj($$) 




6314




 





 





 





 





 





 



     { 




6315




13





 





 




  
13
  




 





143



         return $_[1]; 




6316




 





 





 





 





 





 



     } 




6317




 





 





 





 





 





 



   




6318




 





 





 





 





 





 



     sub clone($) 




6319




 





 





 





 





 





 



     { 




6320




11





 





 




  
11
  




 





17



         my ($self)= @_; 




6321




 





 





 





 





 





 



         my $r= bless({ 




6322




 





 





 





 





 





 



                    %$self, 




6323




 





 





 





 





 





 



                    # no need to make a deep copy of 'spec', because it is never changed. 




6324




11





 





 





 





 





22



                    option => { %{ $self->{option} } }, 




 




11





 





 





 





 





45



   




6325




 





 





 





 





 





 



                }, __PACKAGE__); 




6326




11





 





 





 





 





41



         lock_keys %$r; 




6327




11





 





 





 





 





117



         return $r; 




6328




 





 





 





 





 





 



     } 




6329




 





 





 





 





 





 



   




6330




 





 





 





 





 





 



     sub type($) 




6331




 





 





 





 





 





 



     { 




6332




7





 





 




  
7
  




 





13



         return $_[0]->clone(); # make a copy before trying to modify this 




6333




 





 





 





 





 





 



     } 




6334




 





 





 





 





 





 



   




6335




 





 





 





 





 





 



     sub colspec($) 




6336




 





 





 





 





 





 



     { 




6337




1





 





 




  
1
  




 





8



         return SQL::Yapp::ColumnSpec->new($_[0]); # make a copy producing a ColumnSpec 




6338




 





 





 





 





 





 



     } 




6339




 





 





 





 





 





 



   




6340




 





 





 





 





 





 



     sub value($) 




6341




 





 





 





 





 





 



     { 




6342




38





 





 




  
38
  




 





63



         my ($self)= @_; 




6343




38




  
100
  




 





 





 





91



         return '' unless $self->{base}; 




6344




20





 





 





 





 





36



         my @r= ($self->{base}); 




6345




20




  
100
  



  
 66
  




 





 





79



         if ($self->{spec}{prec1} && defined $self->{option}{prec1}) { 




6346




19





 





 





 





 





25



             my $len_str= ''; 




6347




19





 





 





 





 





32



             $len_str.= $self->{option}{prec1}; 




6348




19




  
 50
  



  
 66
  




 





 





41



             if ($self->{spec}{prec2} && defined $self->{option}{prec2}) { 




6349



  
0
  




 





 





 





 





0



                 $len_str.= ', '.$self->{option}{prec2}; 




6350




 





 





 





 





 





 



             } 




6351




 





 





 





 





 





 



             else { 




6352




19




  
  0
  



  
 33
  




 





 





33



                 if ($self->{spec}{prec_mul} && $self->{option}{prec_mul}) { 




6353



  
0
  




 





 





 





 





0



                     $len_str.= ' '.$self->{option}{prec_mul}; 




6354




 





 





 





 





 





 



                 } 




6355




19




  
  0
  



  
 33
  




 





 





30



                 if ($self->{spec}{prec_unit} && $self->{option}{prec_unit}) { 




6356



  
0
  




 





 





 





 





0



                     $len_str.= ' '.$self->{option}{prec_unit}; 




6357




 





 





 





 





 





 



                 } 




6358




 





 





 





 





 





 



             } 




6359




19





 





 





 





 





43



             push @r, '('.$len_str.')'; 




6360




 





 





 





 





 





 



         } 




6361




20




  
 50
  



  
 33
  




 





 





49



         if (my $value_list= $self->{spec}{value_list} && $self->{option}{value_list}) { 




6362



  
0
  




 





 





 





 





0



             push @r, '('.join(', ',@$value_list).')'; 




6363




 





 





 





 





 





 



         } 




6364




20




  
100
  



  
100
  




 





 





63



         if (my $x= $self->{spec}{charset} && $self->{option}{charset}) { 




6365




3





 





 





 





 





4



             push @r, 'CHARACTER SET', $x; 




6366




 





 





 





 





 





 



         } 




6367




20




  
 50
  



  
 66
  




 





 





58



         if (my $x= $self->{spec}{collate} && $self->{option}{collate}) { 




6368



  
0
  




 





 





 





 





0



             push @r, 'COLLATE', $x; 




6369




 





 





 





 





 





 



         } 




6370




20





 





 





 





 





35



         for my $key ('sign', 'zerofill', 'timezone') { 




6371




60




  
 50
  



  
 66
  




 





 





134



             if (my $x= $self->{spec}{$key} && $self->{option}{$key}) { 




6372



  
0
  




 





 





 





 





0



                 push @r, $x; 




6373




 





 





 





 





 





 



             } 




6374




 





 





 





 





 





 



         } 




6375




 





 





 





 





 





 



   




6376




20





 





 





 





 





132



         return join(' ', @r); 




6377




 





 





 





 





 





 



     } 




6378




 





 





 





 





 





 



 } 




6379




 





 





 





 





 





 



   




6380




 





 





 





 





 





 



   




6381




 





 





 





 





 





 



 # ColumnSpec: 




6382




 





 





 





 





 





 



 { 




6383




 





 





 





 





 





 



     package SQL::Yapp::ColumnSpec; 




6384




 





 





 





 





 





 



   




6385




5





 





 




  
5
  




 





31



     use strict; 




 




5





 





 





 





 





7



   




 




5





 





 





 





 





93



   




6386




5





 





 




  
5
  




 





17



     use warnings; 




 




5





 





 





 





 





7



   




 




5





 





 





 





 





150



   




6387




5





 





 




  
5
  




 





19



     use base qw(SQL::Yapp::Obj); 




 




5





 





 





 





 





9



   




 




5





 





 





 





 





982



   




6388




5





 





 




  
5
  




 





27



     use Hash::Util qw(lock_keys); 




 




5





 





 





 





 





13



   




 




5





 





 





 





 





17



   




6389




5





 





 




  
5
  




 





241



     use Carp qw(croak); 




 




5





 





 





 





 





7



   




 




5





 





 





 





 





30917



   




6390




 





 





 





 





 





 



   




6391




 





 





 





 





 





 



     sub new($$) 




6392




 





 





 





 





 





 



     { 




6393




3





 





 




  
3
  




 





17



         my ($class, $type)= @_; 




6394




3





 





 





 





 





11



         my $r= bless({ datatype => $type->clone(), name => {}, option => {} }, $class); 




6395




3





 





 





 





 





39



         lock_keys %$r; 




6396




3





 





 





 





 





50



         return $r; 




6397




 





 





 





 





 





 



     } 




6398




 





 





 





 





 





 



   




6399




 





 





 





 





 





 



     sub obj($$) 




6400




 





 





 





 





 





 



     { 




6401




3





 





 




  
3
  




 





21



         return $_[1]; 




6402




 





 





 





 





 





 



     } 




6403




 





 





 





 





 





 



   




6404




 





 





 





 





 





 



     sub clone($) 




6405




 





 





 





 





 





 



     { 




6406




1





 





 




  
1
  




 





3



         my ($self)= @_; 




6407




 





 





 





 





 





 



         my $r= bless({ 




6408




 





 





 





 





 





 



                    datatype => $self->{datatype}->clone(), 




6409




1





 





 





 





 





3



                    name   => { %{ $self->{name}   } }, 




6410




1





 





 





 





 





5



                    option => { %{ $self->{option} } }, 




 




1





 





 





 





 





5



   




6411




 





 





 





 





 





 



                }, __PACKAGE__); 




6412




1





 





 





 





 





4



         lock_keys %$r; 




6413




1





 





 





 





 





8



         return $r; 




6414




 





 





 





 





 





 



     } 




6415




 





 





 





 





 





 



   




6416




 





 





 





 





 





 



     sub colspec($) 




6417




 





 





 





 





 





 



     { 




6418




1





 





 




  
1
  




 





4



         return $_[0]->clone(); # make a copy before trying to modify this 




6419




 





 





 





 





 





 



     } 




6420




 





 





 





 





 





 



   




6421




 





 





 





 





 





 



     sub name($$) 




6422




 





 





 





 





 





 



     { 




6423




6





 





 




  
6
  




 





13



         my ($self, $key)= @_; 




6424




6




  
 50
  




 





 





 





16



         if (my $x= $self->{name}{$key}) { 




6425



  
0
  




 





 





 





 





0



             return ('CONSTRAINT', $x); 




6426




 





 





 





 





 





 



         } 




6427




6





 





 





 





 





17



         return; 




6428




 





 





 





 





 





 



     } 




6429




 





 





 





 





 





 



   




6430




 





 





 





 





 





 



     sub value($) 




6431




 





 





 





 





 





 



     { 




6432




4





 





 




  
4
  




 





11



         my ($self)= @_; 




6433




4





 





 





 





 





12



         my @r= ($self->{datatype}); 




6434




 





 





 





 





 





 



   




6435




4





 





 





 





 





13



         for my $key ('notnull', 'autoinc', 'unique', 'primary', 'key') { 




6436




20




  
100
  




 





 





 





47



             if (my $x= $self->{option}{$key}) { 




6437




4





 





 





 





 





13



                 push @r, $self->name($key), $x; 




6438




 





 





 





 





 





 



             } 




6439




 





 





 





 





 





 



         } 




6440




 





 





 





 





 





 



   




6441




4





 





 





 





 





13



         for my $key ('default', 'column_format', 'storage') { 




6442




12




  
100
  




 





 





 





32



             if (my $x= $self->{option}{$key}) { 




6443




2





 





 





 





 





5



                 push @r, $self->name($key), uc($key), $x; 




6444




 





 





 





 





 





 



             } 




6445




 





 





 





 





 





 



         } 




6446




 





 





 





 





 





 



   




6447




4





 





 





 





 





8



         for my $key ('check') { 




6448




4




  
 50
  




 





 





 





24



             if (my $x= $self->{option}{$key}) { 




6449



  
0
  




 





 





 





 





0



                 push @r, $self->name($key), uc($key), '('.$x.')'; 




6450




 





 





 





 





 





 



             } 




6451




 





 





 





 





 





 



         } 




6452




 





 





 





 





 





 



   




6453




4





 





 





 





 





9



         for my $key ('references') { 




6454




4




  
 50
  




 





 





 





11



             if (my $x= $self->{option}{$key}) { 




6455



  
0
  




 





 





 





 





0



                 push @r, $self->name($key), $x; 




6456




 





 





 





 





 





 



             } 




6457




 





 





 





 





 





 



         } 




6458




 





 





 





 





 





 



   




6459




4





 





 





 





 





12



         return join(' ', @r); 




6460




 





 





 





 





 





 



     } 




6461




 





 





 





 





 





 



 } 




6462




 





 





 





 





 





 



   




6463




 





 





 





 





 





 



   




6464




 





 





 





 





 





 



 # Special Constants: 




6465




2





 





 




  
2
  



  
0
  




259



 sub ASTERISK { SQL::Yapp::Asterisk->obj(); } 




6466




1





 





 




  
1
  



  
0
  




7



 sub QUESTION { SQL::Yapp::Question->obj(); } 




6467



  
0
  




 





 




  
0
  



  
0
  




0



 sub NULL     { SQL::Yapp::ExprSpecial->obj('NULL'); } 




6468



  
0
  




 





 




  
0
  



  
0
  




0



 sub TRUE     { SQL::Yapp::ExprSpecial->obj('TRUE'); } 




6469



  
0
  




 





 




  
0
  



  
0
  




0



 sub FALSE    { SQL::Yapp::ExprSpecial->obj('FALSE'); } 




6470



  
0
  




 





 




  
0
  



  
0
  




0



 sub UNKNOWN  { SQL::Yapp::ExprSpecial->obj('UNKNOWN'); } 




6471



  
0
  




 





 




  
0
  



  
0
  




0



 sub DEFAULT  { SQL::Yapp::ExprSpecial->obj('DEFAULT'); } 




6472




 





 





 





 





 





 



   




6473




 





 





 





 





 





 



   




6474




 





 





 





 





 





 



 # Wrapped DBI methods: 




6475




 





 





 





 





 





 



 sub croak_no_ref($) 




6476




 





 





 





 





 





 



 { 




6477




1





 





 




  
1
  



  
0
  




2



     my ($self)= @_; 




6478




1





 





 





 





 





5



     croak "Error: Wrong type argument from interpolated code:\n". 




6479




 





 





 





 





 





 



         "\tExpected scalar, but found ".my_dumper($self); 




6480




 





 





 





 





 





 



 } 




6481




 





 





 





 





 





 



   




6482




 





 





 





 





 





 



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




6483




 





 





 





 





 





 



 # Generators: 




6484




 





 





 





 





 





 



   




6485




 





 





 





 





 





 



 # These functions are used to typecheck interpolated Perl code's 




6486




 





 





 





 





 





 



 # result values and to generate objects on the fly if that's possible. 




6487




 





 





 





 





 





 



 # Usually on-the-fly generation coerces basic Perl types to a blessed 




6488




 





 





 





 





 





 



 # object, but it would also be feasible to coerce objects to objects. 




6489




 





 





 





 





 





 



 # Some 'generator' functions don't generate at all, but simply type 




6490




 





 





 





 





 





 



 # check. 




6491




 





 





 





 





 





 



 # 




6492




 





 





 





 





 





 



 # Note: often these functions are invoked in string context, which 




6493




 





 





 





 





 





 



 # means that directly after their invocation, the string cast operator 




6494




 





 





 





 





 





 



 # is invoked.  However, there's no easy way to prevent object creation 




6495




 





 





 





 





 





 



 # in that case, because there is no such thing as 'wantstring' 




6496




 





 





 





 





 





 



 # (would-be analog to 'wantarray').  So these functions must always 




6497




 





 





 





 





 





 



 # return a blessed reference. 




6498




 





 





 





 





 





 



   




6499




 





 





 





 





 





 



 sub _functor($$@) 




6500




 





 





 





 





 





 



 { 




6501




106





 





 




  
106
  




 





171



     my ($functor, $parens, @arg)= @_; 




6502




 





 





 





 





 





 



   




6503




 





 





 





 





 





 



     # possibly translate the functor to a different SQL dialect: 




6504




106




  
100
  




 





 





 





206



     if (my $dialect= $functor->{dialect}) { 




6505




97




  
100
  




 





 





 





157



         if (my $f2= find_ref(%$dialect, $write_dialect)) { 




6506




28





 





 





 





 





35



             $functor= $f2; 




6507




 





 





 





 





 





 



         } 




6508




 





 





 





 





 





 



     } 




6509




 





 





 





 





 





 



   




6510




 





 





 





 





 





 



     # print it: 




6511




106





 





 





 





 





174



     my $name= $functor->{value}; 




6512




 





 





 





 





 





 



   




6513




 





 





 





 





 





 



     # prefix and suffix are not handled here, because they behave 




6514




 





 





 





 





 





 



     # differently: they assume exactly one argument are applied 




6515




 





 





 





 





 





 



     # point-wise.  They cannot be switched (ok, we might switch 




6516




 





 





 





 





 





 



     # between prefix and suffix, but that's not supported yet). 




6517




 





 





 





 





 





 



     my $s= switch ($functor->{type}, 




6518




 





 





 





 





 





 



         'infix()' => sub { 




6519




 





 





 





 





 





 



             (scalar(@arg) ? 




6520




 





 





 





 





 





 



                join(" $name ", @arg) 




6521




 





 





 





 





 





 



             : defined($functor->{result0}) ? 




6522




 





 





 





 





 





 



                get_quote_val->($functor->{result0}) 




6523




52




  
 50
  




 




  
52
  




 





190



             :  die "Error: Functor $functor->{value} used with 0 args, but requires at least one." 




 




 




  
100
  




 





 





 





 



   




6524




 





 





 





 





 





 



             ); 




6525




 





 





 





 





 





 



         }, 




6526




 





 





 





 





 





 



         'funcall' => sub { 




6527




21





 





 




  
21
  




 





24



             $parens= 0; 




6528




21





 





 





 





 





69



             "$name(".join(", ", @arg).")"; 




6529




 





 





 





 





 





 



         }, 




6530




 





 





 





 





 





 



         'prefix' => sub { 




6531




26




  
100
  




 




  
26
  




 





47



             die "Error: Exactly one argument expected for operator $functor->{value},\n". 




6532




 





 





 





 





 





 



                 "\tfound (".join(",", @arg).")" 




6533




 





 





 





 





 





 



                 unless scalar(@arg) == 1; 




6534




25





 





 





 





 





51



             "$name $arg[0]" 




6535




 





 





 





 





 





 



         }, 




6536




 





 





 





 





 





 



         'suffix' => sub { 




6537




7




  
 50
  




 




  
7
  




 





18



             die "Error: exactly one argument expected, found @arg" unless scalar(@arg) == 1; 




6538




7





 





 





 





 





14



             "$arg[0] $name" 




6539




 





 





 





 





 





 



         }, 




6540




106





 





 





 





 





595



     ); 




6541




105




  
100
  




 





 





 





851



     return $parens ? "($s)" : $s; 




6542




 





 





 





 





 





 



 } 




6543




 





 





 





 





 





 



   




6544




 





 





 





 





 





 



 sub _prefix($$@) 




6545




 





 





 





 





 





 



 { 




6546




67





 





 




  
67
  




 





182



     my ($name, $parens)= splice @_,0,2; 




6547




67





 




  
100
  




 





 





186



     return _functor($functor_prefix{$name} || { value => $name, type => 'funcall' } , $parens, @_); 




6548




 





 





 





 





 





 



 } 




6549




 





 





 





 





 





 



   




6550




 





 





 





 





 





 



 sub _suffix($$@) 




6551




 





 





 





 





 





 



 { 




6552




39





 





 




  
39
  




 





333



     my ($name, $parens)= splice @_,0,2; 




6553




39





 





 





 





 





89



     return _functor($functor_suffix{$name}, $parens, @_); 




6554




 





 





 





 





 





 



 } 




6555




 





 





 





 





 





 



   




6556




 





 





 





 





 





 



 sub _max1_if_scalar(@) 




6557




 





 





 





 





 





 



 { 




6558




 





 





 





 





 





 



     # void context: 




6559




219




  
100
  




 




  
219
  




 





416



     unless (defined wantarray) { 




6560




1




  
 50
  




 





 





 





5



         return if scalar(@_) == 0; # allow void context with no params (e.g. after Do) 




6561




1





 





 





 





 





173



         croak 'Error: NYI: void context is currently not supported for SQL blocks.'; 




6562




 





 





 





 





 





 



     } 




6563




 





 





 





 





 





 



   




6564




 





 





 





 





 





 



     # list context: 




6565




218




  
100
  




 





 





 





344



     return @_ if wantarray; 




6566




 





 





 





 





 





 



   




6567




 





 





 





 





 





 



     # scalar context: 




6568




191




  
100
  




 





 





 





444



     croak 'Error: Multiple results cannot be assigned to scalar' 




6569




 





 





 





 





 





 



         if scalar(@_) > 1; 




6570




190





 





 





 





 





488



     return $_[0]; 




6571




 





 





 





 





 





 



 } 




6572




 





 





 





 





 





 



   




6573




 





 





 





 





 





 



 sub min1(@) 




6574




 





 





 





 





 





 



 { 




6575



  
0
  



  
  0
  




 




  
0
  



  
0
  




0



     croak 'Error: Expected at least one element, but found an empty list' 




6576




 





 





 





 





 





 



         if scalar(@_) == 0; 




6577



  
0
  




 





 





 





 





0



     return @_; 




6578




 





 





 





 





 





 



 } 




6579




 





 





 





 





 





 



   




6580




 





 





 





 





 





 



 sub min1default($@) 




6581




 





 





 





 





 





 



 { 




6582



  
0
  



  
  0
  




 




  
0
  



  
0
  




0



     return @_ if scalar(@_) == 1; 




6583



  
0
  




 





 





 





 





0



     shift; 




6584



  
0
  




 





 





 





 





0



     return @_; 




6585




 





 





 





 





 





 



 } 




6586




 





 





 





 





 





 



   




6587




 





 





 





 





 





 



 sub joinlist($$$$$@) 




6588




 





 





 





 





 





 



 { 




6589




213




  
100
  




 




  
213
  



  
0
  




374



     if (scalar(@_) == 5) { 




6590




1




  
 50
  




 





 





 





7



         return $_[1] if defined $_[1]; 




6591



  
0
  




 





 





 





 





0



         my ($module, $file, $line)= caller; 




6592



  
0
  




 





 





 





 





0



         croak "$file:$_[0]: Error: Expected at least one element, but found an empty list"; 




6593




 





 





 





 





 





 



     } 




6594




212





 





 





 





 





667



     return $_[2].join ($_[3], @_[5..$#_]).$_[4]; 




6595




 





 





 





 





 





 



 } 




6596




 





 





 





 





 





 



   




6597




 





 





 





 





 





 



 sub assign($) # check that the result is an assignment, i.e.:`a` =  




6598




 





 





 





 





 





 



 { 




6599




14





 





 




  
14
  



  
0
  




17



     my ($x)= @_; 




6600




14




  
 50
  




 





 





 





21



     if (ref($x)) { 




6601




14





 





 





 





 





21



         return $x->assign(); 




6602




 





 





 





 





 





 



     } 




6603




 





 





 





 





 





 



     else { 




6604



  
0
  




 





 





 





 





0



         croak "Assignment expected, but found non-reference."; 




6605




 





 





 





 





 





 



     } 




6606




 





 





 





 





 





 



 } 




6607




 





 





 





 





 





 



   




6608




 





 





 





 





 





 



 sub set2values(@) 




6609




 





 





 





 





 





 



 { 




6610




7




  
 50
  




 




  
7
  



  
0
  




18



     croak "At least one value expected" if scalar(@_) == 0; 




6611




 





 





 





 





 





 



     return 




6612




 





 





 





 





 





 



         ' ('. 




6613




14





 





 





 





 





22



         join(',', map { assign($_)->arg1() } @_). 




6614




 





 





 





 





 





 



         ') VALUES ('. 




6615




7





 





 





 





 





11



         join(',', map { $_->arg2() } @_). 




 




14





 





 





 





 





20



   




6616




 





 





 





 





 





 



         ')'; 




6617




 





 





 





 





 





 



 } 




6618




 





 





 





 





 





 



   




6619




 





 





 





 





 





 



 sub exprlist($) 




6620




 





 





 





 





 





 



 { 




6621




7





 





 




  
7
  



  
0
  




25



     my ($x)= @_; 




6622




7




  
 50
  




 





 





 





20



     croak "Array reference expected for expression list" 




6623




 





 





 





 





 





 



        unless ref($x) eq 'ARRAY'; 




6624




7




  
 50
  




 





 





 





21



     croak "At least one element expected in expression list" 




6625




 





 





 





 





 





 



        unless scalar(@$x) >= 1; 




6626




7





 





 





 





 





16



     return '('.join(', ', map { expr($_) } @$x).')'; 




 




14





 





 





 





 





31



   




6627




 





 





 





 





 





 



 } 




6628




 





 





 





 





 





 



   




6629




 





 





 





 





 





 



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




6630




 





 





 





 





 





 



 # Type 




6631




 





 





 





 





 





 



   




6632




 





 





 





 





 





 



 sub type($) 




6633




 





 





 





 





 





 



 { 




6634




7





 





 




  
7
  



  
0
  




1279



     my ($x)= @_; 




6635




7




  
 50
  




 





 





 





16



     if (ref($x)) { 




6636




7





 





 





 





 





14



         return $x->type(); 




6637




 





 





 





 





 





 



     } 




6638




 





 





 





 





 





 



     else { 




6639



  
0
  




 





 





 





 





0



         croak "Type expected, but found non-reference (user types are not supported yet)."; 




6640




 





 





 





 





 





 



     } 




6641




 





 





 





 





 





 



 } 




6642




 





 





 





 





 





 



   




6643




 





 





 





 





 





 



 # These have $self at the end because it's easier to generate code like that. 




6644




 





 





 





 





 





 



 sub type_base($$) 




6645




 





 





 





 





 





 



 { 




6646




11





 





 




  
11
  



  
0
  




38



     my $self= pop @_; 




6647




11





 





 





 





 





35



     my ($base)= @_; 




6648




11




  
 50
  




 





 





 





27



     croak "Unrecognised base type '$base'" unless 




6649




 





 





 





 





 





 



         my $spec= find_ref(%type_spec, $base); 




6650




11




  
 50
  




 





 





 





31



     die unless $self; 




6651




11





 





 





 





 





27



     return $self->set_base($base, $spec); 




6652




 





 





 





 





 





 



 } 




6653




 





 





 





 





 





 



   




6654




 





 





 





 





 





 



 sub type_basewlist($@) 




6655




 





 





 





 





 





 



 { 




6656



  
0
  




 





 




  
0
  



  
0
  




0



     my $self= pop @_; 




6657



  
0
  




 





 





 





 





0



     my ($base, @value)= @_; 




6658



  
0
  



  
  0
  




 





 





 





0



     croak "Unrecognised base type '$base'" unless 




6659




 





 





 





 





 





 



         my $spec= find_ref(%type_spec, $base); 




6660



  
0
  



  
  0
  




 





 





 





0



     die unless $self; 




6661



  
0
  




 





 





 





 





0



     $self->set_base($base, $spec); 




6662



  
0
  




 





 





 





 





0



     $self->set_property('value_list', \@value); 




6663



  
0
  




 





 





 





 





0



     return $self; 




6664




 





 





 





 





 





 



 } 




6665




 





 





 





 





 





 



   




6666




 





 





 





 





 





 



 sub type_length($$;$) 




6667




 





 





 





 





 





 



 { 




6668




11





 





 




  
11
  



  
0
  




18



     my $self= pop @_; 




6669




11





 





 





 





 





17



     my ($prec1, $prec2)= @_; 




6670




11





 





 





 





 





27



     $self->set_property('prec1', $prec1); 




6671




11




  
 50
  




 





 





 





22



     $self->set_property('prec2', $prec2) if defined $prec2; 




6672




11





 





 





 





 





44



     return $self; 




6673




 





 





 





 





 





 



 } 




6674




 





 





 





 





 





 



   




6675




 





 





 





 





 





 



 sub type_largelength($$$;$) 




6676




 





 





 





 





 





 



 { 




6677



  
0
  




 





 




  
0
  



  
0
  




0



     my $self= pop @_; 




6678



  
0
  




 





 





 





 





0



     my ($coeff, $mul, $unit)= @_; 




6679



  
0
  




 





 





 





 





0



     $self->set_property('prec1',      $coeff); 




6680



  
0
  



  
  0
  




 





 





 





0



     $self->set_property('prec_mul',   $mul)  if defined $mul; 




6681



  
0
  



  
  0
  




 





 





 





0



     $self->set_property('prec_unit',  $unit) if defined $unit; 




6682



  
0
  




 





 





 





 





0



     return $self; 




6683




 





 





 





 





 





 



 } 




6684




 





 





 





 





 





 



   




6685




 





 





 





 





 





 



 sub type_property($$$) 




6686




 





 





 





 





 





 



 { 




6687




2





 





 




  
2
  



  
0
  




5



     my $self= pop @_; 




6688




2





 





 





 





 





3



     my ($key,$value)= @_; 




6689




2





 





 





 





 





6



     $self->set_property($key,$value); 




6690




2





 





 





 





 





6



     return $self; 




6691




 





 





 





 





 





 



 } 




6692




 





 





 





 





 





 



   




6693




 





 





 





 





 





 



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




6694




 





 





 





 





 





 



 # ColumnSpec 




6695




 





 





 





 





 





 



   




6696




 





 





 





 





 





 



 sub colspec($) 




6697




 





 





 





 





 





 



 { 




6698




2





 





 




  
2
  



  
0
  




239



     my ($x)= @_; 




6699




2




  
 50
  




 





 





 





6



     if (ref($x)) { 




6700




2





 





 





 





 





5



         return $x->colspec(); 




6701




 





 





 





 





 





 



     } 




6702




 





 





 





 





 





 



     else { 




6703



  
0
  




 





 





 





 





0



         croak "ColumnSpec expected, but found non-reference (user types are not supported yet)."; 




6704




 





 





 





 





 





 



     } 




6705




 





 





 





 





 





 



 } 




6706




 





 





 





 





 





 



   




6707




 





 





 





 





 





 



 sub colspec_property($$$$) 




6708




 





 





 





 





 





 



 { 




6709




4





 





 




  
4
  



  
0
  




29



     my $self= pop @_; 




6710




4





 





 





 





 





12



     my ($name, $key, $value)= @_; 




6711




4





 





 





 





 





12



     $self->{name}{$key}=   $name; 




6712




4





 





 





 





 





9



     $self->{option}{$key}= $value; 




6713




4





 





 





 





 





26



     return $self; 




6714




 





 





 





 





 





 



 } 




6715




 





 





 





 





 





 



   




6716




 





 





 





 





 





 



 sub colspec_type_base($$) 




6717




 





 





 





 





 





 



 { 




6718



  
0
  




 





 




  
0
  



  
0
  




0



     my $self= pop @_; 




6719



  
0
  




 





 





 





 





0



     my ($base)= @_; 




6720



  
0
  




 





 





 





 





0



     type_base($base, $self->{datatype}); 




6721



  
0
  




 





 





 





 





0



     return $self; 




6722




 





 





 





 





 





 



 } 




6723




 





 





 





 





 





 



   




6724




 





 





 





 





 





 



 sub colspec_type_property($$$) 




6725




 





 





 





 





 





 



 { 




6726



  
0
  




 





 




  
0
  



  
0
  




0



     my $self= pop @_; 




6727



  
0
  




 





 





 





 





0



     my ($key, $value)= @_; 




6728



  
0
  




 





 





 





 





0



     type_property($key, $value, $self->{datatype}); 




6729



  
0
  




 





 





 





 





0



     return $self; 




6730




 





 





 





 





 





 



 } 




6731




 





 





 





 





 





 



   




6732




 





 





 





 





 





 



 sub colspec_type_basewlist($@) 




6733




 





 





 





 





 





 



 { 




6734



  
0
  




 





 




  
0
  



  
0
  




0



     my $self= pop @_; 




6735



  
0
  




 





 





 





 





0



     my ($base, @value)= @_; 




6736



  
0
  




 





 





 





 





0



     type_basewlist($base, @value, $self->{datatype}); 




6737



  
0
  




 





 





 





 





0



     return $self; 




6738




 





 





 





 





 





 



 } 




6739




 





 





 





 





 





 



   




6740




 





 





 





 





 





 



 sub colspec_type_length($$;$) 




6741




 





 





 





 





 





 



 { 




6742



  
0
  




 





 




  
0
  



  
0
  




0



     my $self= pop @_; 




6743



  
0
  




 





 





 





 





0



     my ($prec1, $prec2)= @_; 




6744



  
0
  




 





 





 





 





0



     type_length($prec1, $prec2, $self->{datatype}); 




6745



  
0
  




 





 





 





 





0



     return $self; 




6746




 





 





 





 





 





 



 } 




6747




 





 





 





 





 





 



   




6748




 





 





 





 





 





 



 sub colspec_type_largelength($$$;$) 




6749




 





 





 





 





 





 



 { 




6750



  
0
  




 





 




  
0
  



  
0
  




0



     my $self= pop @_; 




6751



  
0
  




 





 





 





 





0



     my ($coeff, $mul, $unit)= @_; 




6752



  
0
  




 





 





 





 





0



     type_largelength($coeff, $mul, $unit, $self->{datatype}); 




6753



  
0
  




 





 





 





 





0



     return $self; 




6754




 





 





 





 





 





 



 } 




6755




 





 





 





 





 





 



   




6756




 





 





 





 





 





 



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




6757




 





 





 





 





 





 



 # identifier interpolation, column and table: 




6758




 





 





 





 





 





 



   




6759




 





 





 





 





 





 



 sub tabname($) 




6760




 





 





 





 





 





 



 { 




6761




1





 





 




  
1
  



  
0
  




4



     my ($x)= @_; 




6762




1




  
 50
  




 





 





 





4



     if (ref($x)) { 




 




 




  
 50
  




 





 





 





 



   




6763



  
0
  




 





 





 





 





0



         return $x->tabname; 




6764




 





 





 





 





 





 



     } 




6765




 





 





 





 





 





 



     elsif (defined $x) { 




6766




1





 





 





 





 





3



         return SQL::Yapp::TableName->obj(get_quote_id->($xlat_table->($x))); 




6767




 





 





 





 





 





 



     } 




6768




 





 





 





 





 





 



     else { 




6769



  
0
  




 





 





 





 





0



         croak "Error: Cannot use undef/NULL as a table name"; 




6770




 





 





 





 





 





 



     } 




6771




 





 





 





 





 





 



 } 




6772




 





 





 





 





 





 



   




6773




 





 





 





 





 





 



 # Schema-qualified names: 




6774




 





 





 





 





 





 



 sub schemaname1($$$) 




6775




 





 





 





 





 





 



 { 




6776




122





 





 




  
122
  



  
0
  




167



     my ($class,$xlat,$x)= @_; 




6777




122




  
 50
  




 





 





 





153



     if (defined $x) { 




6778




122





 





 





 





 





194



         return $class->obj(get_quote_id->($xlat->($x))); 




6779




 





 





 





 





 





 



     } 




6780




 





 





 





 





 





 



     else { 




6781



  
0
  




 





 





 





 





0



         croak "Error: Cannot use undef/NULL as a table name"; 




6782




 





 





 





 





 





 



     } 




6783




 





 





 





 





 





 



 } 




6784




 





 





 





 





 





 



   




6785




 





 





 





 





 





 



 sub schemaname2($$$$) 




6786




 





 





 





 





 





 



 { 




6787




2





 





 




  
2
  



  
0
  




7



     my ($class,$xlat,$x,$y)= @_; 




6788




 





 





 





 





 





 



   




6789




2




  
100
  




 





 





 





10



     if (ref($x)) { croak_no_ref($x); } 




 




1





 





 





 





 





3



   




6790




1




  
 50
  




 





 





 





2



     if (ref($y)) { croak_no_ref($y); } 




 



  
0
  




 





 





 





 





0



   




6791




1




  
 50
  




 





 





 





3



     croak "Error: Cannot use undef/NULL as an identifier" 




6792




 





 





 





 





 





 



         unless defined $y; 




6793




 





 





 





 





 





 



   




6794




1




  
 50
  




 





 





 





6



     return $class->obj( 




6795




 





 





 





 





 





 



                get_quote_id->( 




6796




 





 





 





 





 





 



                    undef, 




6797




 





 





 





 





 





 



                    (defined $x ? $xlat_schema->($x) : undef), 




6798




 





 





 





 





 





 



                    $xlat->($y))); 




6799




 





 





 





 





 





 



 } 




6800




 





 





 





 





 





 



   




6801




 





 





 





 





 





 



 sub schemaname3($$$$$) 




6802




 





 





 





 





 





 



 { 




6803




3





 





 




  
3
  



  
0
  




7



     my ($class,$xlat,$x,$y,$z)= @_; 




6804




3




  
 50
  




 





 





 





8



     if (ref($x)) { croak_no_ref($x); } 




 



  
0
  




 





 





 





 





0



   




6805




3




  
 50
  




 





 





 





5



     if (ref($y)) { croak_no_ref($y); } 




 



  
0
  




 





 





 





 





0



   




6806




3




  
 50
  




 





 





 





5



     if (ref($z)) { croak_no_ref($z); } 




 



  
0
  




 





 





 





 





0



   




6807




3




  
 50
  




 





 





 





8



     croak "Error: Cannot use undef/NULL as an identifier" 




6808




 





 





 





 





 





 



         unless defined $z; 




6809




 





 





 





 





 





 



   




6810




3




  
 50
  




 





 





 





11



     return $class->obj( 




 




 




  
 50
  




 





 





 





 



   




6811




 





 





 





 





 





 



                get_quote_id->( 




6812




 





 





 





 





 





 



                    (defined $x ? $xlat_catalog->($x) : undef), 




6813




 





 





 





 





 





 



                    (defined $y ? $xlat_schema->($y)  : undef), 




6814




 





 





 





 





 





 



                    $xlat->($z))); 




6815




 





 





 





 





 





 



 } 




6816




 





 





 





 





 





 



   




6817




 





 





 





 





 





 



   




6818




 





 





 





 





 





 



 # Table: 




6819




 





 





 





 





 





 



 sub table1($) 




6820




 





 





 





 





 





 



 { 




6821




124





 





 




  
124
  



  
0
  




4052



     my ($x)= @_; 




6822




124




  
100
  




 





 





 





245



     return ref($x) ? $x->table1 : schemaname1('SQL::Yapp::Table', $xlat_table, $x); 




6823




 





 





 





 





 





 



 } 




6824




 





 





 





 





 





 



   




6825




 





 





 





 





 





 



 sub table2($$) 




6826




 





 





 





 





 





 



 { 




6827




2





 





 




  
2
  



  
0
  




551



     my ($x,$y)= @_; 




6828




2





 





 





 





 





6



     return schemaname2('SQL::Yapp::Table', $xlat_table, $x, $y); 




6829




 





 





 





 





 





 



 } 




6830




 





 





 





 





 





 



   




6831




 





 





 





 





 





 



 sub table3($$$) 




6832




 





 





 





 





 





 



 { 




6833




3





 





 




  
3
  



  
0
  




261



     my ($x,$y,$z)= @_; 




6834




3





 





 





 





 





7



     return schemaname3('SQL::Yapp::Table', $xlat_table, $x, $y, $z); 




6835




 





 





 





 





 





 



 } 




6836




 





 





 





 





 





 



   




6837




 





 





 





 





 





 



   




6838




 





 





 





 





 





 



 # Index: 




6839




 





 





 





 





 





 



 sub index1($) 




6840




 





 





 





 





 





 



 { 




6841



  
0
  




 





 




  
0
  



  
0
  




0



     my ($x)= @_; 




6842



  
0
  



  
  0
  




 





 





 





0



     return ref($x) ? $x->index1 : schemaname1('SQL::Yapp::Index', $xlat_index, $x); 




6843




 





 





 





 





 





 



 } 




6844




 





 





 





 





 





 



   




6845




 





 





 





 





 





 



 sub index2($$) 




6846




 





 





 





 





 





 



 { 




6847



  
0
  




 





 




  
0
  



  
0
  




0



     my ($x,$y)= @_; 




6848



  
0
  




 





 





 





 





0



     return schemaname2('SQL::Yapp::Index', $xlat_index, $x, $y); 




6849




 





 





 





 





 





 



 } 




6850




 





 





 





 





 





 



   




6851




 





 





 





 





 





 



 sub index3($$$) 




6852




 





 





 





 





 





 



 { 




6853



  
0
  




 





 




  
0
  



  
0
  




0



     my ($x,$y,$z)= @_; 




6854



  
0
  




 





 





 





 





0



     return schemaname3('SQL::Yapp::Index', $xlat_index, $x, $y, $z); 




6855




 





 





 





 





 





 



 } 




6856




 





 





 





 





 





 



   




6857




 





 





 





 





 





 



   




6858




 





 





 





 





 





 



 # CharSet: 




6859




 





 





 





 





 





 



 sub charset1($) 




6860




 





 





 





 





 





 



 { 




6861




2





 





 




  
2
  



  
0
  




7



     my ($x)= @_; 




6862




2




  
 50
  




 





 





 





9



     return ref($x) ? $x->charset1 : schemaname1('SQL::Yapp::CharSet', $xlat_charset, $x); 




6863




 





 





 





 





 





 



 } 




6864




 





 





 





 





 





 



   




6865




 





 





 





 





 





 



 sub charset2($$) 




6866




 





 





 





 





 





 



 { 




6867



  
0
  




 





 




  
0
  



  
0
  




0



     my ($x,$y)= @_; 




6868



  
0
  




 





 





 





 





0



     return schemaname2('SQL::Yapp::CharSet', $xlat_charset, $x, $y); 




6869




 





 





 





 





 





 



 } 




6870




 





 





 





 





 





 



   




6871




 





 





 





 





 





 



 sub charset3($$$) 




6872




 





 





 





 





 





 



 { 




6873



  
0
  




 





 




  
0
  



  
0
  




0



     my ($x,$y,$z)= @_; 




6874



  
0
  




 





 





 





 





0



     return schemaname3('SQL::Yapp::CharSet', $xlat_charset, $x, $y, $z); 




6875




 





 





 





 





 





 



 } 




6876




 





 





 





 





 





 



   




6877




 





 





 





 





 





 



   




6878




 





 





 





 





 





 



 # Collate: 




6879




 





 





 





 





 





 



 sub collate1($) 




6880




 





 





 





 





 





 



 { 




6881



  
0
  




 





 




  
0
  



  
0
  




0



     my ($x)= @_; 




6882



  
0
  



  
  0
  




 





 





 





0



     return ref($x) ? $x->collate1 : schemaname1('SQL::Yapp::Collate', $xlat_collate, $x); 




6883




 





 





 





 





 





 



 } 




6884




 





 





 





 





 





 



   




6885




 





 





 





 





 





 



 sub collate2($$) 




6886




 





 





 





 





 





 



 { 




6887



  
0
  




 





 




  
0
  



  
0
  




0



     my ($x,$y)= @_; 




6888



  
0
  




 





 





 





 





0



     return schemaname2('SQL::Yapp::Collate', $xlat_collate, $x, $y); 




6889




 





 





 





 





 





 



 } 




6890




 





 





 





 





 





 



   




6891




 





 





 





 





 





 



 sub collate3($$$) 




6892




 





 





 





 





 





 



 { 




6893



  
0
  




 





 




  
0
  



  
0
  




0



     my ($x,$y,$z)= @_; 




6894



  
0
  




 





 





 





 





0



     return schemaname3('SQL::Yapp::Collate', $xlat_collate, $x, $y, $z); 




6895




 





 





 





 





 





 



 } 




6896




 





 





 





 





 





 



   




6897




 





 





 





 





 





 



   




6898




 





 





 





 





 





 



 # Constraint: 




6899




 





 





 





 





 





 



 sub constraint1($) 




6900




 





 





 





 





 





 



 { 




6901



  
0
  




 





 




  
0
  



  
0
  




0



     my ($x)= @_; 




6902



  
0
  



  
  0
  




 





 





 





0



     return ref($x) ? $x->constraint1 : schemaname1('SQL::Yapp::Constraint', $xlat_constraint, $x); 




6903




 





 





 





 





 





 



 } 




6904




 





 





 





 





 





 



   




6905




 





 





 





 





 





 



 sub constraint2($$) 




6906




 





 





 





 





 





 



 { 




6907



  
0
  




 





 




  
0
  



  
0
  




0



     my ($x,$y)= @_; 




6908



  
0
  




 





 





 





 





0



     return schemaname2('SQL::Yapp::Constraint', $xlat_constraint, $x, $y); 




6909




 





 





 





 





 





 



 } 




6910




 





 





 





 





 





 



   




6911




 





 





 





 





 





 



 sub constraint3($$$) 




6912




 





 





 





 





 





 



 { 




6913



  
0
  




 





 




  
0
  



  
0
  




0



     my ($x,$y,$z)= @_; 




6914



  
0
  




 





 





 





 





0



     return schemaname3('SQL::Yapp::Constraint', $xlat_constraint, $x, $y, $z); 




6915




 





 





 





 





 





 



 } 




6916




 





 





 





 





 





 



   




6917




 





 





 





 





 





 



   




6918




 





 





 





 





 





 



 # Transliteration: 




6919




 





 





 





 





 





 



 sub transliteration1($) 




6920




 





 





 





 





 





 



 { 




6921



  
0
  




 





 




  
0
  



  
0
  




0



     my ($x)= @_; 




6922



  
0
  



  
  0
  




 





 





 





0



     return ref($x) ? $x->transliteration1 : schemaname1('SQL::Yapp::Transliteration', $xlat_transliteration, $x); 




6923




 





 





 





 





 





 



 } 




6924




 





 





 





 





 





 



   




6925




 





 





 





 





 





 



 sub transliteration2($$) 




6926




 





 





 





 





 





 



 { 




6927



  
0
  




 





 




  
0
  



  
0
  




0



     my ($x,$y)= @_; 




6928



  
0
  




 





 





 





 





0



     return schemaname2('SQL::Yapp::Transliteration', $xlat_transliteration, $x, $y); 




6929




 





 





 





 





 





 



 } 




6930




 





 





 





 





 





 



   




6931




 





 





 





 





 





 



 sub transliteration3($$$) 




6932




 





 





 





 





 





 



 { 




6933



  
0
  




 





 




  
0
  



  
0
  




0



     my ($x,$y,$z)= @_; 




6934



  
0
  




 





 





 





 





0



     return schemaname3('SQL::Yapp::Transliteration', $xlat_transliteration, $x, $y, $z); 




6935




 





 





 





 





 





 



 } 




6936




 





 





 





 





 





 



   




6937




 





 





 





 





 





 



   




6938




 





 





 





 





 





 



 # Transcoding: 




6939




 





 





 





 





 





 



 sub transcoding1($) 




6940




 





 





 





 





 





 



 { 




6941



  
0
  




 





 




  
0
  



  
0
  




0



     my ($x)= @_; 




6942



  
0
  



  
  0
  




 





 





 





0



     return ref($x) ? $x->transcoding1 : schemaname1('SQL::Yapp::Transcoding', $xlat_transcoding, $x); 




6943




 





 





 





 





 





 



 } 




6944




 





 





 





 





 





 



   




6945




 





 





 





 





 





 



 sub transcoding2($$) 




6946




 





 





 





 





 





 



 { 




6947



  
0
  




 





 




  
0
  



  
0
  




0



     my ($x,$y)= @_; 




6948



  
0
  




 





 





 





 





0



     return schemaname2('SQL::Yapp::Transcoding', $xlat_transcoding, $x, $y); 




6949




 





 





 





 





 





 



 } 




6950




 





 





 





 





 





 



   




6951




 





 





 





 





 





 



 sub transcoding3($$$) 




6952




 





 





 





 





 





 



 { 




6953



  
0
  




 





 




  
0
  



  
0
  




0



     my ($x,$y,$z)= @_; 




6954



  
0
  




 





 





 





 





0



     return schemaname3('SQL::Yapp::Transcoding', $xlat_transcoding, $x, $y, $z); 




6955




 





 





 





 





 





 



 } 




6956




 





 





 





 





 





 



   




6957




 





 





 





 





 





 



   




6958




 





 





 





 





 





 



 # Engine: 




6959




 





 





 





 





 





 



 sub engine1($) 




6960




 





 





 





 





 





 



 { 




6961




1





 





 




  
1
  



  
0
  




239



     my ($x)= @_; 




6962




1




  
 50
  




 





 





 





7



     return ref($x) ? $x->engine1 : schemaname1('SQL::Yapp::Engine', $xlat_engine, $x); 




6963




 





 





 





 





 





 



 } 




6964




 





 





 





 





 





 



   




6965




 





 





 





 





 





 



 sub engine2($$) 




6966




 





 





 





 





 





 



 { 




6967



  
0
  




 





 




  
0
  



  
0
  




0



     my ($x,$y)= @_; 




6968



  
0
  




 





 





 





 





0



     return schemaname2('SQL::Yapp::Engine', $xlat_engine, $x, $y); 




6969




 





 





 





 





 





 



 } 




6970




 





 





 





 





 





 



   




6971




 





 





 





 





 





 



 sub engine3($$$) 




6972




 





 





 





 





 





 



 { 




6973



  
0
  




 





 




  
0
  



  
0
  




0



     my ($x,$y,$z)= @_; 




6974



  
0
  




 





 





 





 





0



     return schemaname3('SQL::Yapp::Engine', $xlat_engine, $x, $y, $z); 




6975




 





 





 





 





 





 



 } 




6976




 





 





 





 





 





 



   




6977




 





 





 





 





 





 



   




6978




 





 





 





 





 





 



 # Columns: 




6979




 





 





 





 





 





 



 sub colname($) 




6980




 





 





 





 





 





 



 { 




6981




10





 





 




  
10
  



  
0
  




25



     my ($x)= @_; 




6982




10




  
 50
  




 





 





 





30



     if (ref($x)) { 




 




 




  
 50
  




 





 





 





 



   




6983



  
0
  




 





 





 





 





0



         return $x->colname; 




6984




 





 





 





 





 





 



     } 




6985




 





 





 





 





 





 



     elsif (defined $x) { 




6986




10





 





 





 





 





21



         return SQL::Yapp::ColumnName->obj(get_quote_id->($xlat_column->($x))); 




6987




 





 





 





 





 





 



     } 




6988




 





 





 





 





 





 



     else { 




6989



  
0
  




 





 





 





 





0



         croak "Error: Cannot use undef/NULL as a column name"; 




6990




 





 





 





 





 





 



     } 




6991




 





 





 





 





 





 



 } 




6992




 





 





 





 





 





 



   




6993




 





 





 





 





 





 



 sub column1($) 




6994




 





 





 





 





 





 



 { 




6995




209





 





 




  
209
  



  
0
  




18078



     my ($x)= @_; 




6996




209




  
100
  




 





 





 





437



     if (ref($x)) { 




 




 




  
 50
  




 





 





 





 



   




6997




4





 





 





 





 





13



         return $x->column1; 




6998




 





 





 





 





 





 



     } 




6999




 





 





 





 





 





 



     elsif (defined $x) { 




7000




205





 





 





 





 





369



         return SQL::Yapp::Column->obj(get_quote_id->($xlat_column->($x))); 




7001




 





 





 





 





 





 



     } 




7002




 





 





 





 





 





 



     else { 




7003



  
0
  




 





 





 





 





0



         croak "Error: Cannot use undef/NULL as an identifier"; 




7004




 





 





 





 





 





 



     } 




7005




 





 





 





 





 





 



 } 




7006




 





 





 





 





 





 



   




7007




 





 





 





 





 





 



 sub column1_single($) #internal 




7008




 





 





 





 





 





 



 { 




7009




25





 





 




  
25
  



  
0
  




34



     my ($x)= @_; 




7010




25




  
100
  




 





 





 





44



     if (ref($x)) { 




 




 




  
 50
  




 





 





 





 



   




7011




1





 





 





 





 





8



         return $x->column1_single; 




7012




 





 





 





 





 





 



     } 




7013




 





 





 





 





 





 



     elsif (defined $x) { 




7014




24





 





 





 





 





35



         return get_quote_id->($xlat_column->($x)); 




7015




 





 





 





 





 





 



     } 




7016




 





 





 





 





 





 



     else { 




7017



  
0
  




 





 





 





 





0



         croak "Error: Cannot use undef/NULL as an identifier"; 




7018




 





 





 





 





 





 



     } 




7019




 





 





 





 





 





 



 } 




7020




 





 





 





 





 





 



   




7021




 





 





 





 





 





 



 sub column2($$) 




7022




 





 





 





 





 





 



 { 




7023




25





 





 




  
25
  



  
0
  




1748



     my ($x,$y)= @_; 




7024




25





 





 





 





 





33



     return SQL::Yapp::Column->obj(table1($x).'.'.column1_single($y)); 




7025




 





 





 





 





 





 



 } 




7026




 





 





 





 





 





 



   




7027




 





 





 





 





 





 



 sub column3($$$) 




7028




 





 





 





 





 





 



 { 




7029



  
0
  




 





 




  
0
  



  
0
  




0



     my ($x,$y,$z)= @_; 




7030



  
0
  




 





 





 





 





0



     return SQL::Yapp::Column->obj(table2($x,$y).'.'.column1_single($z)); 




7031




 





 





 





 





 





 



 } 




7032




 





 





 





 





 





 



   




7033




 





 





 





 





 





 



 sub column4($$$$) 




7034




 





 





 





 





 





 



 { 




7035



  
0
  




 





 




  
0
  



  
0
  




0



     my ($w,$x,$y,$z)= @_; 




7036



  
0
  




 





 





 





 





0



     return SQL::Yapp::Column->obj(table3($w,$x,$y).'.'.column1_single($z)); 




7037




 





 





 





 





 





 



 } 




7038




 





 





 





 





 





 



   




7039




 





 





 





 





 





 



 # Generated with mkidentn.pl: 




7040



  
0
  




 





 




  
0
  



  
0
  




0



 sub table1_n($)         { map { table1        ($_   )                       } @{ $_[0] }  } 




 



  
0
  




 





 





 





 





0



   




 



  
0
  




 





 





 





 





0



   




7041



  
0
  




 





 




  
0
  



  
0
  




0



 sub table2_1n($$)       { map { table2        ($_[0], $_   )                } @{ $_[1] }  } 




 



  
0
  




 





 





 





 





0



   




 



  
0
  




 





 





 





 





0



   




7042



  
0
  




 





 




  
0
  



  
0
  




0



 sub table2_n1($$)       { map { table2        ($_   , $_[1])                } @{ $_[0] }  } 




 



  
0
  




 





 





 





 





0



   




 



  
0
  




 





 





 





 





0



   




7043



  
0
  




 





 




  
0
  



  
0
  




0



 sub table2_nn($$)       { map { table2_1n     ($_   , $_[1])                } @{ $_[0] }  } 




 



  
0
  




 





 





 





 





0



   




 



  
0
  




 





 





 





 





0



   




7044



  
0
  




 





 




  
0
  



  
0
  




0



 sub table3_11n($$$)     { map { table3        ($_[0], $_[1], $_   )         } @{ $_[2] }  } 




 



  
0
  




 





 





 





 





0



   




 



  
0
  




 





 





 





 





0



   




7045



  
0
  




 





 




  
0
  



  
0
  




0



 sub table3_1n1($$$)     { map { table3        ($_[0], $_   , $_[2])         } @{ $_[1] }  } 




 



  
0
  




 





 





 





 





0



   




 



  
0
  




 





 





 





 





0



   




7046



  
0
  




 





 




  
0
  



  
0
  




0



 sub table3_1nn($$$)     { map { table3_11n    ($_[0], $_   , $_[2])         } @{ $_[1] }  } 




 



  
0
  




 





 





 





 





0



   




 



  
0
  




 





 





 





 





0



   




7047



  
0
  




 





 




  
0
  



  
0
  




0



 sub table3_n11($$$)     { map { table3        ($_   , $_[1], $_[2])         } @{ $_[0] }  } 




 



  
0
  




 





 





 





 





0



   




 



  
0
  




 





 





 





 





0



   




7048



  
0
  




 





 




  
0
  



  
0
  




0



 sub table3_n1n($$$)     { map { table3_11n    ($_   , $_[1], $_[2])         } @{ $_[0] }  } 




 



  
0
  




 





 





 





 





0



   




 



  
0
  




 





 





 





 





0



   




7049



  
0
  




 





 




  
0
  



  
0
  




0



 sub table3_nn1($$$)     { map { table3_1n1    ($_   , $_[1], $_[2])         } @{ $_[0] }  } 




 



  
0
  




 





 





 





 





0



   




 



  
0
  




 





 





 





 





0



   




7050



  
0
  




 





 




  
0
  



  
0
  




0



 sub table3_nnn($$$)     { map { table3_1nn    ($_   , $_[1], $_[2])         } @{ $_[0] }  } 




 



  
0
  




 





 





 





 





0



   




 



  
0
  




 





 





 





 





0



   




7051




 





 





 





 





 





 



   




7052



  
0
  




 





 




  
0
  



  
0
  




0



 sub column1_n($)        { map { column1       ($_   )                       } @{ $_[0] }  } 




 



  
0
  




 





 





 





 





0



   




 



  
0
  




 





 





 





 





0



   




7053




4





 





 




  
4
  



  
0
  




5



 sub column2_1n($$)      { map { column2       ($_[0], $_   )                } @{ $_[1] }  } 




 




8





 





 





 





 





11



   




 




4





 





 





 





 





8



   




7054



  
0
  




 





 




  
0
  



  
0
  




0



 sub column2_n1($$)      { map { column2       ($_   , $_[1])                } @{ $_[0] }  } 




 



  
0
  




 





 





 





 





0



   




 



  
0
  




 





 





 





 





0



   




7055




2





 





 




  
2
  



  
0
  




504



 sub column2_nn($$)      { map { column2_1n    ($_   , $_[1])                } @{ $_[0] }  } 




 




4





 





 





 





 





11



   




 




2





 





 





 





 





8



   




7056



  
0
  




 





 




  
0
  



  
0
  




0



 sub column3_11n($$$)    { map { column3       ($_[0], $_[1], $_   )         } @{ $_[2] }  } 




 



  
0
  




 





 





 





 





0



   




 



  
0
  




 





 





 





 





0



   




7057



  
0
  




 





 




  
0
  



  
0
  




0



 sub column3_1n1($$$)    { map { column3       ($_[0], $_   , $_[2])         } @{ $_[1] }  } 




 



  
0
  




 





 





 





 





0



   




 



  
0
  




 





 





 





 





0



   




7058



  
0
  




 





 




  
0
  



  
0
  




0



 sub column3_1nn($$$)    { map { column3_11n   ($_[0], $_   , $_[2])         } @{ $_[1] }  } 




 



  
0
  




 





 





 





 





0



   




 



  
0
  




 





 





 





 





0



   




7059



  
0
  




 





 




  
0
  



  
0
  




0



 sub column3_n11($$$)    { map { column3       ($_   , $_[1], $_[2])         } @{ $_[0] }  } 




 



  
0
  




 





 





 





 





0



   




 



  
0
  




 





 





 





 





0



   




7060



  
0
  




 





 




  
0
  



  
0
  




0



 sub column3_n1n($$$)    { map { column3_11n   ($_   , $_[1], $_[2])         } @{ $_[0] }  } 




 



  
0
  




 





 





 





 





0



   




 



  
0
  




 





 





 





 





0



   




7061



  
0
  




 





 




  
0
  



  
0
  




0



 sub column3_nn1($$$)    { map { column3_1n1   ($_   , $_[1], $_[2])         } @{ $_[0] }  } 




 



  
0
  




 





 





 





 





0



   




 



  
0
  




 





 





 





 





0



   




7062



  
0
  




 





 




  
0
  



  
0
  




0



 sub column3_nnn($$$)    { map { column3_1nn   ($_   , $_[1], $_[2])         } @{ $_[0] }  } 




 



  
0
  




 





 





 





 





0



   




 



  
0
  




 





 





 





 





0



   




7063



  
0
  




 





 




  
0
  



  
0
  




0



 sub column4_111n($$$$)  { map { column4       ($_[0], $_[1], $_[2], $_   )  } @{ $_[3] }  } 




 



  
0
  




 





 





 





 





0



   




 



  
0
  




 





 





 





 





0



   




7064



  
0
  




 





 




  
0
  



  
0
  




0



 sub column4_11n1($$$$)  { map { column4       ($_[0], $_[1], $_   , $_[3])  } @{ $_[2] }  } 




 



  
0
  




 





 





 





 





0



   




 



  
0
  




 





 





 





 





0



   




7065



  
0
  




 





 




  
0
  



  
0
  




0



 sub column4_11nn($$$$)  { map { column4_111n  ($_[0], $_[1], $_   , $_[3])  } @{ $_[2] }  } 




 



  
0
  




 





 





 





 





0



   




 



  
0
  




 





 





 





 





0



   




7066



  
0
  




 





 




  
0
  



  
0
  




0



 sub column4_1n11($$$$)  { map { column4       ($_[0], $_   , $_[2], $_[3])  } @{ $_[1] }  } 




 



  
0
  




 





 





 





 





0



   




 



  
0
  




 





 





 





 





0



   




7067



  
0
  




 





 




  
0
  



  
0
  




0



 sub column4_1n1n($$$$)  { map { column4_111n  ($_[0], $_   , $_[2], $_[3])  } @{ $_[1] }  } 




 



  
0
  




 





 





 





 





0



   




 



  
0
  




 





 





 





 





0



   




7068



  
0
  




 





 




  
0
  



  
0
  




0



 sub column4_1nn1($$$$)  { map { column4_11n1  ($_[0], $_   , $_[2], $_[3])  } @{ $_[1] }  } 




 



  
0
  




 





 





 





 





0



   




 



  
0
  




 





 





 





 





0



   




7069



  
0
  




 





 




  
0
  



  
0
  




0



 sub column4_1nnn($$$$)  { map { column4_11nn  ($_[0], $_   , $_[2], $_[3])  } @{ $_[1] }  } 




 



  
0
  




 





 





 





 





0



   




 



  
0
  




 





 





 





 





0



   




7070



  
0
  




 





 




  
0
  



  
0
  




0



 sub column4_n111($$$$)  { map { column4       ($_   , $_[1], $_[2], $_[3])  } @{ $_[0] }  } 




 



  
0
  




 





 





 





 





0



   




 



  
0
  




 





 





 





 





0



   




7071



  
0
  




 





 




  
0
  



  
0
  




0



 sub column4_n11n($$$$)  { map { column4_111n  ($_   , $_[1], $_[2], $_[3])  } @{ $_[0] }  } 




 



  
0
  




 





 





 





 





0



   




 



  
0
  




 





 





 





 





0



   




7072



  
0
  




 





 




  
0
  



  
0
  




0



 sub column4_n1n1($$$$)  { map { column4_11n1  ($_   , $_[1], $_[2], $_[3])  } @{ $_[0] }  } 




 



  
0
  




 





 





 





 





0



   




 



  
0
  




 





 





 





 





0



   




7073



  
0
  




 





 




  
0
  



  
0
  




0



 sub column4_n1nn($$$$)  { map { column4_11nn  ($_   , $_[1], $_[2], $_[3])  } @{ $_[0] }  } 




 



  
0
  




 





 





 





 





0



   




 



  
0
  




 





 





 





 





0



   




7074



  
0
  




 





 




  
0
  



  
0
  




0



 sub column4_nn11($$$$)  { map { column4_1n11  ($_   , $_[1], $_[2], $_[3])  } @{ $_[0] }  } 




 



  
0
  




 





 





 





 





0



   




 



  
0
  




 





 





 





 





0



   




7075



  
0
  




 





 




  
0
  



  
0
  




0



 sub column4_nn1n($$$$)  { map { column4_1n1n  ($_   , $_[1], $_[2], $_[3])  } @{ $_[0] }  } 




 



  
0
  




 





 





 





 





0



   




 



  
0
  




 





 





 





 





0



   




7076



  
0
  




 





 




  
0
  



  
0
  




0



 sub column4_nnn1($$$$)  { map { column4_1nn1  ($_   , $_[1], $_[2], $_[3])  } @{ $_[0] }  } 




 



  
0
  




 





 





 





 





0



   




 



  
0
  




 





 





 





 





0



   




7077



  
0
  




 





 




  
0
  



  
0
  




0



 sub column4_nnnn($$$$)  { map { column4_1nnn  ($_   , $_[1], $_[2], $_[3])  } @{ $_[0] }  } 




 



  
0
  




 





 





 





 





0



   




 



  
0
  




 





 





 





 





0



   




7078




 





 





 





 





 





 



   




7079




 





 





 





 





 





 



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




7080




 





 





 





 





 





 



 # stmt interpolation: 




7081




 





 





 





 





 





 



   




7082




 





 





 





 





 





 



 sub stmt($) 




7083




 





 





 





 





 





 



 { 




7084




3





 





 




  
3
  



  
0
  




15



     my ($x)= @_; 




7085




3




  
 50
  




 





 





 





6



     if (ref($x)) { 




7086




3





 





 





 





 





8



         return $x->stmt; 




7087




 





 





 





 





 





 



     } 




7088




 





 





 





 





 





 



     else { 




7089



  
0
  




 





 





 





 





0



         croak "Error: Expected 'Stmt' object, but found: ".my_dumper($x); 




7090




 





 





 





 





 





 



     } 




7091




 





 





 





 





 





 



 } 




7092




 





 





 





 





 





 



   




7093




 





 





 





 





 





 



 sub subquery($) 




7094




 





 





 





 





 





 



 { 




7095




1





 





 




  
1
  



  
0
  




2



     my ($x1)= @_; 




7096




1





 





 





 





 





5



     my $x= SQL::Yapp::Stmt->obj($x1); 




7097




1





 





 





 





 





6



     return $x->subquery; 




7098




 





 





 





 





 





 



 } 




7099




 





 





 





 





 





 



   




7100




 





 





 





 





 





 



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




7101




 





 





 





 





 





 



 # expr interpolation: 




7102




 





 





 





 





 





 



   




7103




 





 





 





 





 





 



 sub exprparen($) 




7104




 





 





 





 





 





 



 { 




7105




70





 





 




  
70
  



  
0
  




1297



     my ($x)= @_; 




7106




70




  
100
  




 





 





 





99



     if (ref($x)) { 




7107




5




  
 50
  




 





 





 





13



         die Dumper($x) if ref($x) eq 'HASH'; 




7108




5




  
 50
  




 





 





 





14



         die Dumper($x) if ref($x) eq 'ARRAY'; 




7109




5




  
 50
  




 





 





 





10



         die Dumper($x) if ref($x) eq 'CODE'; 




7110




5




  
 50
  




 





 





 





10



         die Dumper($x) if ref($x) eq 'SCALAR'; 




7111




5





 





 





 





 





17



         return $x->exprparen; 




7112




 





 





 





 





 





 



     } 




7113




 





 





 





 





 





 



     else { 




7114




65





 





 





 





 





90



         return SQL::Yapp::Expr->obj(get_quote_val->($x)); # raw perl scalar: quote as value, no parens 




7115




 





 





 





 





 





 



     } 




7116




 





 





 





 





 





 



 } 




7117




 





 





 





 





 





 



   




7118




 





 





 





 





 





 



 sub expr($) 




7119




 





 





 





 





 





 



 { 




7120




153





 





 




  
153
  



  
0
  




4932



     my ($x)= @_; 




7121




153




  
100
  




 





 





 





221



     if (ref($x)) { 




7122




21




  
 50
  




 





 





 





68



         confess 'Error: Trying to invoke $x->expr() on unblessed reference $x ". 




7123




 





 





 





 





 





 



                 "(maybe missing nested sqlExpr{...} inside a block, or ". 




7124




 





 





 





 





 





 



                 "additional () around {} interpolation?)' 




7125




 





 





 





 





 





 



             unless blessed($x); 




7126




21





 





 





 





 





58



         return $x->expr; 




7127




 





 





 





 





 





 



     } 




7128




 





 





 





 





 





 



     else { 




7129




132





 





 





 





 





203



         return SQL::Yapp::Expr->obj(get_quote_val->($x)); # raw perl scalar: quote as value 




7130




 





 





 





 





 





 



     } 




7131




 





 





 





 





 





 



 } 




7132




 





 





 





 





 





 



   




7133




 





 





 





 





 





 



 sub expr_or_check($) 




7134




 





 





 





 





 





 



 { 




7135




5





 





 




  
5
  



  
0
  




10



     my ($x)= @_; 




7136




5




  
100
  




 





 





 





14



     if (ref($x)) { 




7137




3





 





 





 





 





7



         return $x->expr_or_check; 




7138




 





 





 





 





 





 



     } 




7139




 





 





 





 





 





 



     else { 




7140




2





 





 





 





 





5



         return SQL::Yapp::Expr->obj(get_quote_val->($x)); # raw perl scalar: quote as value 




7141




 





 





 





 





 





 



     } 




7142




 





 





 





 





 





 



 } 




7143




 





 





 





 





 





 



   




7144




 





 





 





 





 





 



 sub exprparen_hash(\%) 




7145




 





 





 





 





 





 



 { 




7146




3





 





 




  
3
  



  
0
  




6



     my ($x)= @_; 




7147




 





 





 





 





 





 



     return map { 




7148




3





 





 





 





 





16



         my $n= $_; 




 




6





 





 





 





 





11



   




7149




6





 





 





 





 





11



         my $e= $x->{$n}; 




7150




6




  
100
  



  
 66
  




 





 





41



         (blessed($e) && $e->isa('SQL::Yapp::Check') ? 




7151




 





 





 





 





 





 



             '('.get_quote_id->($n).' '.$e->check.')' 




7152




 





 





 





 





 





 



         :   '('.get_quote_id->($n).' = '.exprparen($e).')' 




7153




 





 





 





 





 





 



         ) 




7154




 





 





 





 





 





 



     } 




7155




 





 





 





 





 





 



     sort keys %$x; 




7156




 





 





 





 





 





 



 } 




7157




 





 





 





 





 





 



   




7158




 





 





 





 





 





 



 sub expr_hash(\%) 




7159




 





 





 





 





 





 



 { 




7160




4





 





 




  
4
  



  
0
  




11



     my ($x)= @_; 




7161




 





 





 





 





 





 



     return map { 




7162




4





 





 





 





 





14



         my $n= $_; 




 




7





 





 





 





 





11



   




7163




7





 





 





 





 





11



         my $e= $x->{$n}; 




7164




7




  
 50
  



  
 33
  




 





 





24



         (blessed($e) && $e->isa('SQL::Yapp::Check') ? 




7165




 





 





 





 





 





 



             '('.get_quote_id->($n).' '.$e->check.')' 




7166




 





 





 





 





 





 



         :   SQL::Yapp::Infix->obj('=', get_quote_id->($n), exprparen($e)) 




7167




 





 





 





 





 





 



         ) 




7168




 





 





 





 





 





 



     } 




7169




 





 





 





 





 





 



     sort keys %$x; 




7170




 





 





 





 





 





 



 } 




7171




 





 





 





 





 





 



   




7172




 





 





 





 





 





 



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




7173




 





 





 





 





 





 



 # order interpolation: 




7174




 





 





 





 





 





 



   




7175




 





 





 





 





 





 



 sub asc($) 




7176




 





 





 





 





 





 



 { 




7177




9





 





 




  
9
  



  
0
  




275



     my ($x)= @_; 




7178




9




  
100
  




 





 





 





18



     if (ref($x)) { 




 




 




  
 50
  




 





 





 





 



   




7179




4





 





 





 





 





11



         return $x->asc; 




7180




 





 





 





 





 





 



     } 




7181




 





 





 





 





 





 



     elsif (defined $x) { 




7182




5





 





 





 





 





9



         return column1($x); 




7183




 





 





 





 





 





 



     } 




7184




 





 





 





 





 





 



     else { 




7185



  
0
  




 





 





 





 





0



         return NULL; 




7186




 





 





 





 





 





 



     } 




7187




 





 





 





 





 





 



 } 




7188




 





 





 





 





 





 



   




7189




 





 





 





 





 





 



 sub desc($) 




7190




 





 





 





 





 





 



 { 




7191




10





 





 




  
10
  



  
0
  




40



     my ($x)= @_; 




7192




10




  
100
  




 





 





 





21



     if (ref($x)) { 




 




 




  
 50
  




 





 





 





 



   




7193




6





 





 





 





 





13



         return $x->desc; 




7194




 





 





 





 





 





 



     } 




7195




 





 





 





 





 





 



     elsif (defined $x) { 




7196




4





 





 





 





 





5



         return SQL::Yapp::Desc->obj(column1($x)); 




7197




 





 





 





 





 





 



     } 




7198




 





 





 





 





 





 



     else { 




7199



  
0
  




 





 





 





 





0



         return NULL; 




7200




 





 





 





 





 





 



     } 




7201




 





 





 





 





 





 



 } 




7202




 





 





 





 





 





 



   




7203




 





 





 





 





 





 



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




7204




 





 





 





 





 





 



 # table option: 




7205




 





 





 





 





 





 



   




7206




 





 





 





 





 





 



 sub tableopt($) 




7207




 





 





 





 





 





 



 { 




7208




2





 





 




  
2
  



  
0
  




7



     my ($x)= @_; 




7209




2




  
 50
  




 





 





 





5



     if (ref($x)) { 




7210




2





 





 





 





 





4



         return $x->tableopt; 




7211




 





 





 





 





 





 



     } 




7212




 





 





 





 





 





 



     else { 




7213



  
0
  




 





 





 





 





0



         croak "Error: Expected 'TableOption' object, but found: ".my_dumper($x); 




7214




 





 





 





 





 





 



     } 




7215




 





 





 





 





 





 



 } 




7216




 





 





 





 





 





 



   




7217




 





 





 





 





 





 



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




7218




 





 





 





 





 





 



 # join interpolation: 




7219




 





 





 





 





 





 



   




7220




 





 





 





 





 





 



 sub joinclause($) 




7221




 





 





 





 





 





 



 { 




7222




4





 





 




  
4
  



  
0
  




9



     my ($x)= @_; 




7223




4




  
 50
  




 





 





 





8



     if (ref($x)) { 




7224




4





 





 





 





 





10



         return $x->joinclause; 




7225




 





 





 





 





 





 



     } 




7226




 





 





 





 





 





 



     else { 




7227



  
0
  




 





 





 





 





0



         croak "Error: Expected 'Join' object, but found: ".my_dumper($x); 




7228




 





 





 





 





 





 



     } 




7229




 





 





 





 





 





 



 } 




7230




 





 





 





 





 





 



   




7231




 





 





 





 





 





 



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




7232




 





 





 





 





 





 



 # limit interpolation: 




7233




 





 





 





 





 





 



   




7234




 





 





 





 





 





 



 sub limit_number($) 




7235




 





 





 





 





 





 



 { 




7236




14





 





 




  
14
  



  
0
  




56



     my ($x)= @_; 




7237




14




  
 50
  




 





 





 





47



     if (ref($x)) { 




 




 




  
 50
  




 





 





 





 



   




7238



  
0
  




 





 





 





 





0



         return $x->limit_number; 




7239




 





 





 





 





 





 



     } 




7240




 





 





 





 





 





 



     elsif (looks_like_number $x) { 




7241




14





 





 





 





 





43



         return $x; 




7242




 





 





 





 





 





 



     } 




7243




 





 





 





 





 





 



     else { 




7244



  
0
  




 





 





 





 





0



         croak "Error: Expected number or ?, but found: ".my_dumper($x); 




7245




 





 





 





 





 





 



     } 




7246




 





 





 





 





 





 



 } 




7247




 





 





 





 





 





 



   




7248




 





 





 





 





 





 



 sub limit($$) 




7249




 





 





 





 





 





 



 { 




7250




2





 





 




  
2
  



  
0
  




8



     my ($cnt, $offset)= @_; 




7251




 





 





 





 





 





 



   




7252




 





 





 





 





 





 



     # FIXME: if dialect is 'std' (or maybe 'std2008'), produce OFFSET/FETCH 




7253




 





 





 





 





 





 



     #        clause (SQL-2008). 




7254




2




  
100
  




 





 





 





6



     if (defined $cnt) { 




7255




1




  
 50
  




 





 





 





3



         if (defined $offset) { 




7256




1





 





 





 





 





3



             return " LIMIT ".limit_number($cnt)." OFFSET ".limit_number($offset); 




7257




 





 





 





 





 





 



         } 




7258




 





 





 





 





 





 



         else { 




7259



  
0
  




 





 





 





 





0



             return " LIMIT ".limit_number($cnt); 




7260




 





 





 





 





 





 



         } 




7261




 





 





 





 





 





 



     } 




7262




 





 





 





 





 





 



     else { 




7263




1




  
 50
  




 





 





 





4



         if (defined $offset) { 




7264




1




  
 50
  




 





 





 





3



             if ($write_dialect eq 'postgresql') { 




7265



  
0
  




 





 





 





 





0



                 return " LIMIT ALL OFFSET ".limit_number($offset); 




7266




 





 





 





 





 





 



             } 




7267




 





 





 





 





 





 



             else { 




7268




1





 





 





 





 





2



                 return " LIMIT ${\LARGE_LIMIT_CNT} OFFSET ".limit_number($offset); 




 




1





 





 





 





 





4



   




7269




 





 





 





 





 





 



             } 




7270




 





 





 





 





 





 



         } 




7271




 





 





 





 





 





 



         else { 




7272



  
0
  




 





 





 





 





0



             return ''; 




7273




 





 





 





 





 





 



         } 




7274




 





 





 





 





 





 



     } 




7275




 





 





 





 





 





 



 } 




7276




 





 





 





 





 





 



   




7277




 





 





 





 





 





 



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




7278




 





 





 





 





 





 



 # case: 




7279




 





 





 





 





 





 



   




7280




 





 





 





 





 





 



 sub whenthen($$) 




7281




 





 





 





 





 





 



 { 




7282




6





 





 




  
6
  



  
0
  




10



     my ($expr, $then)= @_; 




7283




6





 





 





 





 





50



     return 'WHEN '.$expr.' THEN '.$then; 




7284




 





 





 





 





 





 



 } 




7285




 





 





 





 





 





 



   




7286




 





 





 





 





 





 



 sub caseswitch($$@) 




7287




 





 





 





 





 





 



 { 




7288




 





 





 





 





 





 



    #my ($switchval, $default, @whenthen) 




7289




8




  
100
  




 




  
8
  



  
0
  




19



    if (scalar(@_) == 2) { # @whenthen is empty => always use default 




7290




2





 





 





 





 





7



        return $_[1];      # return default 




7291




 





 





 





 





 





 



    } 




7292




 





 





 





 





 





 



    return 




7293




6





 





 





 





 





45



       join(' ', 




7294




 





 





 





 





 





 



           'CASE', 




7295




 





 





 





 





 





 



           $_[0], 




7296




 





 





 





 





 





 



           @_[2..$#_],     # @whenthen 




7297




 





 





 





 





 





 



           'ELSE',         # always generate default, it's easier. 




7298




 





 





 





 





 





 



           $_[1], 




7299




 





 





 





 





 





 



           'END' 




7300




 





 





 





 





 





 



      ); 




7301




 





 





 





 





 





 



 } 




7302




 





 





 





 





 





 



   




7303




 





 





 





 





 





 



 sub casecond($@) 




7304




 





 





 





 





 





 



 { 




7305




 





 





 





 





 





 



    #my ($default, @whenthen) 




7306



  
0
  



  
  0
  




 




  
0
  



  
0
  




 



    if (scalar(@_) == 1) { # @whenthen is empty => always use default 




7307



  
0
  




 





 





 





 





 



        return $_[0];      # return default 




7308




 





 





 





 





 





 



    } 




7309




 





 





 





 





 





 



    return 




7310




0





 





 





 





 





 



       join(' ', 




7311




 





 





 





 





 





 



           'CASE', 




7312




 





 





 





 





 





 



           @_[1..$#_],     # @whenthen 




7313




 





 





 





 





 





 



           'ELSE',         # always generate default, it's easier. 




7314




 





 





 





 





 





 



           $_[0], 




7315




 





 





 





 





 





 



           'END' 




7316




 





 





 





 





 





 



      ); 




7317




 





 





 





 





 





 



 } 




7318




 





 





 





 





 





 



   




7319




 





 





 





 





 





 



 1; 




7320




 





 





 





 





 





 



   




7321




 





 





 





 





 





 



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




7322




 





 





 





 





 





 



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




7323




 





 





 





 





 





 



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




7324




 





 





 





 





 





 



   




7325




 





 





 





 





 





 



 __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}) {
                # Oracle does not allow AS in table aliases.  But this module
                # does not allow leaving it out.  To avoid generating what
                # this module cannot read back in the default case, check for
                # the write dialect.
                if ($write_dialect eq 'oracle') {
                    str_append_join  ($str, sep => ' ', never_empty => 1);
                }
                else {
                    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 table1($)        { $_[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__