File Coverage

blib/lib/SQL/Yapp.pm

Criterion	Covered	Total	%
statement	2374	2937	80.8
branch	710	1108	64.0
condition	146	293	49.8
subroutine	519	722	71.8
pod	0	298	0.0
total	3749	5358	69.9

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

        NOT => { NULL => {} },

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

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

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

my %type_spec= ();

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

    %type_spec= type_spec();
}

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

sub good_interpol_type($);

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

    skip_ws($lx);

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

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

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

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

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

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

        return $tok;
    }

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

    return $result;
}

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

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

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

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

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

    return $result;
}

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

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

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

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

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

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

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

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

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

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

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

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

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

    check_column(@$arr);

    $r->{ident_chain}= $arr;

    lock_keys %$r;
    return $r;
}

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

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

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

    $r->{ident_chain}= $arr;

    lock_keys %$r;
    return $r;
}

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

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

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

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

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

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

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

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


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

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

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

    lock_keys %$r;
    return $r;
}

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

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

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

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

    lock_hash %$r;
    return $r;
}

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

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

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

    lock_keys %$r;
    return $r;
}

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

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

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

    lock_hash %$r;
    return $r;
}

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

                     push @arg, lexer_shift($lx);

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

                         push @arg, $unit;
                     }
                },

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

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

                },

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

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

    return ($functor, \@arg);
}

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

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

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

    return parse_type_post ($lx, $r);
}

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

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

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

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

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

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

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

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

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

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

    lexer_shift($lx);

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

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

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

    lock_hash %$r;
    return $r;
}

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

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

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

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

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

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

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

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

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

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

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

    return ($functor, \@arg);
}

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

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

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

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

    return parse_column_spec_post ($lx, $r);
}

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

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

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

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

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

}

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

    my $cond;

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

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

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

    return [ $cond, $expr ];
}

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

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

    return [ $cond, $expr ];
}

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

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

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

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

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

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

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

    # otherwise: ambiguous
    return ACTION_AMBIGUOUS;
}

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

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

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

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

    return $functor;
}

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

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

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

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

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

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

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

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

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

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

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

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

    return $arg1;
}

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

    lock_hash %$r;
    return $r;
}

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

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

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

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

    lock_hash %$r;
    return $r;
}

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

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

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

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

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

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

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

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

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

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

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

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

    lock_hash %$r;
    return $r;
}

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

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

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

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

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

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




3269




 





 





 





 





 





 



     # 




3270




 





 





 





 





 





 



     # All: 




3271




 





 





 





 





 





 



     #     - UNION 




3272




 





 





 





 





 





 



     #     - INTERSECT 




3273




 





 





 





 





 





 



     #     - EXCEPT 




3274




 





 





 





 





 





 



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




3275




 





 





 





 





 





 



   




3276




180





 





 





 





 





277



     $r->{opt_front}= []; 




3277




 





 





 





 





 





 



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




3278




 





 





 





 





 





 



         'DISTINCT', 'ALL', 




3279




 





 





 





 





 





 



         ($read_dialect{mysql} ? 




3280




180




  
 50
  




 





 





 





555



             ('DISTINCTROW') 




3281




 





 





 





 





 





 



         :   () 




3282




 





 





 





 





 





 



         ) 




3283




 





 





 





 





 





 



     ]); 




3284




 





 





 





 





 





 



   




3285




 





 





 





 





 





 



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




3286




 





 





 





 





 





 



         ($read_dialect{mysql} ? 




3287




 





 





 





 





 





 



             ( 




3288




180




  
 50
  




 





 





 





585



                 'HIGH_PRIORITY', 'STRAIGHT_JOIN', 




3289




 





 





 





 





 





 



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




3290




 





 





 





 





 





 



                 'SQL_CACHE', 'SQL_NO_CACHE', 'SQL_CALC_FOUND_ROWS' 




3291




 





 





 





 





 





 



             ) 




3292




 





 





 





 





 





 



         :   () 




3293




 





 





 





 





 





 



         ) 




3294




 





 





 





 





 





 



     ]); 




3295




 





 





 





 





 





 



   




3296




 





 





 





 





 





 



     return unless 




3297




180




  
100
  




 





 





 





401



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




3298




 





 





 





 





 





 



   




3299




179




  
100
  




 





 





 





241



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




3300




 





 





 





 





 





 



         return unless 




3301




 





 





 





 





 





 



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




3302




94




  
 50
  



  
 33
  




 





 





189



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




3303




 





 





 





 





 





 



   




3304




94




  
100
  




 





 





 





156



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




3305




 





 





 





 





 





 



             return unless 




3306




44




  
 50
  




 





 





 





86



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




3307




 





 





 





 





 





 



         } 




3308




94




  
100
  




 





 





 





158



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




3309




 





 





 





 





 





 



             return unless 




3310




6




  
 50
  




 





 





 





18



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




3311




 





 





 





 





 





 



   




3312




6





 





 





 





 





10



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




3313




 





 





 





 





 





 



         } 




3314




94




  
100
  




 





 





 





120



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




3315




 





 





 





 





 





 



             return unless 




3316




1




  
 50
  




 





 





 





3



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




3317




 





 





 





 





 





 



         } 




3318




94




  
100
  




 





 





 





130



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




3319




 





 





 





 





 





 



             return unless 




3320




8




  
 50
  




 





 





 





21



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




3321




 





 





 





 





 





 



         } 




3322




 





 





 





 





 





 



   




3323




94




  
100
  




 





 





 





132



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




3324




4




  
 50
  




 





 





 





9



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




3325




4





 





 





 





 





12



                 my $first_num= parse_limit_num ($lx); 




3326




4




  
100
  




 





 





 





14



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




3327




2





 





 





 





 





3



                     $r->{limit_offset}= $first_num; 




3328




2





 





 





 





 





4



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




3329




 





 





 





 





 





 



                 } 




3330




 





 





 





 





 





 



                 else { 




3331




2





 





 





 





 





5



                     $r->{limit_cnt}= $first_num; 




3332




 





 





 





 





 





 



                 } 




3333




 





 





 





 





 





 



             } 




3334




 





 





 





 





 





 



         } 




3335




94




  
100
  



  
100
  




 





 





238



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




3336




 





 





 





 





 





 



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




3337




 





 





 





 





 





 



         { 




3338




1





 





 





 





 





3



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




3339




 





 





 





 





 





 



         } 




3340




 





 





 





 





 





 



   




3341




94





 





 





 





 





119



         $r->{opt_back}=  []; 




3342




 





 





 





 





 





 



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




3343




 





 





 





 





 





 



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




3344




 





 





 





 





 





 



                 ('FOR UPDATE') 




3345




 





 





 





 





 





 



             :   () 




3346




 





 





 





 





 





 



             ), 




3347




 





 





 





 





 





 



             ($read_dialect{mysql} ? 




3348




 





 





 





 





 





 



                 ( 




3349




 





 





 





 





 





 



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




3350




 





 





 





 





 





 



                 ) 




3351




 





 





 





 





 





 



             :   () 




3352




 





 





 





 





 





 



             ), 




3353




 





 





 





 





 





 



             ($read_dialect{postgresql} ? 




3354




 





 





 





 





 





 



                 ( 




3355




94




  
 50
  



  
 33
  




 





 





483



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




 




 




  
 50
  




 





 





 





 



   




 




 




  
 50
  




 





 





 





 



   




3356




 





 





 





 





 





 



                     'NOWAIT' 




3357




 





 





 





 





 





 



                 ) 




3358




 





 





 





 





 





 



             :   () 




3359




 





 





 





 





 





 



             ), 




3360




 





 





 





 





 





 



         ]); 




3361




 





 





 





 





 





 



     } 




3362




 





 





 





 





 





 



   




3363




179





 





 





 





 





386



     lock_hash %$r; 




3364




179





 





 





 





 





3631



     return $r; 




3365




 





 





 





 





 





 



 } 




3366




 





 





 





 





 





 



   




3367




 





 





 





 





 





 



 sub parse_insert($) 




3368




 





 





 





 





 





 



 { 




3369




13





 





 




  
13
  



  
0
  




17



     my ($lx)= @_; 




3370




13





 





 





 





 





41



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




3371




 





 





 





 





 





 



         qw( 




3372




 





 





 





 





 





 



             opt_front 




3373




 





 





 





 





 





 



             into 




3374




 





 





 





 





 





 



             column 




3375




 





 





 





 





 





 



             default_values 




3376




 





 





 





 





 





 



             value 




3377




 





 





 





 





 





 



             value_interpol 




3378




 





 





 





 





 





 



             set 




3379




 





 





 





 





 





 



             select 




3380




 





 





 





 





 





 



             duplicate_update 




3381




 





 





 





 





 





 



         ) 




3382




 





 





 





 





 





 



     ); 




3383




 





 





 





 





 





 



   




3384




13




  
 50
  




 





 





 





35



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




3385




 





 





 





 





 





 



   




3386




 





 





 





 





 





 



     # PostgreSQL: 




3387




 





 





 





 





 





 



     #    - RETURNING ... 




3388




 





 





 





 





 





 



   




3389




13





 





 





 





 





25



     $r->{opt_front}= []; 




3390




 





 





 





 





 





 



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




3391




 





 





 





 





 





 



         ($read_dialect{mysql} ? 




3392




 





 





 





 





 





 



             ( 




3393




13




  
 50
  




 





 





 





58



                 'IGNORE', 




3394




 





 





 





 





 





 



                 'LOW_PRIORITY', 




3395




 





 





 





 





 





 



                 'HIGH_PRIORITY', 




3396




 





 





 





 





 





 



                 'DELAYED', 




3397




 





 





 





 





 





 



             ) 




3398




 





 





 





 





 





 



         :   () 




3399




 





 





 





 





 





 



         ) 




3400




 





 





 





 





 





 



     ]); 




3401




 





 





 





 





 





 



   




3402




13





 





 





 





 





23



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




3403




 





 





 





 





 





 



   




3404




 





 





 





 





 





 



     return unless 




3405




13




  
 50
  




 





 





 





30



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




3406




 





 





 





 





 





 



   




3407




13




  
100
  




 





 





 





26



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




3408




 





 





 





 





 





 



         return unless 




3409




5




  
 50
  




 





 





 





16



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




3410




 





 





 





 





 





 



     } 




3411




 





 





 





 





 





 



   




3412




 





 





 





 





 





 



     parse_choice($lx, 




3413




 





 





 





 





 





 



         'DEFAULT VALUES' => sub { 




3414



  
0
  




 





 




  
0
  




 





0



             lexer_shift($lx); 




3415



  
0
  




 





 





 





 





0



             $r->{default_values}= 1; 




3416




 





 





 





 





 





 



         }, 




3417




 





 





 





 





 





 



   




3418




 





 





 





 





 





 



         'VALUE' => 'VALUES', 




3419




 





 





 





 





 





 



         'VALUES' => sub { 




3420




5





 





 




  
5
  




 





10



             lexer_shift($lx); 




3421




5





 





 





 





 





16



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




3422




 





 





 





 





 





 



         }, 




3423




 





 





 





 





 





 



   




3424




 





 





 





 





 





 



         'SET' => sub { 




3425




 





 





 





 





 





 



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




3426




 





 





 





 





 





 



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




3427




8




  
 50
  




 




  
8
  




 





17



             if ($r->{column}) { 




3428



  
0
  




 





 





 





 





0



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




3429



  
0
  




 





 





 





 





0



                 return; 




3430




 





 





 





 





 





 



             } 




3431




8





 





 





 





 





13



             lexer_shift($lx); 




3432




8





 





 





 





 





19



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




3433




 





 





 





 





 





 



         }, 




3434




 





 





 





 





 





 



   




3435




13





 





 





 





 





63



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




3436




 





 





 





 





 





 



         'interpol' => 'interpolStmt', 




3437




 





 





 





 





 





 



         'interpolStmt' => sub { 




3438



  
0
  




 





 




  
0
  




 





0



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




3439




 





 





 





 





 





 



         }, 




3440




13





 





 





 





 





65



     ); 




3441




13




  
 50
  




 





 





 





151



     return if $lx->{error}; 




3442




 





 





 





 





 





 



   




3443




13




  
100
  



  
 66
  




 





 





43



     if ($read_dialect{mysql} && 




3444




 





 





 





 





 





 



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




3445




 





 





 





 





 





 



     { 




3446




 





 





 





 





 





 



         return unless 




3447




1




  
 50
  




 





 





 





4



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




3448




 





 





 





 





 





 



     } 




3449




 





 





 





 





 





 



   




3450




13





 





 





 





 





38



     lock_hash %$r; 




3451




13





 





 





 





 





263



     return $r; 




3452




 





 





 





 





 





 



 } 




3453




 





 





 





 





 





 



   




3454




 





 





 





 





 





 



 sub parse_update($) 




3455




 





 





 





 





 





 



 { 




3456




9





 





 




  
9
  



  
0
  




9



     my ($lx)= @_; 




3457




9





 





 





 





 





28



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




3458




 





 





 





 





 





 



         qw( 




3459




 





 





 





 





 





 



             opt_front 




3460




 





 





 





 





 





 



             table 




3461




 





 





 





 





 





 



             set 




3462




 





 





 





 





 





 



             from 




3463




 





 





 





 





 





 



             join 




3464




 





 





 





 





 





 



             where 




3465




 





 





 





 





 





 



             order_by 




3466




 





 





 





 





 





 



             limit_cnt 




3467




 





 





 





 





 





 



             limit_offset 




3468




 





 





 





 





 





 



         ) 




3469




 





 





 





 





 





 



     ); 




3470




 





 





 





 





 





 



   




3471




9




  
 50
  




 





 





 





20



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




3472




 





 





 





 





 





 



   




3473




 





 





 





 





 





 



     # PostgreSQL: 




3474




 





 





 





 





 





 



     #    - RETURNING ... 




3475




 





 





 





 





 





 



   




3476




9





 





 





 





 





16



     $r->{opt_front}= []; 




3477




 





 





 





 





 





 



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




3478




 





 





 





 





 





 



         ($read_dialect{mysql} ? 




3479




 





 





 





 





 





 



             ( 




3480




 





 





 





 





 





 



                 'IGNORE', 




3481




 





 





 





 





 





 



                 'LOW_PRIORITY', 




3482




 





 





 





 





 





 



             ) 




3483




 





 





 





 





 





 



         :   () 




3484




 





 





 





 





 





 



         ), 




3485




 





 





 





 





 





 



         ($read_dialect{postgresql} ? 




3486




 





 





 





 





 





 



             ( 




3487




9




  
 50
  




 





 





 





40



                 'ONLY', 




 




 




  
 50
  




 





 





 





 



   




3488




 





 





 





 





 





 



             ) 




3489




 





 





 





 





 





 



         :   () 




3490




 





 





 





 





 





 



         ) 




3491




 





 





 





 





 





 



     ]); 




3492




 





 





 





 





 





 



   




3493




 





 





 





 





 





 



     return unless 




3494




 





 





 





 





 





 



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




3495




 





 





 





 





 





 



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




3496




9




  
 50
  



  
 33
  




 





 





25



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




 




 





 




  
 33
  




 





 





 



   




3497




 





 





 





 





 





 



   




3498




9




  
100
  




 





 





 





23



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




3499




 





 





 





 





 





 



         return unless 




3500




1




  
 50
  




 





 





 





3



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




3501




 





 





 





 





 





 



     } 




3502




 





 





 





 





 





 



     return unless 




3503




9




  
 50
  




 





 





 





22



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




3504




 





 





 





 





 





 



   




3505




9




  
 50
  




 





 





 





17



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




3506




 





 





 





 





 





 



         return unless 




3507




9




  
 50
  




 





 





 





16



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




3508




 





 





 





 





 





 



     } 




3509




9




  
100
  




 





 





 





18



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




3510




 





 





 





 





 





 



         return unless 




3511




1




  
 50
  




 





 





 





4



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




3512




 





 





 





 





 





 



     } 




3513




9




  
100
  




 





 





 





14



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




3514




1





 





 





 





 





3



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




3515




 





 





 





 





 





 



     } 




3516




 





 





 





 





 





 



   




3517




9





 





 





 





 





23



     lock_hash %$r; 




3518




9





 





 





 





 





167



     return $r; 




3519




 





 





 





 





 





 



 } 




3520




 





 





 





 





 





 



   




3521




 





 





 





 





 





 



 sub parse_delete($) 




3522




 





 





 





 





 





 



 { 




3523




4





 





 




  
4
  



  
0
  




5



     my ($lx)= @_; 




3524




4





 





 





 





 





17



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




3525




 





 





 





 





 





 



         qw( 




3526




 





 





 





 





 





 



             opt_front 




3527




 





 





 





 





 





 



             from 




3528




 





 





 





 





 





 



             from_opt_front 




3529




 





 





 





 





 





 



             join 




3530




 





 





 





 





 





 



             using 




3531




 





 





 





 





 





 



             where 




3532




 





 





 





 





 





 



             order_by 




3533




 





 





 





 





 





 



             limit_cnt 




3534




 





 





 





 





 





 



             limit_offset 




3535




 





 





 





 





 





 



         ) 




3536




 





 





 





 





 





 



     ); 




3537




 





 





 





 





 





 



   




3538




4




  
 50
  




 





 





 





11



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




3539




 





 





 





 





 





 



   




3540




 





 





 





 





 





 



     # PostgreSQL: 




3541




 





 





 





 





 





 



     #    - RETURNING ... 




3542




 





 





 





 





 





 



   




3543




4





 





 





 





 





10



     $r->{opt_front}= []; 




3544




 





 





 





 





 





 



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




3545




 





 





 





 





 





 



         ($read_dialect{mysql} ? 




3546




 





 





 





 





 





 



             ( 




3547




4




  
 50
  




 





 





 





19



                 'IGNORE', 




3548




 





 





 





 





 





 



                 'LOW_PRIORITY', 




3549




 





 





 





 





 





 



                 'QUICK' 




3550




 





 





 





 





 





 



             ) 




3551




 





 





 





 





 





 



         :   () 




3552




 





 





 





 





 





 



         ) 




3553




 





 





 





 





 





 



     ]); 




3554




 





 





 





 





 





 



   




3555




4




  
 50
  




 





 





 





11



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




3556




 





 





 





 





 





 



   




3557




4





 





 





 





 





8



     $r->{from_opt_front}= []; 




3558




 





 





 





 





 





 



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




3559




 





 





 





 





 





 



         ($read_dialect{postgresql} ? 




3560




4




  
 50
  




 





 





 





16



             ('ONLY') 




3561




 





 





 





 





 





 



         :   () 




3562




 





 





 





 





 





 



         ) 




3563




 





 





 





 





 





 



     ]); 




3564




 





 





 





 





 





 



   




3565




 





 





 





 





 





 



     return unless 




3566




4




  
 50
  




 





 





 





13



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




3567




 





 





 





 





 





 



   




3568




4




  
100
  




 





 





 





9



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




3569




 





 





 





 





 





 



         return unless 




3570




2




  
 50
  




 





 





 





7



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




3571




 





 





 





 





 





 



     } 




3572




 





 





 





 





 





 



   




3573




 





 





 





 





 





 



     return unless 




3574




4




  
 50
  




 





 





 





12



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




3575




 





 





 





 





 





 



   




3576




4




  
100
  




 





 





 





8



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




3577




 





 





 





 





 





 



         return unless 




3578




3




  
 50
  




 





 





 





7



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




3579




 





 





 





 





 





 



     } 




3580




4




  
 50
  




 





 





 





10



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




3581




 





 





 





 





 





 



         return unless 




3582



  
0
  



  
  0
  




 





 





 





0



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




3583




 





 





 





 





 





 



     } 




3584




4




  
 50
  




 





 





 





11



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




3585



  
0
  




 





 





 





 





0



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




3586




 





 





 





 





 





 



     } 




3587




 





 





 





 





 





 



   




3588




4





 





 





 





 





11



     lock_hash %$r; 




3589




4





 





 





 





 





74



     return $r; 




3590




 





 





 





 





 





 



 } 




3591




 





 





 





 





 





 



   




3592




 





 





 





 





 





 



 sub keyword($$) 




3593




 





 





 





 





 





 



 { 




3594




1





 





 




  
1
  



  
0
  




3



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




3595




 





 





 





 





 





 



     return 




3596




1




  
 50
  




 





 





 





4



         unless $keyword; 




3597




 





 





 





 





 





 



   




3598




1




  
 50
  




 





 





 





3



     return $keyword 




3599




 





 





 





 





 





 



         if ref($keyword); 




3600




 





 





 





 





 





 



          




3601




1





 





 





 





 





1



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




3602




1





 





 





 





 





2



     $r->{keyword}= $keyword; 




3603




1





 





 





 





 





3



     lock_hash %$r; 




3604




1





 





 





 





 





11



     return $r; 




3605




 





 





 





 





 





 



 } 




3606




 





 





 





 





 





 



   




3607




 





 





 





 





 





 



 sub parse_index_option($) 




3608




 





 





 





 





 





 



 { 




3609




1





 





 




  
1
  



  
0
  




1



     my ($lx)= @_; 




3610




1





 





 





 





 





3



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




3611




 





 





 





 





 





 



   




3612




 





 





 





 





 





 



     parse_choice($lx, 




3613




 





 





 





 





 





 



         -default => sub { 




3614




1





 





 




  
1
  




 





2



             $r= undef; 




3615




 





 





 





 





 





 



         }, 




3616




 





 





 





 





 





 



   




3617




 





 





 





 





 





 



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




3618




 





 





 





 





 





 



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




3619




 





 





 





 





 





 



         #'USING' => sub { 




3620




 





 





 





 





 





 



         #    lexer_shift($lx); 




3621




 





 





 





 





 





 



         #    return unless 




3622




 





 





 





 





 





 



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




3623




 





 





 





 





 





 



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




3624




 





 





 





 





 





 



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




3625




 





 





 





 





 





 



         #}, 




3626




1





 





 





 





 





5



     ); 




3627




1




  
 50
  




 





 





 





9



     return unless $r; 




3628



  
0
  



  
  0
  




 





 





 





0



     return if $lx->{error}; 




3629




 





 





 





 





 





 



   




3630



  
0
  




 





 





 





 





0



     lock_hash %$r; 




3631



  
0
  




 





 





 





 





0



     return $r; 




3632




 





 





 





 





 





 



 } 




3633




 





 





 





 





 





 



   




3634




 





 





 





 





 





 



 sub parse_index_type ($) 




3635




 





 





 





 





 





 



 { 




3636




3





 





 




  
3
  



  
0
  




2



     my ($lx)= @_; 




3637




3




  
100
  




 





 





 





6



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




3638




1





 





 





 





 





3



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




3639




 





 





 





 





 





 



     } 




3640




2





 





 





 





 





2



     return; 




3641




 





 





 





 





 





 



 } 




3642




 





 





 





 





 





 



   




3643




 





 





 





 





 





 



 sub parse_table_constraint($) 




3644




 





 





 





 





 





 



 { 




3645




3





 





 




  
3
  



  
0
  




4



     my ($lx)= @_; 




3646




3





 





 





 





 





4



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




3647




3





 





 





 





 





5



     $r->{index_option}= []; 




3648




 





 





 





 





 





 



   




3649




3




  
 50
  




 





 





 





4



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




3650




 





 





 





 





 





 



         return unless 




3651




3




  
 50
  




 





 





 





5



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




3652




 





 





 





 





 





 



     } 




3653




 





 





 





 





 





 



   




3654




 





 





 





 





 





 



     parse_choice($lx, 




3655




 





 





 





 





 





 



         'PRIMARY KEY' => sub { 




3656



  
0
  




 





 




  
0
  




 





0



             lexer_shift($lx); 




3657



  
0
  




 





 





 





 





0



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




3658



  
0
  




 





 





 





 





0



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




3659




 





 





 





 





 





 



             return unless 




3660




 





 





 





 





 





 



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




3661



  
0
  



  
  0
  



  
  0
  




 





 





0



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




3662




 





 





 





 





 





 



         }, 




3663




 





 





 





 





 





 



         'UNIQUE' => sub { 




3664




1





 





 




  
1
  




 





2



             lexer_shift($lx); 




3665




1





 





 





 





 





2



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




3666




1





 





 





 





 





3



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




3667




 





 





 





 





 





 



             return unless 




3668




 





 





 





 





 





 



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




3669




1




  
 50
  



  
 33
  




 





 





4



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




3670




 





 





 





 





 





 



         }, 




3671




 





 





 





 





 





 



         'FULLTEXT' => sub { 




3672



  
0
  




 





 




  
0
  




 





0



             lexer_shift($lx); 




3673



  
0
  




 





 





 





 





0



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




3674



  
0
  




 





 





 





 





0



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




3675




 





 





 





 





 





 



             return unless 




3676




 





 





 





 





 





 



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




3677



  
0
  



  
  0
  



  
  0
  




 





 





0



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




3678




 





 





 





 





 





 



         }, 




3679




 





 





 





 





 





 



         'SPATIAL' => sub { 




3680



  
0
  




 





 




  
0
  




 





0



             lexer_shift($lx); 




3681



  
0
  




 





 





 





 





0



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




3682



  
0
  




 





 





 





 





0



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




3683




 





 





 





 





 





 



             return unless 




3684




 





 





 





 





 





 



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




3685



  
0
  



  
  0
  



  
  0
  




 





 





0



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




3686




 





 





 





 





 





 



         }, 




3687




 





 





 





 





 





 



         'FOREIGN KEY' => sub { 




3688




2





 





 




  
2
  




 





4



             lexer_shift($lx); 




3689




2





 





 





 





 





2



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




3690




2





 





 





 





 





3



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




3691




 





 





 





 





 





 



             return unless 




3692




 





 





 





 





 





 



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




3693




2




  
 50
  



  
 33
  




 





 





5



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




3694




 





 





 





 





 





 



         }, 




3695




 





 





 





 





 





 



         # 'CHECK' => sub { 




3696




 





 





 





 





 





 



         # }, 




3697




 





 





 





 





 





 



         ($read_dialect{mysql} ? 




3698




 





 





 





 





 





 



             ( 




3699




 





 





 





 





 





 



                 'INDEX' => sub { 




3700



  
0
  




 





 




  
0
  




 





0



                     lexer_shift($lx); 




3701



  
0
  




 





 





 





 





0



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




3702




 





 





 





 





 





 



                     # FIXME: mysql allows an index name here 




3703




 





 





 





 





 





 



                     return unless 




3704



  
0
  



  
  0
  




 





 





 





0



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




3705



  
0
  




 





 





 





 





0



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




3706




 





 





 





 





 





 



                 } 




3707




 





 





 





 





 





 



             ) 




3708




3




  
 50
  




 





 





 





27



         :   () 




3709




 





 





 





 





 





 



         ), 




3710




 





 





 





 





 





 



     ); 




3711




3




  
 50
  




 





 





 





45



     return if $lx->{error}; 




3712




 





 





 





 





 





 



   




3713




3





 





 





 





 





7



     lock_hash %$r; 




3714




3





 





 





 





 





45



     return $r; 




3715




 





 





 





 





 





 



 } 




3716




 





 





 





 





 





 



   




3717




 





 





 





 





 





 



 sub parse_table_option1($$$$) 




3718




 





 





 





 





 





 



 { 




3719




6





 





 




  
6
  



  
0
  




8



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




3720




6





 





 





 





 





9



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




3721




6





 





 





 





 





7



     $r->{name}= $name; 




3722




6





 





 





 





 





10



     lexer_shift($lx); 




3723




6





 





 





 





 





11



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




3724




 





 





 





 





 





 



     return unless 




3725




6




  
 50
  




 





 





 





14



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




3726




6





 





 





 





 





11



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




3727




6





 





 





 





 





12



     return $r; 




3728




 





 





 





 





 





 



 } 




3729




 





 





 





 





 





 



   




3730




 





 





 





 





 





 



 sub parse_on_commit_action($) 




3731




 





 





 





 





 





 



 { 




3732




1





 





 




  
1
  



  
0
  




3



     my ($lx)= @_; 




3733




 





 





 





 





 





 



     return keyword ($lx, 




3734




 





 





 





 





 





 



         expect($lx, 




3735




 





 





 





 





 





 



             [ 




3736




 





 





 





 





 





 



                 'PRESERVE ROWS', 




3737




 





 





 





 





 





 



                 'DELETE ROWS', 




3738




 





 





 





 





 





 



                 ($read_dialect{postgresql} ? 




3739




 





 





 





 





 





 



                     ( 




3740




1




  
 50
  




 





 





 





6



                         'DROP' 




3741




 





 





 





 





 





 



                     ) 




3742




 





 





 





 





 





 



                 :   () 




3743




 





 





 





 





 





 



                 ) 




3744




 





 





 





 





 





 



             ], 




3745




 





 





 





 





 





 



             SHIFT 




3746




 





 





 





 





 





 



         ) 




3747




 





 





 





 





 





 



     ); 




3748




 





 





 





 





 





 



 } 




3749




 





 





 





 





 





 



   




3750




 





 





 





 





 





 



 sub parse_table_option($) 




3751




 





 





 





 





 





 



 { 




3752




12





 





 




  
12
  



  
0
  




10



     my ($lx)= @_; 




3753




12





 





 





 





 





23



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




3754




 





 





 





 





 





 



   




3755




 





 





 





 





 





 



     parse_choice($lx, 




3756




 





 





 





 





 





 



         -default => sub { 




3757




4





 





 




  
4
  




 





7



             $r= undef; 




3758




 





 





 





 





 





 



         }, 




3759




 





 





 





 





 





 



   




3760




 





 





 





 





 





 



         ($read_dialect{mysql} ? 




3761




 





 





 





 





 





 



             ( 




3762




 





 





 





 





 





 



                 'ENGINE' => sub { 




3763




2





 





 




  
2
  




 





7



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




3764




 





 





 





 





 





 



                 }, 




3765




 





 





 





 





 





 



          




3766




 





 





 





 





 





 



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




3767




 





 





 





 





 





 



                 'DEFAULT CHARACTER SET' => sub { 




3768




2





 





 




  
2
  




 





4



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




3769




 





 





 





 





 





 



                 }, 




3770




 





 





 





 





 





 



   




3771




 





 





 





 





 





 



                 'COLLATE' => 'DEFAULT COLLATE', 




3772




 





 





 





 





 





 



                 'DEFAULT COLLATE' => sub { 




3773



  
0
  




 





 




  
0
  




 





0



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




3774




 





 





 





 





 





 



                 }, 




3775




 





 





 





 





 





 



   




3776




 





 





 





 





 





 



                 'AUTO_INCREMENT' => sub { 




3777



  
0
  




 





 




  
0
  




 





0



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




3778




 





 





 





 





 





 



                 }, 




3779




 





 





 





 





 





 



   




3780




 





 





 





 





 





 



                 'COMMENT' => sub { 




3781




1





 





 




  
1
  




 





3



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




3782




 





 





 





 





 





 



                 }, 




3783




 





 





 





 





 





 



             ) 




3784




 





 





 





 





 





 



         :   () 




3785




 





 





 





 





 





 



         ), 




3786




 





 





 





 





 





 



   




3787




 





 





 





 





 





 



         'ON COMMIT' => sub { 




3788




1





 





 




  
1
  




 





3



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




3789




 





 





 





 





 





 



         }, 




3790




 





 





 





 





 





 



   




3791




 





 





 





 





 





 



         'interpolTableOption' => 'interpol', 




3792




 





 





 





 





 





 



         'interpol' => sub { 




3793




2





 





 




  
2
  




 





5



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




3794




2





 





 





 





 





2



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




3795




2





 





 





 





 





4



             lexer_shift($lx); 




3796




2





 





 





 





 





4



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




3797




2





 





 





 





 





2



             return $r; 




3798




 





 





 





 





 





 



         }, 




3799




12




  
 50
  




 





 





 





118



     ); 




3800




12




  
100
  




 





 





 





153



     return unless $r; 




3801




8




  
 50
  




 





 





 





15



     return if $lx->{error}; 




3802




8





 





 





 





 





16



     lock_hash %$r; 




3803




8





 





 





 





 





114



     return $r; 




3804




 





 





 





 





 





 



 } 




3805




 





 





 





 





 





 



   




3806




 





 





 





 





 





 



 sub parse_column_def($) 




3807




 





 





 





 





 





 



 { 




3808




6





 





 




  
6
  



  
0
  




4



     my ($lx)= @_; 




3809




6





 





 





 





 





12



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




3810




 





 





 





 





 





 



     return unless 




3811




 





 





 





 





 





 



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




3812




6




  
 50
  



  
 33
  




 





 





13



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




3813




6





 





 





 





 





16



     lock_hash %$r; 




3814




6





 





 





 





 





89



     return $r; 




3815




 





 





 





 





 





 



 } 




3816




 





 





 





 





 





 



   




3817




 





 





 





 





 





 



 sub parse_column_def_or_option($) 




3818




 





 





 





 





 





 



 { 




3819




6





 





 




  
6
  



  
0
  




8



     my ($lx)= @_; 




3820




 





 





 





 





 





 



     return parse_choice($lx, 




3821




 





 





 





 





 





 



         'interpol' => 'ident', 




3822




 





 





 





 





 





 



         'ident' => sub { 




3823




4





 





 




  
4
  




 





10



             return parse_column_def($lx); 




3824




 





 





 





 





 





 



         }, 




3825




 





 





 





 





 





 



         -default => sub { 




3826




2





 





 




  
2
  




 





5



             return parse_table_constraint($lx); 




3827




 





 





 





 





 





 



         }, 




3828




6





 





 





 





 





28



     ); 




3829




 





 





 





 





 





 



 } 




3830




 





 





 





 





 





 



   




3831




 





 





 





 





 





 



 sub parse_create_table($) 




3832




 





 





 





 





 





 



 { 




3833




2





 





 




  
2
  



  
0
  




3



     my ($lx)= @_; 




3834




 





 





 





 





 





 



     return unless 




3835




2




  
 50
  




 





 





 





5



         expect($lx, \@CREATE_TABLE_INITIAL); 




3836




 





 





 





 





 





 



   




3837




2





 





 





 





 





8



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




3838




 





 





 





 





 





 



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




3839




2





 





 





 





 





5



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




3840




 





 





 





 





 





 



   




3841




2




  
100
  



  
 66
  




 





 





11



     if ($read_dialect{mysql} && 




3842




 





 





 





 





 





 



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




3843




 





 





 





 





 





 



     { 




3844




1





 





 





 





 





2



         $r->{if_not_exists}= 1; 




3845




 





 





 





 





 





 



     } 




3846




 





 





 





 





 





 



   




3847




 





 





 





 





 





 



     return unless 




3848




2




  
 50
  




 





 





 





5



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




3849




 





 





 





 





 





 



   




3850




2





 





 





 





 





3



     $r->{column_def}= []; 




3851




2





 





 





 





 





4



     $r->{tabconstr}=  []; 




3852




2




  
 50
  




 





 





 





4



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




3853




 





 





 





 





 





 



         return unless 




3854




2




  
 50
  




 





 





 





6



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




3855




 





 





 





 





 





 



   




3856




2





 





 





 





 





5



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




 




6





 





 





 





 





12



   




3857




2





 





 





 





 





6



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




 




6





 





 





 





 





8



   




3858




 





 





 





 





 





 



     } 




3859




 





 





 





 





 





 



   




3860




 





 





 





 





 





 



     return unless 




3861




2




  
 50
  




 





 





 





8



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




3862




 





 





 





 





 





 



   




3863




2




  
100
  



  
 66
  




 





 





5



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




3864




 





 





 





 





 





 



         looking_at($lx, \@SELECT_INITIAL)) 




3865




 





 





 





 





 





 



     { 




3866




 





 





 





 





 





 



         return unless 




3867




1




  
 50
  




 





 





 





4



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




3868




 





 





 





 





 





 



     } 




3869




 





 





 





 





 





 



   




3870




2




  
  0
  



  
 33
  




 





 





3



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




 




2





 





 





 





 





7



   




3871



  
0
  




 





 





 





 





0



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




3872



  
0
  




 





 





 





 





0



         return; 




3873




 





 





 





 





 





 



     } 




3874




 





 





 





 





 





 



   




3875




2





 





 





 





 





6



     lock_hash %$r; 




3876




2





 





 





 





 





32



     return $r; 




3877




 





 





 





 





 





 



 } 




3878




 





 





 





 





 





 



   




3879




 





 





 





 





 





 



 sub parse_drop_table($) 




3880




 





 





 





 





 





 



 { 




3881




1





 





 




  
1
  



  
0
  




2



     my ($lx)= @_; 




3882




 





 





 





 





 





 



     return unless 




3883




1




  
 50
  




 





 





 





3



         expect($lx, \@DROP_TABLE_INITIAL); 




3884




 





 





 





 





 





 



   




3885




1





 





 





 





 





6



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




3886




 





 





 





 





 





 



                   qw(subtype if_exists table cascade)); 




3887




1





 





 





 





 





4



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




3888




 





 





 





 





 





 



   




3889




1




  
 50
  



  
 33
  




 





 





5



     if ($read_dialect{mysql} && 




3890




 





 





 





 





 





 



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




3891




 





 





 





 





 





 



     { 




3892




1





 





 





 





 





1



         $r->{if_exists}= 1; 




3893




 





 





 





 





 





 



     } 




3894




 





 





 





 





 





 



   




3895




 





 





 





 





 





 



     return unless 




3896




1




  
 50
  




 





 





 





5



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




3897




 





 





 





 





 





 



   




3898




1





 





 





 





 





4



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




3899




 





 





 





 





 





 



   




3900




1





 





 





 





 





3



     lock_hash %$r; 




3901




1





 





 





 





 





14



     return $r; 




3902




 





 





 





 





 





 



 } 




3903




 





 





 





 





 





 



   




3904




 





 





 





 





 





 



 sub parse_column_pos_perhaps($) 




3905




 





 





 





 





 





 



 { 




3906




3





 





 




  
3
  



  
0
  




3



     my ($lx)= @_; 




3907




 





 





 





 





 





 



     return parse_choice($lx, 




3908




 





 





 





 





 





 



         -default => sub { 




3909




1





 





 




  
1
  




 





3



             return; 




3910




 





 





 





 





 





 



         }, 




3911




 





 





 





 





 





 



         'FIRST' => sub { 




3912




1





 





 




  
1
  




 





2



             return lexer_shift($lx); 




3913




 





 





 





 





 





 



         }, 




3914




 





 





 





 





 





 



         'AFTER' => sub { 




3915




1





 





 




  
1
  




 





3



             lexer_shift($lx); 




3916




1





 





 





 





 





2



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




3917




 





 





 





 





 





 



         }, 




3918




3





 





 





 





 





16



     ); 




3919




 





 





 





 





 





 



 } 




3920




 





 





 





 





 





 



   




3921




 





 





 





 





 





 



 sub parse_alter_table($) 




3922




 





 





 





 





 





 



 { 




3923




20





 





 




  
20
  



  
0
  




18



     my ($lx)= @_; 




3924




 





 





 





 





 





 



     return unless 




3925




20




  
 50
  




 





 





 





30



         expect($lx, \@ALTER_TABLE_INITIAL); 




3926




 





 





 





 





 





 



   




3927




20





 





 





 





 





43



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




3928




 





 





 





 





 





 



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




3929




20





 





 





 





 





30



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




3930




20





 





 





 





 





22



     $r->{arg}=     []; 




3931




 





 





 





 





 





 



   




3932




 





 





 





 





 





 



     return unless 




3933




20




  
 50
  




 





 





 





27



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




3934




 





 





 





 





 





 



   




3935




20





 





 





 





 





25



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




3936




 





 





 





 





 





 



   




3937




 





 





 





 





 





 



     parse_choice($lx, 




3938




 





 





 





 





 





 



         'DROP CONSTRAINT' => sub { 




3939




1





 





 




  
1
  




 





2



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




3940




 





 





 





 





 





 



             return unless 




3941




1




  
 50
  




 





 





 





2



                 my $constraint= parse_constraint($lx); 




3942




1





 





 





 





 





1



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




 




1





 





 





 





 





3



   




3943




 





 





 





 





 





 



         }, 




3944




 





 





 





 





 





 



   




3945




 





 





 





 





 





 



         'DROP COLUMN' => sub { 




3946




3





 





 




  
3
  




 





5



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




3947




 





 





 





 





 





 



             return unless 




3948




3




  
 50
  




 





 





 





6



                 my $column= parse_column_name($lx); 




3949




3





 





 





 





 





3



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




 




3





 





 





 





 





7



   




3950




 





 





 





 





 





 



         }, 




3951




 





 





 





 





 





 



   




3952




 





 





 





 





 





 



         'RENAME COLUMN' => sub { 




3953




1





 





 




  
1
  




 





2



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




3954




 





 





 





 





 





 



   




3955




 





 





 





 





 





 



             return unless 




3956




1




  
 50
  



  
 33
  




 





 





2



                 my $column= parse_column_name($lx) 




 




 





 




  
 33
  




 





 





 



   




3957




 





 





 





 





 





 



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




3958




 





 





 





 





 





 



             and my $column2= parse_column_name($lx); 




3959




 





 





 





 





 





 



   




3960




1





 





 





 





 





2



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




 




1





 





 





 





 





3



   




3961




 





 





 





 





 





 



         }, 




3962




 





 





 





 





 





 



   




3963




 





 





 





 





 





 



         'DROP PRIMARY KEY' => sub { 




3964




1





 





 




  
1
  




 





2



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




3965




 





 





 





 





 





 



         }, 




3966




 





 





 





 





 





 



   




3967




 





 





 





 





 





 



         'ALTER COLUMN' => sub { 




3968




6





 





 




  
6
  




 





9



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




3969




6





 





 





 





 





5



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




 




6





 





 





 





 





12



   




3970




6




  
 50
  




 





 





 





10



             return if $lx->{error}; 




3971




 





 





 





 





 





 



   




3972




 





 





 





 





 





 



             parse_choice($lx, 




3973




 





 





 





 





 





 



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




3974




 





 





 





 





 





 



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




3975




 





 





 





 





 





 



                 'SET NOT NULL'  => sub { 




3976




3





 





 





 





 





2



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




 




3





 





 





 





 





7



   




3977




 





 





 





 





 





 



                 }, 




3978




 





 





 





 





 





 



   




3979




 





 





 





 





 





 



                 'SET DEFAULT' => sub { 




3980




1





 





 





 





 





2



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




 




1





 





 





 





 





3



   




3981




1





 





 





 





 





2



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




 




1





 





 





 





 





3



   




3982




 





 





 





 





 





 



                 }, 




3983




 





 





 





 





 





 



   




3984




 





 





 





 





 





 



                 ($read_dialect{postgresql} ? 




3985




 





 





 





 





 





 



                     ( 




3986




 





 





 





 





 





 



                         'TYPE' => sub { 




3987




2





 





 





 





 





2



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




 




2





 





 





 





 





4



   




3988




2





 





 





 





 





2



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




 




2





 





 





 





 





7



   




3989




2




  
 50
  




 





 





 





5



                             return if $lx->{error}; 




3990




2




  
100
  




 





 





 





3



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




3991




1





 





 





 





 





1



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




 




1





 





 





 





 





3



   




3992




 





 





 





 





 





 



                             } 




3993




 





 





 





 





 





 



                         } 




3994




 





 





 





 





 





 



                     ) 




3995




6




  
 50
  




 





 





 





34



                 :   () 




3996




 





 





 





 





 





 



                 ), 




3997




 





 





 





 





 





 



             ); 




3998




 





 





 





 





 





 



         }, 




3999




 





 





 





 





 





 



   




4000




 





 





 





 





 





 



         'RENAME TO' => sub { 




4001




1





 





 




  
1
  




 





2



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




4002




1





 





 





 





 





1



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




 




1





 





 





 





 





4



   




4003




 





 





 





 





 





 



         }, 




4004




 





 





 





 





 





 



   




4005




 





 





 





 





 





 



         'ADD COLUMN' => sub { 




4006




2





 





 




  
2
  




 





4



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




4007




2




  
100
  




 





 





 





3



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




4008




1





 





 





 





 





1



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




 




1





 





 





 





 





4



   




4009




1




  
 50
  




 





 





 





3



                 return if $lx->{error}; 




4010




1





 





 





 





 





3



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




4011




 





 





 





 





 





 



             } 




4012




 





 





 





 





 





 



             else { 




4013




 





 





 





 





 





 



                 return unless 




4014




1




  
 50
  



  
 33
  




 





 





2



                     my $col1= parse_column_name($lx) 




4015




 





 





 





 





 





 



                 and my $spec= parse_column_spec($lx); 




4016




1





 





 





 





 





1



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




 




1





 





 





 





 





4



   




4017




 





 





 





 





 





 



             } 




4018




 





 





 





 





 





 



         }, 




4019




 





 





 





 





 





 



   




4020




 





 





 





 





 





 



         'ADD' => sub { 




4021




1





 





 




  
1
  




 





3



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




4022




1





 





 





 





 





2



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




 




1





 





 





 





 





3



   




4023




 





 





 





 





 





 



         }, 




4024




 





 





 





 





 





 



   




4025




 





 





 





 





 





 



         ($read_dialect{mysql} ? 




4026




 





 





 





 





 





 



             ( 




4027




 





 





 





 





 





 



                 'MODIFY COLUMN' => sub { 




4028




1





 





 




  
1
  




 





2



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




4029




 





 





 





 





 





 



                     return unless 




4030




1




  
 50
  



  
 33
  




 





 





3



                         my $col1= parse_column_name($lx) 




4031




 





 





 





 





 





 



                     and my $spec= parse_column_spec($lx); 




4032




1





 





 





 





 





1



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




 




1





 





 





 





 





3



   




4033




 





 





 





 





 





 



                 }, 




4034




 





 





 





 





 





 



                 'CHANGE COLUMN' => sub { 




4035




1





 





 




  
1
  




 





3



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




4036




 





 





 





 





 





 



                     return unless 




4037




1




  
 50
  



  
 33
  




 





 





2



                         my $col1= parse_column_name($lx) 




 




 





 




  
 33
  




 





 





 



   




4038




 





 





 





 





 





 



                     and my $col2= parse_column_name($lx) 




4039




 





 





 





 





 





 



                     and my $spec= parse_column_spec($lx); 




4040




1





 





 





 





 





2



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




 




1





 





 





 





 





3



   




4041




 





 





 





 





 





 



                 }, 




4042




 





 





 





 





 





 



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




4043




1





 





 




  
1
  




 





2



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




4044




 





 





 





 





 





 



                     return unless 




4045




1




  
 50
  




 





 





 





2



                         my $constraint= parse_constraint($lx); 




4046




1





 





 





 





 





1



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




 




1





 





 





 





 





4



   




4047




 





 





 





 





 





 



                 }, 




4048




 





 





 





 





 





 



                 'DROP INDEX' => sub { 




4049




1





 





 




  
1
  




 





2



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




4050




 





 





 





 





 





 



                     return unless 




4051




1




  
 50
  




 





 





 





3



                         my $index= parse_index($lx); 




4052




1





 





 





 





 





2



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




 




1





 





 





 





 





3



   




4053




 





 





 





 





 





 



                 }, 




4054




 





 





 





 





 





 



             ) 




4055




20




  
 50
  




 





 





 





247



         :   () 




4056




 





 





 





 





 





 



         ), 




4057




 





 





 





 





 





 



     ); 




4058




20




  
 50
  




 





 





 





431



     return if $lx->{error}; 




4059




 





 





 





 





 





 



   




4060




20





 





 





 





 





41



     lock_hash %$r; 




4061




20





 





 





 





 





369



     return $r; 




4062




 





 





 





 





 





 



 } 




4063




 





 





 





 





 





 



   




4064




 





 





 





 





 





 



 sub parse_stmt_interpol($) 




4065




 





 





 





 





 





 



 { 




4066




3





 





 




  
3
  



  
0
  




5



     my ($lx)= @_; 




4067




 





 





 





 





 





 



   




4068




 





 





 





 





 





 



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




4069




 





 





 





 





 





 



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




4070




3




  
 50
  



  
 33
  




 





 





18



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




4071




 





 





 





 





 





 



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




4072




 





 





 





 





 





 



     { 




4073



  
0
  




 





 





 





 





0



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




4074



  
0
  




 





 





 





 





0



         return; 




4075




 





 





 





 





 





 



     } 




4076




 





 





 





 





 





 



   




4077




3




  
 50
  




 





 





 





9



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




4078



  
0
  




 





 





 





 





0



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




4079



  
0
  




 





 





 





 





0



         return; 




4080




 





 





 





 





 





 



     } 




4081




 





 





 





 





 





 



   




4082




3




  
 50
  




 





 





 





8



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




4083



  
0
  




 





 





 





 





0



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




4084



  
0
  




 





 





 





 





0



         return; 




4085




 





 





 





 





 





 



     } 




4086




 





 





 





 





 





 



   




4087




 





 





 





 





 





 



     # But some may be: 




4088




3





 





 





 





 





7



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




4089




3





 





 





 





 





6



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




4090




3





 





 





 





 





10



     lexer_shift($lx); 




4091




 





 





 





 





 





 



   




4092




3





 





 





 





 





8



     lock_hash %$r; 




4093




3





 





 





 





 





42



     return $r; 




4094




 





 





 





 





 





 



 } 




4095




 





 





 





 





 





 



   




4096




 





 





 





 





 





 



 sub parse_select_stmt($) 




4097




 





 





 





 





 





 



 { 




4098




6





 





 




  
6
  



  
0
  




8



     my ($lx)= @_; 




4099




 





 





 





 





 





 



     return parse_choice($lx, 




4100




6





 





 




  
6
  




 





11



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




4101




 





 





 





 





 





 



   




4102




 





 





 





 





 





 



         'interpolStmt' => 'interpol', 




4103



  
0
  




 





 




  
0
  




 





0



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




4104




6





 





 





 





 





25



     ); 




4105




 





 





 





 





 





 



 } 




4106




 





 





 





 





 





 



   




4107




 





 





 





 





 





 



 sub parse_stmt($) 




4108




 





 





 





 





 





 



 { 




4109




225





 





 




  
225
  



  
0
  




206



     my ($lx)= @_; 




4110




 





 





 





 





 





 



     return parse_choice($lx, 




4111




173





 





 




  
173
  




 





284



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




4112




13





 





 




  
13
  




 





30



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




4113




9





 





 




  
9
  




 





23



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




4114




4





 





 




  
4
  




 





12



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




4115




 





 





 





 





 





 



   




4116




1350





 





 





 





 





1408



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




4117




2





 





 




  
2
  




 





6



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




4118




 





 





 





 





 





 



   




4119




450





 





 





 





 





647



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




4120




1





 





 




  
1
  




 





4



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




4121




 





 





 





 





 





 



   




4122




1350





 





 





 





 





1636



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




4123




20





 





 




  
20
  




 





27



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




4124




 





 





 





 





 





 



   




4125




 





 





 





 





 





 



         'interpolStmt' => 'interpol', 




4126




3





 





 




  
3
  




 





6



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




4127




225





 





 





 





 





1038



     ); 




4128




 





 





 





 





 





 



 } 




4129




 





 





 





 





 





 



   




4130




 





 





 





 





 





 



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




4131




 





 





 





 





 





 



 # Perl generation: 




4132




 





 





 





 





 





 



   




4133




 





 





 





 





 





 



   




4134




 





 





 





 





 





 



 ## First: creating a list of strings. 




4135




 





 





 





 





 





 



 # 




4136




 





 





 





 





 





 



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




4137




 





 





 





 





 





 



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




4138




 





 





 





 





 





 



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




4139




 





 





 





 





 





 



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




4140




 





 





 





 





 





 



 # 




4141




 





 





 





 





 





 



 #    my $s= str_new(); 




4142




 





 





 





 





 





 



 #    str_append_str  ($s, "a"); 




4143




 





 





 





 





 





 



 #    str_append_perl ($s, "b"); 




4144




 





 





 





 





 





 



 # 




4145




 





 





 





 





 





 



 # This would result in the following string: 




4146




 





 





 





 





 





 



 # 




4147




 





 





 





 





 





 



 #    'a',b 




4148




 





 





 





 





 





 



 # 




4149




 





 





 





 





 





 



 # Appending the comma separator is done automatically. 




4150




 





 





 





 





 





 



 # 




4151




 





 





 





 





 





 



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




4152




 





 





 





 





 





 



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




4153




 





 





 





 





 





 



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




4154




 





 





 





 





 





 



 # characters is done automatically by the str_ functions. 




4155




 





 





 





 





 





 



 # 




4156




 





 





 





 





 





 



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




4157




 





 





 





 





 





 



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




4158




 





 





 





 





 





 



 # 




4159




 





 





 





 





 





 



 #    my $s= str_new(); 




4160




 





 





 





 





 





 



 #    str_append_str  ($s, 'a'); 




4161




 





 





 





 





 





 



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




4162




 





 





 





 





 





 



 #    str_append_perl ($s, 'b'); 




4163




 





 





 





 





 





 



 #    str_target_line ($s, 2); 




4164




 





 





 





 





 





 



 #    str_append_str  ($s, 'c'); 




4165




 





 





 





 





 





 



 #    str_append_end  ($s); 




4166




 





 





 





 





 





 



 #    str_append_perl ($s, 'd'); 




4167




 





 





 





 





 





 



 # 




4168




 





 





 





 





 





 



 # This results in the following string in $s: 




4169




 





 





 





 





 





 



 # 




4170




 





 





 





 





 





 



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




4171




 





 





 





 





 





 



 #    'c'),d 




4172




 





 





 





 





 





 



 # 




4173




 





 





 





 





 





 



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




4174




 





 





 





 





 





 



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




4175




 





 





 





 





 





 



 # 




4176




 





 





 





 





 





 



 #    str_append_str  ($s, 'a'); 




4177




 





 





 





 





 





 



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




4178




 





 





 





 





 





 



 #    str_append_perl ($s, 'b'); 




4179




 





 





 





 





 





 



 #    str_append_str  ($s, 'c'); 




4180




 





 





 





 





 





 



 #    str_append_end  ($s); 




4181




 





 





 





 





 





 



 #    str_append_perl ($s, 'd'); 




4182




 





 





 





 





 





 



 # 




4183




 





 





 





 





 





 



 # This results in: 




4184




 





 





 





 





 





 



 # 




4185




 





 





 





 





 





 



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




4186




 





 





 





 





 





 



 # 




4187




 





 





 





 





 





 



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




4188




 





 





 





 





 





 



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




4189




 





 





 





 





 





 



 # _max1_if_scalar, are slightly inefficient and should later be eliminated 




4190




 





 





 





 





 





 



 # if possible. 




4191




 





 





 





 





 





 



 # 




4192




 





 





 





 





 





 



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




4193




 





 





 





 





 





 



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




4194




 





 





 





 





 





 



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




4195




 





 





 





 





 





 



 # problems, e.g. after map: 




4196




 





 





 





 





 





 



 # 




4197




 





 





 





 





 





 



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




4198




 





 





 





 





 





 



 # 




4199




 





 





 





 





 





 



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




4200




 





 





 





 





 





 



 # 




4201




 





 





 





 





 





 



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




4202




 





 





 





 





 





 



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




4203




 





 





 





 





 





 



 sub str_new($) 




4204




 





 





 





 





 





 



 { 




4205




278





 





 




  
278
  



  
0
  




228



     my ($line_start)= @_; 




4206




278





 





 





 





 





257



     my $text= []; 




4207




278





 





 





 





 





788



     my $s= { 




4208




 





 





 





 





 





 



         buff        => '', 




4209




 





 





 





 





 





 



         need_comma  => 0, 




4210




 





 





 





 





 





 



         line_is     => 1, 




4211




 





 





 





 





 





 



         line_target => 1, 




4212




 





 





 





 





 





 



         line_start  => $line_start, 




4213




 





 





 





 





 





 



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




4214




 





 





 





 





 





 



     }; 




4215




278





 





 





 





 





446



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




4216




278





 





 





 





 





1220



     return $s; 




4217




 





 





 





 





 





 



 } 




4218




 





 





 





 





 





 



   




4219




 





 





 





 





 





 



 sub str_append_raw($$) 




4220




 





 





 





 





 





 



 { 




4221




11636





 





 




  
11636
  



  
0
  




8372



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




4222




11636





 





 





 





 





9210



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




4223




11636





 





 





 





 





11355



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




4224




 





 





 





 





 





 



 } 




4225




 





 





 





 





 





 



   




4226




 





 





 





 





 





 



 sub str_sync_line($) 




4227




 





 





 





 





 





 



 { 




4228




5808





 





 




  
5808
  



  
0
  




3892



     my ($s)= @_; 




4229




5808





 





 





 





 





8640



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




4230




309





 





 





 





 





349



         str_append_raw ($s, "\n"); 




4231




 





 





 





 





 





 



     } 




4232




 





 





 





 





 





 



 } 




4233




 





 





 





 





 





 



 sub str_target_line($$) 




4234




 





 





 





 





 





 



 { 




4235




2834





 





 




  
2834
  



  
0
  




2155



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




4236




2834




  
 50
  




 





 





 





3541



     my_confess "undefined line number" unless defined $n; 




4237




2834





 





 





 





 





2569



     $s->{line_target}= $n; 




4238




 





 





 





 





 





 



 } 




4239




 





 





 





 





 





 



   




4240




 





 





 





 





 





 



 sub str_append_comma($) 




4241




 





 





 





 





 





 



 { 




4242




7388





 





 




  
7388
  



  
0
  




4702



     my ($s)= @_; 




4243




7388




  
100
  




 





 





 





10358



     if ($s->{need_comma}) { 




4244




3792





 





 





 





 





4183



         str_append_raw ($s, COMMA_STR); 




4245




3792





 





 





 





 





3382



         $s->{need_comma}= 0; 




4246




 





 





 





 





 





 



     } 




4247




 





 





 





 





 





 



 } 




4248




 





 





 





 





 





 



   




4249




 





 





 





 





 





 



 sub str_append_perl($$) 




4250




 





 





 





 





 





 



 { 




4251




4347





 





 




  
4347
  



  
0
  




3954



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




4252




4347




  
 50
  




 





 





 





5876



     if ($perl ne '') { 




4253




4347





 





 





 





 





4107



         str_append_comma($s); 




4254




4347





 





 





 





 





4082



         str_sync_line ($s); 




4255




4347





 





 





 





 





3920



         str_append_raw ($s, $perl); 




4256




4347





 





 





 





 





38232



         $s->{need_comma}= 1; 




4257




 





 





 





 





 





 



     } 




4258




 





 





 





 





 





 



 } 




4259




 





 





 





 





 





 



   




4260




 





 





 





 





 





 



 sub str_append_str($$) 




4261




 





 





 





 





 





 



 { 




4262




2628





 





 




  
2628
  



  
0
  




1968



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




4263




2628





 





 





 





 





2669



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




4264




 





 





 





 





 





 



 } 




4265




 





 





 





 





 





 



   




4266




 





 





 





 





 





 



 sub str_append_join($%) 




4267




 





 





 





 





 





 



 { 




4268




764





 





 




  
764
  



  
0
  




1423



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




4269




764





 




  
100
  




 





 





1705



     $opt{prefix}||=  ''; 




4270




764





 




  
100
  




 





 





1701



     $opt{suffix}||=  ''; 




4271




764





 




  
100
  




 





 





1284



     $opt{sep}||=     ''; 




4272




 





 





 





 





 





 



   




4273




764





 





 





 





 





820



     str_append_comma($s); 




4274




764





 





 





 





 





809



     str_sync_line  ($s); 




4275




764




  
100
  



  
 66
  




 





 





3284



     if ($opt{joinfunc}) { 




 




 




  
100
  



  
 66
  




 





 





 



   




 




 




  
100
  



  
 66
  




 





 





 



   




 




 





 




  
 66
  




 





 





 



   




 




 





 




  
 66
  




 





 





 



   




4276




 





 





 





 





 





 



         # special case: ignore all other settings 




4277




94





 





 





 





 





209



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




4278




94





 





 





 





 





98



         $s->{need_comma}= 0; 




4279




94





 





 





 





 





75



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




 




94





 





 





 





 





191



   




4280




 





 





 





 





 





 



     } 




4281




 





 





 





 





 





 



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




4282




 





 





 





 





 





 



            $opt{suffix} eq '' && 




4283




 





 





 





 





 





 



            ( 




4284




 





 





 





 





 





 



                $opt{never_empty} || 




4285




 





 





 





 





 





 



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




4286




 





 





 





 





 





 



            )) 




4287




 





 





 





 





 





 



     { 




4288




 





 





 





 





 





 



         # simple case 1 




4289




254





 





 





 





 





315



         str_append_raw ($s, 'join('); 




4290




254





 





 





 





 





386



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




4291




254





 





 





 





 





235



         $s->{need_comma}= 1; 




4292




254





 





 





 





 





199



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




 




254





 





 





 





 





445



   




4293




 





 





 





 





 





 



     } 




4294




 





 





 





 





 





 



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




4295




 





 





 





 





 





 



            ( 




4296




 





 





 





 





 





 



                $opt{never_empty} || 




4297




 





 





 





 





 





 



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




4298




 





 





 





 





 





 



            )) 




4299




 





 





 





 





 





 



     { 




4300




 





 





 





 





 





 



         # simple case 2 




4301




21





 





 





 





 





31



         str_append_raw ($s, 'join('); 




4302




21





 





 





 





 





27



         str_append_str ($s, ''); 




4303




 





 





 





 





 





 



   




4304




21




  
 50
  




 





 





 





40



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




4305




21





 





 





 





 





25



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




4306




 





 





 





 





 





 



         } 




4307




 





 





 





 





 





 



   




4308




21





 




  
100
  




 





 





21



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




 




21





 





 





 





 





68



   




4309




 





 





 





 





 





 



     } 




4310




 





 





 





 





 





 



     else { 




4311




 





 





 





 





 





 



         # complex case: 




4312




395





 





 





 





 





545



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




4313




395





 





 





 





 





678



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




4314




 





 





 





 





 





 



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




4315




 





 





 





 





 





 



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




4316




 





 





 





 





 





 



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




4317




 





 





 





 





 





 



             # nicer error messages if necessary. 




4318




395





 





 





 





 





385



         str_append_comma($s); 




4319




395





 





 





 





 





518



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




4320




395





 





 





 





 





456



         str_append_comma($s); 




4321




395





 





 





 





 





431



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




4322




395





 





 





 





 





434



         str_append_comma($s); 




4323




395





 





 





 





 





431



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




4324




395





 





 





 





 





397



         str_append_comma($s); 




4325




395





 





 





 





 





431



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




4326




395





 





 





 





 





344



         $s->{need_comma}= 1; 




4327




395





 





 





 





 





282



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




 




395





 





 





 





 





713



   




4328




 





 





 





 





 





 



     } 




4329




 





 





 





 





 





 



 } 




4330




 





 





 





 





 





 



   




4331




 





 





 





 





 





 



 sub str_append_map($$) 




4332




 





 





 





 





 





 



 { 




4333




173





 





 




  
173
  



  
0
  




170



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




4334




173





 





 





 





 





217



     str_append_comma($s); 




4335




173





 





 





 





 





198



     str_sync_line  ($s); 




4336




173





 





 





 





 





305



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




4337




173





 





 





 





 





199



     $s->{need_comma}= 0; 




4338




173





 





 





 





 





137



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




 




173





 





 





 





 





281



   




4339




 





 





 





 





 





 



 } 




4340




 





 





 





 





 





 



   




4341




 





 





 





 





 





 



 sub str_append_funcall_begin($$$) 




4342




 





 





 





 





 





 



 { 




4343




523





 





 




  
523
  



  
0
  




448



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




4344




523





 





 





 





 





592



     str_append_comma($s); 




4345




523





 





 





 





 





688



     str_sync_line  ($s); 




4346




523




  
100
  




 





 





 





597



     if ($in_list) { 




4347




277





 





 





 





 





489



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




4348




 





 





 





 





 





 



     } 




4349




 





 





 





 





 





 



     else { 




4350




246





 





 





 





 





419



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




4351




 





 





 





 





 





 



     } 




4352




523





 





 





 





 





510



     $s->{need_comma}= 0; 




4353




523





 





 





 





 





419



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




 




523





 





 





 





 





749



   




4354




 





 





 





 





 





 



 } 




4355




 





 





 





 





 





 



   




4356




 





 





 





 





 





 



 sub str_append_funcall_end($$) 




4357




 





 





 





 





 





 



 { 




4358




523





 





 




  
523
  



  
0
  




397



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




4359




523




  
100
  




 





 





 





822



     if ($in_list) { 




4360




277





 





 





 





 





338



         str_append_perl ($s, '$_'); 




4361




277





 





 





 





 





257



         str_append_raw ($s, ') }'); 




4362




277





 





 





 





 





289



         $s->{need_comma}= 0; 




4363




 





 





 





 





 





 



     } 




4364




 





 





 





 





 





 



 } 




4365




 





 





 





 





 





 



   




4366




 





 





 





 





 





 



 sub str_append_funcall($$$) 




4367




 





 





 





 





 





 



 { 




4368




445





 





 




  
445
  



  
0
  




492



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




4369




445





 





 





 





 





631



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




4370




445





 





 





 





 





589



     str_append_funcall_end   ($s, $in_list); 




4371




 





 





 





 





 





 



 } 




4372




 





 





 





 





 





 



   




4373




 





 





 





 





 





 



 sub str_append_end($) 




4374




 





 





 





 





 





 



 # Terminator for: 




4375




 





 





 





 





 





 



 #   str_append_map 




4376




 





 





 





 





 





 



 #   str_append_funcall 




4377




 





 





 





 





 





 



 #   str_append_join 




4378




 





 





 





 





 





 



 { 




4379




1450





 





 




  
1450
  



  
0
  




1315



     my ($s)= @_; 




4380




1450





 





 





 





 





976



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




 




1450





 





 





 





 





1795



   




4381




1450




  
100
  




 





 





 





2176



     if (defined $end_str) { 




4382




18





 





 





 





 





24



         str_append_str($s, $end_str); 




4383




 





 





 





 





 





 



     } 




4384




1450





 





 





 





 





1608



     str_append_raw ($s, ')'); 




4385




1450





 





 





 





 





35615



     $s->{need_comma}= 1; 




4386




 





 





 





 





 





 



 } 




4387




 





 





 





 





 





 



   




4388




 





 





 





 





 





 



 sub str_get_string($) 




4389




 





 





 





 





 





 



 { 




4390




275





 





 




  
275
  



  
0
  




383



     my ($s)= @_; 




4391




275




  
 50
  




 





 





 





490



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




4392




275





 





 





 





 





494



     return $s->{buff}; 




4393




 





 





 





 





 





 



 } 




4394




 





 





 





 





 





 



   




4395




 





 





 





 





 





 



 # Now start appending more complex things: 




4396




 





 





 





 





 





 



   




4397




 





 





 





 





 





 



 sub str_append_thing($$$$); 




4398




 





 





 





 





 





 



   




4399




 





 





 





 





 





 



 sub str_append_list($$$;%) 




4400




 





 





 





 





 





 



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




4401




 





 





 





 





 





 



 # so str_append_join() can optimise. 




4402




 





 





 





 





 





 



 { 




4403




354





 





 




  
354
  



  
0
  




539



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




4404




354





 





 





 





 





915



     local $SIG{__DIE__}= \&my_confess; 




4405




 





 





 





 





 





 



   




4406




 





 





 





 





 





 



     # set line to first element (if any): 




4407




354




  
 50
  




 





 





 





552



     if (scalar(@$list)) { 




4408




354





 





 





 





 





533



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




4409




 





 





 





 





 





 



     } 




4410




 





 





 





 





 





 



   




4411




 





 





 





 





 





 



     # joining, delimiters, result if empty: 




4412




 





 





 





 





 





 



     str_append_join($str, 




4413




 





 





 





 





 





 



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




4414




 





 





 





 





 





 



         prefix   => $opt{prefix}, 




4415




 





 





 





 





 





 



         suffix   => $opt{suffix}, 




4416




 





 





 





 





 





 



         result0  => $opt{result0}, 




4417




354




  
100
  




 





 





 





1096



     ); 




4418




 





 





 





 





 





 



   




4419




 





 





 





 





 





 



     # map? 




4420




354




  
100
  




 





 





 





733



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




4421




1





 





 





 





 





2



         str_append_comma ($str); 




4422




1





 





 





 





 





124



         str_sync_line    ($str); 




4423




1





 





 





 





 





3



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




4424




1





 





 





 





 





2



         $str->{need_comma}= 0; 




4425




 





 





 





 





 





 



     }; 




4426




 





 





 





 





 





 



   




4427




 





 





 





 





 





 



     # the list: 




4428




354





 





 





 





 





424



     for my $l (@$list) { 




4429




428





 





 





 





 





588



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




4430




 





 





 





 





 





 



     } 




4431




 





 





 





 





 





 



   




4432




 





 





 





 





 





 



     # end: 




4433




352





 





 





 





 





560



     str_append_end($str); 




4434




 





 





 





 





 





 



 } 




4435




 





 





 





 





 





 



   




4436




 





 





 





 





 





 



 sub interpol_set_context ($$); 




4437




 





 





 





 





 





 



   




4438




 





 





 





 





 





 



 sub perl_val($$$) 




4439




 





 





 





 





 





 



 { 




4440




1056





 





 




  
1056
  



  
0
  




1088



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




4441




 





 





 





 





 





 



   




4442




 





 





 





 





 





 



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




4443




 





 





 





 





 





 



         if $allow && 




4444




1056




  
 50
  



  
 66
  




 





 





1874



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




 




96





 





 





 





 





188



   




4445




 





 





 





 





 





 



   




4446




 





 





 





 





 





 



     return switch($token->{kind}, 




4447




526





 





 




  
526
  




 





803



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




4448




9





 





 




  
9
  




 





22



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




4449




2





 





 




  
2
  




 





4



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




4450




2





 





 




  
2
  




 





5



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




4451




1





 





 




  
1
  




 





4



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




4452



  
0
  




 





 




  
0
  




 





0



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




4453



  
0
  




 





 




  
0
  




 





0



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




4454




1





 





 




  
1
  




 





3



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




4455




 





 





 





 





 





 



         -default => sub { 




4456




515




  
 50
  




 




  
515
  




 





1694



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




4457




515





 





 





 





 





745



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




4458




 





 





 





 





 





 



             } 




4459




 





 





 





 





 





 



             else { 




4460



  
0
  




 





 





 





 





0



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




4461




 





 





 





 





 





 



             } 




4462




 





 





 





 





 





 



         } 




4463




1056





 





 





 





 





8177



     ); 




4464




 





 





 





 





 





 



 } 




4465




 





 





 





 





 





 



   




4466




 





 





 





 





 





 



 sub perl_val_list($$$) 




4467




 





 





 





 





 





 



 { 




4468




43





 





 




  
43
  



  
0
  




43



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




4469




43





 





 





 





 





57



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




4470




 





 





 





 





 





 



   




4471




43




  
100
  




 





 





 





281



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




4472




9





 





 





 





 





26



         return "sort keys $s"; 




4473




 





 





 





 





 





 



     } 




4474




 





 





 





 





 





 



     else { 




4475




34





 





 





 





 





86



         return $s; 




4476




 





 





 





 





 





 



     } 




4477




 





 





 





 





 





 



 } 




4478




 





 





 





 





 





 



   




4479




 





 





 





 





 





 



 sub token_pos($) 




4480




 





 





 





 





 





 



 { 




4481




3





 





 




  
3
  



  
0
  




4



     my ($token)= @_; 




4482




3





 





 





 





 





40



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




4483




 





 





 





 





 





 



 } 




4484




 





 





 





 





 





 



   




4485




 





 





 





 





 





 



 sub lx_pos($) 




4486




 





 





 





 





 





 



 { 




4487




2





 





 




  
2
  



  
0
  




2



     my ($lx)= @_; 




4488




2





 





 





 





 





23



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




4489




 





 





 





 





 





 



 } 




4490




 





 





 





 





 





 



   




4491




 





 





 





 





 





 



 sub croak_unless_scalar($) 




4492




 





 





 





 





 





 



 { 




4493




861





 





 




  
861
  



  
0
  




727



     my ($token)= @_; 




4494




 





 





 





 





 





 



     die token_pos($token).": ". 




4495




 





 





 





 





 





 



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




4496




861




  
100
  



  
 66
  




 





 





5370



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




4497




 





 





 





 





 





 



 } 




4498




 





 





 





 





 





 



   




4499




 





 





 





 





 





 



 sub str_append_typed($$$$$%) 




4500




 





 





 





 





 





 



 { 




4501




474





 





 




  
474
  



  
0
  




701



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




4502




474





 





 





 





 





772



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




4503




 





 





 





 





 





 



   




4504




474




  
100
  



  
100
  




 





 





3751



     if (!$in_list || 




 




 




  
100
  




 





 





 





 



   




4505




 





 





 





 





 





 



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




4506




 





 





 





 





 





 



     { 




4507




358





 





 





 





 





476



         croak_unless_scalar ($thing->{token}); 




4508




356





 





 





 





 





878



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




4509




 





 





 





 





 





 



     } 




4510




 





 





 





 





 





 



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




4511




19




  
100
  




 





 





 





43



         if ($opt{hash}) { 




 




 




  
 50
  




 





 





 





 



   




4512




16





 





 





 





 





49



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




4513




 





 





 





 





 





 



         } 




4514




 





 





 





 





 





 



         elsif ($opt{hashkeys}) { 




4515




3





 





 





 





 





11



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




4516




3





 





 





 





 





9



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




4517




3





 





 





 





 





6



             str_append_end  ($str); 




4518




 





 





 





 





 





 



         } 




4519




 





 





 





 





 





 



         else { 




4520



  
0
  




 





 





 





 





0



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




4521




 





 





 





 





 





 



         } 




4522




 





 





 





 





 





 



     } 




4523




 





 





 





 





 





 



     else { 




4524




97





 





 





 





 





267



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




4525




97





 





 





 





 





143



         str_append_perl ($str, $q_val); 




4526




97





 





 





 





 





120



         str_append_end  ($str); 




4527




 





 





 





 





 





 



     } 




4528




 





 





 





 





 





 



 } 




4529




 





 





 





 





 





 



   




4530




 





 





 





 





 





 



 sub is_multicol($); 




4531




 





 





 





 





 





 



 sub is_multicol($) 




4532




 





 





 





 





 





 



 { 




4533




510





 





 




  
510
  



  
0
  




392



     my ($thing) = @_; 




4534




 





 





 





 





 





 



     return switch ($thing->{kind}, 




4535




 





 





 





 





 





 



         'ExprAs' => sub{ 




4536




165





 





 




  
165
  




 





222



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




4537




 





 





 





 





 





 



         }, 




4538




 





 





 





 





 





 



         'Expr' => sub { 




4539




165




  
100
  




 




  
165
  




 





277



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




4540




90





 





 





 





 





115



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




4541




 





 





 





 





 





 



             } 




4542




75





 





 





 





 





519



             return 0; 




4543




 





 





 





 





 





 



         }, 




4544




 





 





 





 





 





 



         'Column' => sub { 




4545




90





 





 




  
90
  




 





143



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




4546




 





 





 





 





 





 



         }, 




4547




 





 





 





 





 





 



         '*' => sub { 




4548




4





 





 




  
4
  




 





57



             return 1; 




4549




 





 





 





 





 





 



         }, 




4550




 





 





 





 





 





 



         'interpol' => sub { 




4551




21





 





 




  
21
  




 





273



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




4552




 





 





 





 





 





 



         }, 




4553




 





 





 





 





 





 



         -default => sub { 




4554




65





 





 




  
65
  




 





825



             return 0; 




4555




 





 





 





 





 





 



         }, 




4556




510





 





 





 





 





2840



     ); 




4557




 





 





 





 





 





 



 } 




4558




 





 





 





 





 





 



   




4559




 





 





 





 





 





 



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




4560




 





 





 





 





 





 



 my %ident_context= ( 




4561




 





 





 





 





 





 



     'Column' => { 




4562




 





 





 





 





 





 



         1 => [ 'Column' ], 




4563




 





 





 





 





 





 



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




4564




 





 





 





 





 





 



     }, 




4565




 





 





 





 





 





 



 ); 




4566




 





 





 





 





 





 



   




4567




 





 





 





 





 





 



 sub str_append_ident_chain($$$@) 




4568




 





 





 





 





 





 



 { 




4569




509





 





 




  
509
  



  
0
  




651



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




4570




509





 





 





 





 





543



     my $func= lc($family); 




4571




 





 





 





 





 





 



   




4572




509





 




  
 66
  




 





 





1580



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




4573




 





 





 





 





 





 



               (scalar(@token) == 1 ? 




4574




 





 





 





 





 





 



                   [ $family ] 




4575




 





 





 





 





 





 



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




4576




 





 





 





 





 





 



               ); 




4577




 





 





 





 





 





 



   




4578




509





 





 





 





 





567



     my $n= scalar(@token); 




4579




509





 





 





 





 





839



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




 




551





 





 





 





 





1287



   




4580




 





 





 





 





 





 



   




4581




509




  
100
  



  
100
  




 





 





1551



     if (!$in_list || 




 




 




  
100
  




 





 





 





 



   




4582




 





 





 





 





 





 



         scalar(@non_scalar_i) == 0) 




4583




 





 





 





 





 





 



     { 




4584




470





 





 





 





 





560



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




 




503





 





 





 





 





611



   




4585




 





 





 





 





 





 



         my $q_vals= join(",", 




4586




 





 





 





 





 





 



                         map 




4587




469





 





 





 





 





566



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




 




502





 





 





 





 





822



   




4588




 





 





 





 





 





 



                         0..$n-1 




4589




 





 





 





 





 





 



                     ); 




4590




469





 





 





 





 





1218



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




4591




 





 





 





 





 





 



     } 




4592




 





 





 





 





 





 



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




4593




 





 





 





 





 





 



         str_append_map ($str, 




4594




 





 





 





 





 





 



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




4595




 





 





 





 





 





 



                 join(",", 




4596




 





 





 





 





 





 



                     map { 




4597




35




  
100
  




 





 





 





102



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




 




40





 





 





 





 





146



   




4598




 





 





 





 





 





 



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




4599




 





 





 





 





 





 



                         :   '$_' 




4600




 





 





 





 





 





 



                         ) 




4601




 





 





 





 





 





 



                     } 




4602




 





 





 





 





 





 



                     0..$n-1 




4603




 





 





 





 





 





 



                 ). 




4604




 





 





 





 





 





 



             ")" 




4605




 





 





 





 





 





 



         ); 




4606




35





 





 





 





 





43



         my ($i)= @non_scalar_i; 




4607




35





 





 





 





 





79



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




4608




35





 





 





 





 





50



         str_append_end  ($str); 




4609




 





 





 





 





 





 



     } 




4610




 





 





 





 





 





 



     else { 




4611




4




  
 50
  




 





 





 





12



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




 




8





 





 





 





 





25



   




4612




 





 





 





 





 





 



         str_append_perl ($str, 




4613




 





 





 





 





 





 



             __PACKAGE__."::$f_ident(". 




4614




 





 





 





 





 





 



                 join(",", 




4615




 





 





 





 





 





 



                     map { 




4616




4




  
 50
  




 





 





 





14



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




 




8





 





 





 





 





21



   




4617




 





 





 





 





 





 



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




4618




 





 





 





 





 





 



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




4619




 





 





 





 





 





 



                         ) 




4620




 





 





 





 





 





 



                     } 




4621




 





 





 





 





 





 



                     0..$n-1 




4622




 





 





 





 





 





 



                 ). 




4623




 





 





 





 





 





 



             ")" 




4624




 





 





 





 





 





 



         ); 




4625




 





 





 





 





 





 



     } 




4626




 





 





 





 





 





 



 } 




4627




 





 





 





 





 





 



   




4628




 





 





 





 





 





 



 sub str_append_limit ($$$) 




4629




 





 





 





 





 





 



 { 




4630




106





 





 




  
106
  



  
0
  




124



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




4631




 





 





 





 





 





 



   




4632




106




  
100
  



  
 66
  




 





 





380



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




4633




5





 





 





 





 





8



         my $limit_cnt_str= 'undef'; 




4634




5




  
 50
  




 





 





 





11



         if ($limit_cnt) { 




4635




5





 





 





 





 





15



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




4636




 





 





 





 





 





 



         } 




4637




 





 





 





 





 





 



   




4638




5





 





 





 





 





29



         my $limit_offset_str= 'undef'; 




4639




5




  
100
  




 





 





 





15



         if ($limit_offset) { 




4640




3





 





 





 





 





11



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




4641




 





 





 





 





 





 



         } 




4642




 





 





 





 





 





 



   




4643




5





 





 





 





 





32



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




4644




 





 





 





 





 





 



     } 




4645




 





 





 





 





 





 



 } 




4646




 





 





 





 





 





 



   




4647




 





 





 





 





 





 



 sub str_append_parens($$$) 




4648




 





 





 





 





 





 



 { 




4649




18





 





 




  
18
  



  
0
  




21



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




4650




18




  
 50
  




 





 





 





26



     if ($in_list) { 




4651



  
0
  




 





 





 





 





0



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




4652



  
0
  




 





 





 





 





0



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




4653



  
0
  




 





 





 





 





0



         str_append_end ($str); 




4654




 





 





 





 





 





 



     } 




4655




 





 





 





 





 





 



     else { 




4656




18





 





 





 





 





26



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




4657




18





 





 





 





 





29



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




4658




18





 





 





 





 





1037



         str_append_end   ($str); 




4659




 





 





 





 





 





 



     } 




4660




 





 





 





 





 





 



 } 




4661




 





 





 





 





 





 



   




4662




 





 





 





 





 





 



 sub str_append_table_key($$$) 




4663




 





 





 





 





 





 



 { 




4664




3





 





 




  
3
  



  
0
  




5



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




4665




3





 





 





 





 





4



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




4666




3




  
 50
  




 





 





 





8



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




4667




3





 





 





 





 





4



         str_append_str   ($str, 'CONSTRAINT'); 




4668




3





 





 





 





 





7



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




4669




 





 





 





 





 





 



     } 




4670




3





 





 





 





 





95



     str_append_str  ($str, $type); 




4671




3




  
100
  




 





 





 





6



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




4672




1





 





 





 





 





252



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




4673




 





 





 





 





 





 



     } 




4674




3





 





 





 





 





8



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




4675




3





 





 





 





 





3



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




 




3





 





 





 





 





7



   




4676



  
0
  




 





 





 





 





0



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




4677




 





 





 





 





 





 



     } 




4678




3




  
100
  




 





 





 





8



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




4679




2





 





 





 





 





4



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




4680




 





 





 





 





 





 



     } 




4681




3





 





 





 





 





53



     str_append_end ($str); 




4682




 





 





 





 





 





 



 } 




4683




 





 





 





 





 





 



   




4684




 





 





 





 





 





 



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




4685




 





 





 





 





 





 



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




4686




 





 





 





 





 





 



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




4687




 





 





 





 





 





 



 # objects of the correct type. 




4688




 





 





 





 





 





 



 # 




4689




 





 





 





 





 





 



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




4690




 





 





 





 





 





 



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




4691




 





 





 





 





 





 



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




4692




 





 





 





 





 





 



 # 




4693




 





 





 





 





 





 



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




4694




 





 





 





 





 





 



 # each represent a small piece of the SQL command. 




4695




 





 





 





 





 





 



 # 




4696




 





 





 





 





 





 



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




4697




 





 





 





 





 





 



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




4698




 





 





 





 





 





 



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




4699




 





 





 





 





 





 



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




4700




 





 





 





 





 





 



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




4701




 





 





 





 





 





 



 # the code that generates a SELECT statement from scratch appends 




4702




 





 





 





 





 





 



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




4703




 





 





 





 





 





 



 # join() is generated. 




4704




 





 





 





 





 





 



 # 




4705




 





 





 





 





 





 



 sub str_append_thing($$$$) 




4706




 





 





 





 





 





 



 { 




4707




2820





 





 




  
2820
  



  
0
  




2829



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




4708




2820





 





 





 





 





6297



     local $SIG{__DIE__}= \&my_confess; 




4709




 





 





 





 





 





 



   




4710




 





 





 





 





 





 



     # simple things to append: 




4711




2820




  
100
  




 





 





 





4072



     unless (defined $thing) { 




4712




16





 





 





 





 





22



         str_append_perl ($str, 'undef'); 




4713




16





 





 





 





 





31



         return; 




4714




 





 





 





 





 





 



     } 




4715




2804




  
100
  




 





 





 





3863



     unless (ref $thing) { 




4716




380





 





 





 





 





413



         str_append_str ($str, $thing); 




4717




380





 





 





 





 





681



         return; 




4718




 





 





 





 





 





 



     } 




4719




2424




  
100
  




 





 





 





3395



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




4720




1





 





 





 





 





2



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




4721




1





 





 





 





 





3



         return; 




4722




 





 





 





 





 





 



     } 




4723




 





 





 





 





 





 



   




4724




 





 





 





 





 





 



     # normal structure: 




4725




2423





 





 





 





 





3185



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




4726




 





 





 





 





 





 



   




4727




 





 





 





 





 





 



     switch($thing->{kind}, 




4728




 





 





 





 





 





 



         'Stmt' => sub { 




4729




 





 





 





 





 





 



             switch($thing->{type}, 




4730




 





 





 





 





 





 



                 'Select' => sub { 




4731




 





 





 





 





 





 



                     # find out type name depending on number of columns: 




4732




178





 





 





 





 





165



                     my $type_name = 'SelectStmt'; 




4733




178




  
100
  




 





 





 





144



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




 




178





 





 





 





 





354



   




4734




165




  
100
  




 





 





 





275



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




4735




149





 





 





 





 





153



                             $type_name = 'SelectStmtSingle'; 




4736




 





 





 





 





 





 



                         } 




4737




 





 





 





 





 





 



                     } 




4738




 





 





 





 





 





 



   




4739




 





 





 





 





 





 



                     # generate: 




4740




178





 





 





 





 





937



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




4741




178





 





 





 





 





235



                     str_append_join ($str, never_empty => 1); 




4742




 





 





 





 





 





 



   




4743




 





 





 





 





 





 



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




4744




 





 





 





 





 





 



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




4745




178





 





 





 





 





218



                                             @{ $thing->{opt_front} } 




 




178





 





 





 





 





509



   




4746




 





 





 





 





 





 



                                   ).' ' 




4747




 





 





 





 





 





 



                     ); 




4748




 





 





 





 





 





 



   




4749




176




  
100
  




 





 





 





364



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




4750




94





 





 





 





 





128



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




4751




 





 





 





 





 





 



   




4752




94




  
 50
  




 





 





 





193



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




4753




94




  
100
  




 





 





 





150



                             if (@$x) { 




4754




4





 





 





 





 





10



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




4755




4





 





 





 





 





5



                                 for my $xi (@$x) { 




4756




5





 





 





 





 





11



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




4757




 





 





 





 





 





 



                                 } 




4758




4





 





 





 





 





7



                                 str_append_end ($str); 




4759




 





 





 





 





 





 



                             } 




4760




 





 





 





 





 





 



                         } 




4761




94




  
100
  




 





 





 





159



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




4762




44





 





 





 





 





69



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




4763




44





 





 





 





 





67



                             str_append_str   ($str, ' WHERE '); 




4764




44





 





 





 





 





81



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




4765




 





 





 





 





 





 



                         } 




4766




93




  
100
  




 





 





 





2057



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




4767




6





 





 





 





 





8



                             my $suffix= ''; 




4768




6




  
100
  




 





 





 





13



                             if ($thing->{group_by_with_rollup}) { 




4769




1





 





 





 





 





2



                                 $suffix= ' WITH ROLLUP'; 




4770




 





 





 





 





 





 



                             } 




4771




6





 





 





 





 





11



                             str_append_list ($str, $x, NO_PARENS, 




4772




 





 





 





 





 





 



                                 prefix  => ' GROUP BY ', 




4773




 





 





 





 





 





 



                                 suffix  => $suffix, 




4774




 





 





 





 





 





 



                                 result0 => '', 




4775




 





 





 





 





 





 



                             ); 




4776




 





 





 





 





 





 



                         } 




4777




93




  
100
  




 





 





 





173



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




4778




1





 





 





 





 





3



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




4779




1





 





 





 





 





2



                             str_append_str   ($str, ' HAVING '); 




4780




1





 





 





 





 





4



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




4781




 





 





 





 





 





 



                         } 




4782




93




  
100
  




 





 





 





204



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




4783




8





 





 





 





 





17



                             str_append_list ($str, $x, NO_PARENS, 




4784




 





 





 





 





 





 



                                 prefix  => ' ORDER BY ', 




4785




 





 





 





 





 





 



                                 result0 => '' 




4786




 





 





 





 





 





 



                             ); 




4787




 





 





 





 





 





 



                         } 




4788




93





 





 





 





 





168



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




4789




 





 





 





 





 





 



   




4790




93





 





 





 





 





78



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




 




93





 





 





 





 





292



   




4791




 





 





 





 





 





 



                     } 




4792




 





 





 





 





 





 



   




4793




175





 





 





 





 





244



                     str_append_end ($str); 




4794




175





 





 





 





 





207



                     str_append_end ($str); 




4795




 





 





 





 





 





 



                 }, 




4796




 





 





 





 





 





 



                 'Delete' => sub { 




4797




4





 





 





 





 





11



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




4798




4





 





 





 





 





9



                     str_append_join ($str, never_empty => 1); 




4799




 





 





 





 





 





 



   




4800




 





 





 





 





 





 



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




4801




 





 





 





 





 





 



                         prefix => 




4802




 





 





 





 





 





 



                             join(' ', 




4803




 





 





 





 





 





 



                                 'DELETE', 




4804




4





 





 





 





 





5



                                 @{ $thing->{opt_front} }, 




4805




 





 





 





 





 





 



                                 'FROM', 




4806




4





 





 





 





 





8



                                 @{ $thing->{from_opt_front} }, 




 




4





 





 





 





 





22



   




4807




 





 





 





 





 





 



                             ).' ' 




4808




 





 





 





 





 





 



                     ); 




4809




 





 





 





 





 





 



   




4810




4




  
100
  




 





 





 





11



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




4811




2





 





 





 





 





4



                         str_append_list ($str, $x, NO_PARENS, 




4812




 





 





 





 





 





 



                             prefix => ' USING ', 




4813




 





 





 





 





 





 



                             result0 => '' 




4814




 





 





 





 





 





 



                         ); 




4815




 





 





 





 





 





 



                     } 




4816




 





 





 





 





 





 



   




4817




4




  
 50
  




 





 





 





12



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




4818




4




  
100
  




 





 





 





9



                         if (@$x) { 




4819




2





 





 





 





 





7



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




4820




2





 





 





 





 





4



                             for my $xi (@$x) { 




4821




3





 





 





 





 





6



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




4822




 





 





 





 





 





 



                             } 




4823




2





 





 





 





 





4



                             str_append_end ($str); 




4824




 





 





 





 





 





 



                         } 




4825




 





 





 





 





 





 



                     } 




4826




4




  
100
  




 





 





 





11



                     if (my $x= $thing->{where}) { 




4827




3





 





 





 





 





8



                         str_target_line ($str, $x->{line}); 




4828




3





 





 





 





 





5



                         str_append_str   ($str, ' WHERE '); 




4829




3





 





 





 





 





8



                         str_append_thing ($str, $x, NOT_IN_LIST, NO_PARENS); 




4830




 





 





 





 





 





 



                     } 




4831




4




  
 50
  




 





 





 





157



                     if (my $x= $thing->{order_by}) { 




4832



  
0
  




 





 





 





 





0



                         str_append_list ($str, $x, NO_PARENS, 




4833




 





 





 





 





 





 



                             prefix  => ' ORDER BY ', 




4834




 





 





 





 





 





 



                             result0 => '' 




4835




 





 





 





 





 





 



                         ); 




4836




 





 





 





 





 





 



                     } 




4837




4





 





 





 





 





12



                     str_append_limit ($str, $thing->{limit_cnt}, $thing->{limit_offset}); 




4838




 





 





 





 





 





 



   




4839




4





 





 





 





 





8



                     str_append_end ($str); 




4840




4





 





 





 





 





5



                     str_append_end ($str); 




4841




 





 





 





 





 





 



                 }, 




4842




 





 





 





 





 





 



                 'Insert' => sub { 




4843




13





 





 





 





 





28



                     str_append_funcall ($str, __PACKAGE__.'::Stmt->obj', $in_list); 




4844




13





 





 





 





 





23



                     str_append_join ($str, never_empty => 1); 




4845




 





 





 





 





 





 



   




4846




 





 





 





 





 





 



                     str_append_str ($str, 




4847




 





 





 





 





 





 



                         join(' ', 




4848




 





 





 





 





 





 



                             'INSERT', 




4849




13





 





 





 





 





15



                             @{ $thing->{opt_front} }, 




 




13





 





 





 





 





45



   




4850




 





 





 





 





 





 



                             'INTO', 




4851




 





 





 





 





 





 



                         ).' ' 




4852




 





 





 





 





 





 



                     ); 




4853




 





 





 





 





 





 



   




4854




13





 





 





 





 





25



                     str_append_thing ($str, $thing->{into}, NOT_IN_LIST, NO_PARENS); 




4855




 





 





 





 





 





 



   




4856




13




  
100
  




 





 





 





435



                     if (my $col= $thing->{column}) { 




4857




5





 





 





 





 





12



                         str_append_list ($str, $col, NO_PARENS, prefix => ' (', suffix => ')'); 




4858




 





 





 





 





 





 



                     } 




4859




 





 





 





 





 





 



                                                  




4860




13




  
100
  




 





 





 





42



                     if (my $val= $thing->{value}) { 




 




 




  
 50
  




 





 





 





 



   




 




 




  
  0
  




 





 





 





 



   




 




 




  
  0
  




 





 





 





 



   




4861




5





 





 





 





 





10



                         str_append_str  ($str, ' VALUES '); 




4862




5





 





 





 





 





8



                         str_append_list ($str, $val, NO_PARENS); 




4863




 





 





 





 





 





 



                     } 




4864




 





 





 





 





 





 



                     elsif (my $set= $thing->{set}) { 




4865




8





 





 





 





 





18



                         str_append_funcall ($str, __PACKAGE__."::set2values", NOT_IN_LIST); 




4866




8





 





 





 





 





14



                         for my $l (@$set) { 




4867




16





 





 





 





 





28



                             str_append_thing ($str, $l, IN_LIST, NO_PARENS); 




4868




 





 





 





 





 





 



                         } 




4869




8





 





 





 





 





16



                         str_append_end ($str); 




4870




 





 





 





 





 





 



                     } 




4871




 





 





 





 





 





 



                     elsif (my $sel= $thing->{select}) { 




4872



  
0
  




 





 





 





 





0



                         str_append_str   ($str, ' '); 




4873



  
0
  




 





 





 





 





0



                         str_append_thing ($str, $sel, NOT_IN_LIST, NO_PARENS); 




4874




 





 





 





 





 





 



                     } 




4875




 





 





 





 





 





 



                     elsif ($thing->{default_values}) { 




4876



  
0
  




 





 





 





 





0



                         str_append_str ($str, ' DEFAULT VALUES'); 




4877




 





 





 





 





 





 



                     } 




4878




 





 





 





 





 





 



                     else { 




4879



  
0
  




 





 





 





 





0



                         die; 




4880




 





 





 





 





 





 



                     } 




4881




 





 





 





 





 





 



   




4882




13




  
100
  




 





 





 





38



                     if (my $x= $thing->{duplicate_update}) { 




4883




1





 





 





 





 





2



                         str_append_str  ($str, ' ON DUPLICATE KEY UPDATE '); 




4884




1





 





 





 





 





4



                         str_append_list ($str, $x, NO_PARENS, map => __PACKAGE__.'::assign($_)'); 




4885




 





 





 





 





 





 



                     } 




4886




 





 





 





 





 





 



   




4887




13





 





 





 





 





20



                     str_append_end ($str); 




4888




13





 





 





 





 





18



                     str_append_end ($str); 




4889




 





 





 





 





 





 



                 }, 




4890




 





 





 





 





 





 



                 'Update' => sub { 




4891




9





 





 





 





 





19



                     str_append_funcall ($str, __PACKAGE__.'::Stmt->obj', $in_list); 




4892




9





 





 





 





 





18



                     str_append_join ($str, never_empty => 1); 




4893




 





 





 





 





 





 



   




4894




 





 





 





 





 





 



                     str_append_list ($str, $thing->{table}, NO_PARENS, 




4895




 





 





 





 





 





 



                         prefix => join(' ', 'UPDATE', 




4896




9





 





 





 





 





14



                                             @{ $thing->{opt_front} } 




 




9





 





 





 





 





27



   




4897




 





 





 





 





 





 



                                   ).' ' 




4898




 





 





 





 





 





 



                     ); 




4899




 





 





 





 





 





 



   




4900




9




  
100
  




 





 





 





23



                     if (my $x= $thing->{from}) { 




4901




1





 





 





 





 





3



                         str_append_list ($str, $x, NO_PARENS, 




4902




 





 





 





 





 





 



                             prefix => ' FROM ', 




4903




 





 





 





 





 





 



                             result0 => '' 




4904




 





 





 





 





 





 



                         ); 




4905




 





 





 





 





 





 



                     } 




4906




9




  
 50
  




 





 





 





22



                     if (my $x= $thing->{join}) { 




4907




9




  
 50
  




 





 





 





15



                         if (@$x) { 




4908



  
0
  




 





 





 





 





0



                             str_append_map ($str, '" $_" '); 




4909



  
0
  




 





 





 





 





0



                             for my $xi (@$x) { 




4910



  
0
  




 





 





 





 





0



                                 str_append_thing ($str, $xi, IN_LIST, NO_PARENS); 




4911




 





 





 





 





 





 



                             } 




4912



  
0
  




 





 





 





 





0



                             str_append_end ($str); 




4913




 





 





 





 





 





 



                         } 




4914




 





 





 





 





 





 



                     } 




4915




9




  
 50
  




 





 





 





21



                     if (my $x= $thing->{set}) { 




4916




9





 





 





 





 





15



                         str_append_list ($str, $x, NO_PARENS, 




4917




 





 





 





 





 





 



                             prefix => ' SET ', 




4918




 





 





 





 





 





 



                             result0 => ''  # this is an error. 




4919




 





 





 





 





 





 



                         ); 




4920




 





 





 





 





 





 



                     } 




4921




9




  
 50
  




 





 





 





26



                     if (my $x= $thing->{where}) { 




4922




9





 





 





 





 





15



                         str_target_line ($str, $x->{line}); 




4923




9





 





 





 





 





13



                         str_append_str   ($str, ' WHERE '); 




4924




9





 





 





 





 





15



                         str_append_thing ($str, $x, NOT_IN_LIST, NO_PARENS); 




4925




 





 





 





 





 





 



                     } 




4926




9




  
100
  




 





 





 





384



                     if (my $x= $thing->{order_by}) { 




4927




1





 





 





 





 





3



                         str_append_list ($str, $x, NO_PARENS, 




4928




 





 





 





 





 





 



                             prefix  => ' ORDER BY ', 




4929




 





 





 





 





 





 



                             result0 => '' 




4930




 





 





 





 





 





 



                         ); 




4931




 





 





 





 





 





 



                     } 




4932




9





 





 





 





 





18



                     str_append_limit ($str, $thing->{limit_cnt}, $thing->{limit_offset}); 




4933




 





 





 





 





 





 



   




4934




9





 





 





 





 





11



                     str_append_end ($str); 




4935




9





 





 





 





 





13



                     str_append_end ($str); 




4936




 





 





 





 





 





 



                 }, 




4937




 





 





 





 





 





 



                 'CreateTable' => sub { 




4938




2





 





 





 





 





5



                     str_append_funcall ($str, __PACKAGE__.'::Stmt->obj', $in_list); 




4939




2





 





 





 





 





4



                     str_append_join ($str, never_empty => 1); 




4940




 





 





 





 





 





 



   




4941




2





 





 





 





 





7



                     str_append_str ($str, "$thing->{subtype} "); 




4942




2




  
100
  




 





 





 





6



                     if ($thing->{if_not_exists}) { 




4943




1





 





 





 





 





2



                         str_append_str ($str, 'IF NOT EXISTS '); 




4944




 





 





 





 





 





 



                     } 




4945




2





 





 





 





 





4



                     str_append_thing ($str, $thing->{table}, NOT_IN_LIST, NO_PARENS); 




4946




 





 





 





 





 





 



   




4947




 





 





 





 





 





 



                     my @tabspec= ( 




4948




2





 





 





 





 





5



                         @{ $thing->{column_def} }, 




4949




2





 





 





 





 





55



                         @{ $thing->{tabconstr} } 




 




2





 





 





 





 





5



   




4950




 





 





 





 





 





 



                     ); 




4951




2





 





 





 





 





4



                     str_append_list ($str, \@tabspec, NO_PARENS, 




4952




 





 





 





 





 





 



                         result0 => '', 




4953




 





 





 





 





 





 



                         prefix  => ' (', 




4954




 





 





 





 





 





 



                         suffix  => ')' 




4955




 





 





 





 





 





 



                     ); 




4956




 





 





 





 





 





 



   




4957




2





 





 





 





 





5



                     str_append_list ($str, $thing->{tableopt}, NO_PARENS, 




4958




 





 





 





 





 





 



                         result0 => '', 




4959




 





 





 





 





 





 



                         prefix  => ' ', 




4960




 





 





 





 





 





 



                         sep     => ' ', 




4961




 





 





 





 





 





 



                     ); 




4962




 





 





 





 





 





 



   




4963




2




  
100
  




 





 





 





5



                     if (my $x= $thing->{select}) { 




4964




1





 





 





 





 





2



                         str_append_str   ($str, ' AS '); 




4965




1





 





 





 





 





3



                         str_append_thing ($str, $x, NOT_IN_LIST, NO_PARENS); 




4966




 





 





 





 





 





 



                     } 




4967




 





 





 





 





 





 



   




4968




2





 





 





 





 





85



                     str_append_end ($str); 




4969




2





 





 





 





 





3



                     str_append_end ($str); 




4970




 





 





 





 





 





 



                 }, 




4971




 





 





 





 





 





 



                 'DropTable' => sub { 




4972




1





 





 





 





 





3



                     str_append_funcall ($str, __PACKAGE__.'::Stmt->obj', $in_list); 




4973




1





 





 





 





 





3



                     str_append_join ($str, never_empty => 1); 




4974




 





 





 





 





 





 



   




4975




1





 





 





 





 





3



                     str_append_str ($str, "$thing->{subtype} "); 




4976




1




  
 50
  




 





 





 





3



                     if ($thing->{if_exists}) { 




4977




1





 





 





 





 





2



                         str_append_str ($str, 'IF EXISTS '); 




4978




 





 





 





 





 





 



                     } 




4979




1





 





 





 





 





3



                     str_append_list ($str, $thing->{table}, NO_PARENS); 




4980




 





 





 





 





 





 



   




4981




1




  
 50
  




 





 





 





3



                     if (my $x= $thing->{cascade}) { 




4982




1





 





 





 





 





3



                         str_append_str ($str, " $x"); 




4983




 





 





 





 





 





 



                     } 




4984




1





 





 





 





 





2



                     str_append_end ($str); 




4985




1





 





 





 





 





2



                     str_append_end ($str); 




4986




 





 





 





 





 





 



                 }, 




4987




 





 





 





 





 





 



                 'AlterTable' => sub { 




4988




20





 





 





 





 





36



                     str_append_funcall ($str, __PACKAGE__.'::Stmt->obj', $in_list); 




4989




20





 





 





 





 





31



                     str_append_join ($str, never_empty => 1); 




4990




 





 





 





 





 





 



   




4991




20





 





 





 





 





44



                     str_append_str ($str, "$thing->{subtype} "); 




4992




20




  
 50
  




 





 





 





39



                     if ($thing->{only}) { 




4993



  
0
  




 





 





 





 





0



                         str_append_str ($str, 'ONLY '); 




4994




 





 





 





 





 





 



                     } 




4995




20





 





 





 





 





32



                     str_append_thing ($str, $thing->{table}, NOT_IN_LIST, NO_PARENS); 




4996




 





 





 





 





 





 



   




4997




20





 





 





 





 





541



                     str_append_join ($str, sep => ' ', prefix => ' '); 




4998




20





 





 





 





 





23



                     for my $l ($thing->{functor}, @{ $thing->{arg} }) { 




 




20





 





 





 





 





32



   




4999




61





 





 





 





 





81



                         str_append_thing ($str, $l, NOT_IN_LIST, NO_PARENS); 




5000




 





 





 





 





 





 



                     } 




5001




20





 





 





 





 





30



                     str_append_end ($str); 




5002




 





 





 





 





 





 



   




5003




20





 





 





 





 





22



                     str_append_end ($str); 




5004




20





 





 





 





 





22



                     str_append_end ($str); 




5005




 





 





 





 





 





 



                 }, 




5006




 





 





 





 





 





 



                 'Interpol' => sub { 




5007




3





 





 





 





 





8



                     str_append_typed ($str, 'stmt', 'Stmt', $thing, $in_list); 




5008




 





 





 





 





 





 



                 }, 




5009




230





 





 




  
141
  




 





2451



             ); 




5010




 





 





 





 





 





 



         }, 




5011




 





 





 





 





 





 



   




5012




 





 





 





 





 





 



         'TableOption' => sub { 




5013




 





 





 





 





 





 



             switch ($thing->{type}, 




5014




 





 





 





 





 





 



                'interpol' => sub { 




5015




2





 





 





 





 





5



                     str_append_typed ($str, 'tableopt', 'TableOption', $thing, $in_list); 




5016




 





 





 





 





 





 



                }, 




5017




 





 





 





 





 





 



                'literal' => sub { 




5018




6





 





 





 





 





11



                     str_append_join  ($str, sep => ' '); 




5019




6





 





 





 





 





10



                     str_append_str   ($str, $thing->{name}); 




5020




6





 





 





 





 





12



                     str_append_thing ($str, $thing->{value}, NOT_IN_LIST, NO_PARENS); 




5021




6





 





 





 





 





186



                     str_append_end   ($str); 




5022




 





 





 





 





 





 



                } 




5023




8





 





 




  
3
  




 





30



             ); 




5024




 





 





 





 





 





 



         }, 




5025




 





 





 





 





 





 



   




5026




 





 





 





 





 





 



         'Keyword' => sub { 




5027




1





 





 




  
0
  




 





2



             str_append_str ($str, $thing->{keyword}); 




5028




 





 





 





 





 





 



         }, 




5029




 





 





 





 





 





 



   




5030




 





 





 





 





 





 



         'Join' => sub { 




5031




15




  
100
  




 




  
9
  




 





26



             if ($thing->{type} eq 'interpol') { 




5032




5





 





 





 





 





10



                 str_append_typed ($str, 'joinclause', 'Join', $thing, $in_list); 




5033




 





 





 





 





 





 



             } 




5034




 





 





 





 





 





 



             else { 




5035




10





 





 





 





 





19



                 str_append_join ($str, result0 => ''); 




5036




 





 





 





 





 





 



   




5037




10




  
100
  




 





 





 





47



                 if ($thing->{natural}) { 




5038




3




  
 50
  




 





 





 





6



                     if ($thing->{type} eq 'INNER') { 




5039




3





 





 





 





 





8



                         str_append_str ($str, "NATURAL JOIN "); 




5040




 





 





 





 





 





 



                     } 




5041




 





 





 





 





 





 



                     else { 




5042



  
0
  




 





 





 





 





0



                         str_append_str ($str, "NATURAL $thing->{type} JOIN "); 




5043




 





 





 





 





 





 



                     } 




5044




 





 





 





 





 





 



                 } 




5045




 





 





 





 





 





 



                 else { 




5046




7





 





 





 





 





17



                     str_append_str ($str, "$thing->{type} JOIN "); 




5047




 





 





 





 





 





 



                 } 




5048




 





 





 





 





 





 



   




5049




10





 





 





 





 





18



                 str_append_list ($str, $thing->{table}, NO_PARENS); 




5050




 





 





 





 





 





 



   




5051




10




  
100
  




 





 





 





29



                 if (my $on= $thing->{on}) { 




 




 




  
100
  




 





 





 





 



   




5052




3





 





 





 





 





7



                     str_append_str ($str, ' ON '); 




5053




3





 





 





 





 





6



                     str_append_thing ($str, $on, NOT_IN_LIST, NO_PARENS); 




5054




 





 





 





 





 





 



                 } 




5055




 





 





 





 





 





 



                 elsif (my $using= $thing->{using}) { 




5056




2





 





 





 





 





4



                     str_append_str  ($str, ' USING ('); 




5057




2





 





 





 





 





4



                     str_append_list ($str, $using, NO_PARENS); 




5058




2





 





 





 





 





3



                     str_append_str  ($str, ')'); 




5059




 





 





 





 





 





 



                 }; 




5060




 





 





 





 





 





 



   




5061




10





 





 





 





 





151



                 str_append_end ($str); 




5062




 





 





 





 





 





 



             } 




5063




 





 





 





 





 





 



         }, 




5064




 





 





 





 





 





 



   




5065




 





 





 





 





 





 



         'Table' => 'Column', 




5066




 





 





 





 





 





 



         'CharSet' => 'Column', 




5067




 





 





 





 





 





 



         'Collate' => 'Column', 




5068




 





 





 





 





 





 



         'Index' => 'Column', 




5069




 





 





 





 





 





 



         'Constraint' => 'Column', 




5070




 





 





 





 





 





 



         'Transliteration' => 'Column', 




5071




 





 





 





 





 





 



         'Transcoding' => 'Column', 




5072




 





 





 





 





 





 



         'Engine' => 'Column', 




5073




 





 





 





 





 





 



         'Column' => sub { 




5074




509





 





 




  
355
  




 





442



             str_append_ident_chain ($str, $in_list, $thing->{kind}, @{ $thing->{ident_chain} }); 




 




509





 





 





 





 





1025



   




5075




 





 





 





 





 





 



         }, 




5076




 





 





 





 





 





 



   




5077




 





 





 





 





 





 



         'TableAs' => sub { 




5078




122




  
100
  




 




  
102
  




 





196



             if (my $x= $thing->{as}) { 




5079




 





 





 





 





 





 



                 # Oracle does not allows AS in table aliases.  But this module 




5080




 





 





 





 





 





 



                 # does not allow leaving it out.  To avoid generating what 




5081




 





 





 





 





 





 



                 # this module cannot read back in the default case, check for 




5082




 





 





 





 





 





 



                 # the write dialect. 




5083




3




  
 50
  




 





 





 





8



                 if ($write_dialect eq 'oracle') { 




5084



  
0
  




 





 





 





 





0



                     str_append_join  ($str, sep => ' ', never_empty => 1); 




5085




 





 





 





 





 





 



                 } 




5086




 





 





 





 





 





 



                 else { 




5087




3





 





 





 





 





6



                     str_append_join  ($str, sep => ' AS ', never_empty => 1); 




5088




 





 





 





 





 





 



                 } 




5089




3





 





 





 





 





9



                 str_append_thing ($str, $thing->{table}, NOT_IN_LIST, NO_PARENS); 




5090




3





 





 





 





 





90



                 str_append_thing ($str, $x, NOT_IN_LIST, NO_PARENS); 




5091




3





 





 





 





 





79



                 str_append_end   ($str); 




5092




 





 





 





 





 





 



             } 




5093




 





 





 





 





 





 



             else { 




5094




119





 





 





 





 





178



                 str_append_thing ($str, $thing->{table}, $in_list, NO_PARENS); 




5095




 





 





 





 





 





 



             } 




5096




 





 





 





 





 





 



         }, 




5097




 





 





 





 





 





 



   




5098




 





 





 





 





 





 



         'ExprAs' => sub { 




5099




224




  
100
  




 




  
123
  




 





335



             if (my $x= $thing->{as}) { 




5100




4





 





 





 





 





9



                 str_append_join  ($str, sep => ' AS ', never_empty => 1); 




5101




4





 





 





 





 





8



                 str_append_thing ($str, $thing->{expr}, NOT_IN_LIST, NO_PARENS); 




5102




3





 





 





 





 





211



                 str_append_thing ($str, $x, NOT_IN_LIST, NO_PARENS); 




5103




3





 





 





 





 





80



                 str_append_end   ($str); 




5104




 





 





 





 





 





 



             } 




5105




 





 





 





 





 





 



             else { 




5106




220





 





 





 





 





322



                 str_append_thing ($str, $thing->{expr}, $in_list, $parens); 




5107




 





 





 





 





 





 



             } 




5108




 





 





 





 





 





 



         }, 




5109




 





 





 





 





 





 



         'Order' => sub { 




5110




 





 





 





 





 





 



             switch($thing->{type}, 




5111




 





 





 





 





 





 



                 'interpol' => sub { 




5112




18




  
100
  




 





 





 





33



                     if ($thing->{desc}) { 




5113




5





 





 





 





 





9



                         str_append_typed ($str, 'desc', 'Order', $thing, $in_list, hashkeys => 1); 




5114




 





 





 





 





 





 



                     } 




5115




 





 





 





 





 





 



                     else { 




5116




13





 





 





 





 





22



                         str_append_typed ($str, 'asc', 'Order', $thing, $in_list, hashkeys => 1); 




5117




 





 





 





 





 





 



                     } 




5118




 





 





 





 





 





 



                 }, 




5119




 





 





 





 





 





 



                 'expr' => sub { 




5120




17




  
100
  




 





 





 





34



                     if ($thing->{desc}) { 




5121




5





 





 





 





 





11



                         str_append_map   ($str, __PACKAGE__.'::desc($_)'); 




5122




5





 





 





 





 





10



                         str_append_thing ($str, $thing->{expr}, $in_list, NO_PARENS); 




5123




5





 





 





 





 





379



                         str_append_end   ($str); 




5124




 





 





 





 





 





 



                     } 




5125




 





 





 





 





 





 



                     else { 




5126




12





 





 





 





 





22



                         str_append_thing ($str, $thing->{expr}, $in_list, NO_PARENS); 




5127




 





 





 





 





 





 



                     } 




5128




 





 





 





 





 





 



                 }, 




5129




35





 





 




  
17
  




 





132



             ); 




5130




 





 





 





 





 





 



         }, 




5131




 





 





 





 





 





 



         'TypeList' => sub { 




5132




 





 





 





 





 





 



             switch($thing->{type}, 




5133




 





 





 





 





 





 



                 'interpol' => sub { 




5134



  
0
  




 





 





 





 





0



                     str_append_typed ($str, 'typelist', 'Type', $thing, $in_list); 




5135




 





 





 





 





 





 



                 }, 




5136




 





 





 





 





 





 



   




5137




 





 





 





 





 





 



                 'explicit' => sub { 




5138




1





 





 





 





 





4



                     str_append_list ($str, $thing->{arg}, NO_PARENS, prefix => '(', suffix => ')'); 




5139




 





 





 





 





 





 



                         # may not be empty! 




5140




 





 





 





 





 





 



                 }, 




5141




1





 





 




  
0
  




 





5



             ); 




5142




 





 





 





 





 





 



         }, 




5143




 





 





 





 





 





 



         'Type' => sub { 




5144




 





 





 





 





 





 



             switch ($thing->{type}, 




5145




 





 





 





 





 





 



                 'interpol' => sub { 




5146




8





 





 





 





 





12



                     str_append_typed ($str, 'type', 'Type', $thing, $in_list); 




5147




 





 





 





 





 





 



                 }, 




5148




 





 





 





 





 





 



                 'base' => sub { 




5149




22





 





 





 





 





38



                     str_append_perl ($str, __PACKAGE__.'::Type->new()'); 




5150




 





 





 





 





 





 



                 }, 




5151




30





 





 




  
15
  




 





99



             ); 




5152




 





 





 





 





 





 



         }, 




5153




 





 





 





 





 





 



         'TypePost' => sub { 




5154




56




  
 50
  




 




  
23
  




 





80



             return str_append_parens ($str, $thing, NOT_IN_LIST) 




5155




 





 





 





 





 





 



                 if $parens; 




5156




 





 





 





 





 





 



   




5157




56





 





 





 





 





136



             str_append_funcall_begin ($str, __PACKAGE__.'::type_'.$thing->{functor}, $in_list); 




5158




56





 





 





 





 





43



             for my $arg (@{ $thing->{arg} }) { 




 




56





 





 





 





 





99



   




5159




68





 





 





 





 





108



                 str_append_thing ($str, $arg, NOT_IN_LIST, NO_PARENS); 




5160




 





 





 





 





 





 



             } 




5161




56





 





 





 





 





81



             str_append_funcall_end ($str, $in_list); 




5162




56





 





 





 





 





80



             str_append_thing ($str, $thing->{base}, $in_list, NO_PARENS); 




5163




56





 





 





 





 





1375



             str_append_end ($str); 




5164




 





 





 





 





 





 



         }, 




5165




 





 





 





 





 





 



         'ColumnDef' => sub { 




5166




6





 





 




  
1
  




 





11



             str_append_join  ($str, sep => ' '); 




5167




6





 





 





 





 





12



             str_append_thing ($str, $thing->{name},        NOT_IN_LIST, NO_PARENS); 




5168




6





 





 





 





 





164



             str_append_thing ($str, $thing->{column_spec}, NOT_IN_LIST, NO_PARENS); 




5169




6





 





 





 





 





145



             str_append_end   ($str); 




5170




 





 





 





 





 





 



         }, 




5171




 





 





 





 





 





 



   




5172




 





 





 





 





 





 



         'ColumnSpec' => sub { 




5173




 





 





 





 





 





 



             switch ($thing->{type}, 




5174




 





 





 





 





 





 



                 'interpol' => sub { 




5175




7





 





 





 





 





11



                     str_append_typed ($str, 'colspec', 'ColumnSpec', $thing, $in_list); 




5176




 





 





 





 





 





 



                 }, 




5177




 





 





 





 





 





 



                 'base' => sub { 




5178




9





 





 





 





 





20



                     str_append_funcall ($str, __PACKAGE__.'::ColumnSpec->new', $in_list); 




5179




9





 





 





 





 





17



                     str_append_thing ($str, $thing->{datatype}, $in_list, NO_PARENS); 




5180




9





 





 





 





 





210



                     str_append_end ($str); 




5181




 





 





 





 





 





 



                 } 




5182




16





 





 




  
4
  




 





65



             ); 




5183




 





 





 





 





 





 



         }, 




5184




 





 





 





 





 





 



         'ColumnSpecPost' => sub { 




5185




22




  
 50
  




 




  
4
  




 





31



             return str_append_parens ($str, $thing, NOT_IN_LIST) 




5186




 





 





 





 





 





 



                 if $parens; 




5187




 





 





 





 





 





 



   




5188




22





 





 





 





 





60



             str_append_funcall_begin ($str, __PACKAGE__.'::colspec_'.$thing->{functor}, $in_list); 




5189




22





 





 





 





 





16



             for my $arg (@{ $thing->{arg} }) { 




 




22





 





 





 





 





42



   




5190




61





 





 





 





 





76



                 str_append_thing ($str, $arg, NOT_IN_LIST, NO_PARENS); 




5191




 





 





 





 





 





 



             } 




5192




22





 





 





 





 





33



             str_append_funcall_end ($str, $in_list); 




5193




22





 





 





 





 





29



             str_append_thing ($str, $thing->{base}, $in_list, NO_PARENS); 




5194




22





 





 





 





 





514



             str_append_end ($str); 




5195




 





 





 





 





 





 



         }, 




5196




 





 





 





 





 





 



   




5197




 





 





 





 





 





 



         'TableConstraint' => sub { 




5198




 





 





 





 





 





 



             switch($thing->{type}, 




5199




 





 





 





 





 





 



                 'primary_key' => sub { 




5200



  
0
  




 





 





 





 





0



                     str_append_table_key ($str, $thing, 'PRIMARY KEY'); 




5201




 





 





 





 





 





 



                 }, 




5202




 





 





 





 





 





 



                 'unique' => sub { 




5203




1





 





 





 





 





4



                     str_append_table_key ($str, $thing, 'UNIQUE'); 




5204




 





 





 





 





 





 



                 }, 




5205




 





 





 





 





 





 



                 'fulltext' => sub { 




5206



  
0
  




 





 





 





 





0



                     str_append_table_key ($str, $thing, 'FULLTEXT'); 




5207




 





 





 





 





 





 



                 }, 




5208




 





 





 





 





 





 



                 'spatial' => sub { 




5209



  
0
  




 





 





 





 





0



                     str_append_table_key ($str, $thing, 'SPATIAL'); 




5210




 





 





 





 





 





 



                 }, 




5211




 





 





 





 





 





 



                 'index' => sub { 




5212



  
0
  




 





 





 





 





0



                     str_append_table_key ($str, $thing, 'INDEX'); 




5213




 





 





 





 





 





 



                 }, 




5214




 





 





 





 





 





 



                 'foreign_key' => sub { 




5215




2





 





 





 





 





3



                     str_append_table_key ($str, $thing, 'FOREIGN KEY'); 




5216




 





 





 





 





 





 



                 }, 




5217




3





 





 




  
0
  




 





19



             ); 




5218




 





 





 





 





 





 



         }, 




5219




 





 





 





 





 





 



   




5220




 





 





 





 





 





 



         'IndexOption' => sub { 




5221




 





 





 





 





 





 



             switch($thing->{type}, 




5222




 





 





 





 





 





 



                 'using' => sub { 




5223



  
0
  




 





 





 





 





0



                     str_append_str ($str, "USING $thing->{arg}"); 




5224




 





 





 





 





 





 



                 } 




5225



  
0
  




 





 




  
0
  




 





0



             ); 




5226




 





 





 





 





 





 



         }, 




5227




 





 





 





 





 





 



   




5228




 





 





 





 





 





 



         'References' => sub { 




5229




 





 





 





 





 





 



             # table column match on_delete on_update)); 




5230




 





 





 





 





 





 



             str_append_join  ($str, sep => ' ', 




5231




 





 





 





 





 





 



                 prefix => 'REFERENCES ', 




5232




 





 





 





 





 





 



                 suffix => 




5233




4





 





 





 





 





8



                     join('', map { " $_" } 




5234




 





 





 





 





 





 



                         ($thing->{match} ? 




5235




 





 





 





 





 





 



                             ('MATCH', $thing->{match}) 




5236




 





 





 





 





 





 



                         :   () 




5237




 





 





 





 





 





 



                         ), 




5238




 





 





 





 





 





 



                         ($thing->{on_delete} ? 




5239




 





 





 





 





 





 



                             ('ON DELETE', $thing->{on_delete}) 




5240




 





 





 





 





 





 



                         :   () 




5241




 





 





 





 





 





 



                         ), 




5242




 





 





 





 





 





 



                         ($thing->{on_update} ? 




5243




 





 





 





 





 





 



                             ('ON UPDATE', $thing->{on_update}) 




5244




3




  
100
  




 




  
0
  




 





15



                         :   () 




 




 




  
100
  




 





 





 





 



   




 




 




  
 50
  




 





 





 





 



   




5245




 





 





 





 





 





 



                         ), 




5246




 





 





 





 





 





 



                     ) 




5247




 





 





 





 





 





 



             ); 




5248




3





 





 





 





 





7



             str_append_thing ($str, $thing->{table}, NOT_IN_LIST, NO_PARENS); 




5249




3





 





 





 





 





79



             str_append_list  ($str, $thing->{column}, NO_PARENS, 




5250




 





 





 





 





 





 



                  prefix => '(', suffix => ')', result0 => ''); 




5251




3





 





 





 





 





5



             str_append_end   ($str); 




5252




 





 





 





 





 





 



         }, 




5253




 





 





 





 





 





 



   




5254




 





 





 





 





 





 



         'CharUnit' => sub { 




5255




1





 





 




  
0
  




 





2



             str_append_str ($str, $thing->{name}); 




5256




 





 





 





 





 





 



         }, 




5257




 





 





 





 





 





 



   




5258




 





 





 





 





 





 



         'ExprList' => sub { 




5259




 





 





 





 





 





 



             switch($thing->{type}, 




5260




 





 





 





 





 





 



                 'interpol' => sub { 




5261




5





 





 





 





 





12



                     str_append_typed ($str, 'exprlist', 'Expr', $thing, $in_list); 




5262




 





 





 





 





 





 



                 }, 




5263




 





 





 





 





 





 



   




5264




 





 





 





 





 





 



                 'explicit' => sub { 




5265




6





 





 





 





 





17



                     str_append_list ($str, $thing->{arg}, NO_PARENS, prefix => '(', suffix => ')'); 




5266




 





 





 





 





 





 



                         # may not be empty! 




5267




 





 





 





 





 





 



                 }, 




5268




11





 





 




  
8
  




 





35



             ); 




5269




 





 





 





 





 





 



         }, 




5270




 





 





 





 





 





 



         'ExprEmpty' => sub { 




5271




 





 





 





 





 





 



             # Append an empty string.  Must have an operand here, otherwise 




5272




 





 





 





 





 





 



             # parameters might get mixed up. 




5273




18





 





 




  
10
  




 





30



             str_append_str($str, ''); 




5274




 





 





 





 





 





 



         }, 




5275




 





 





 





 





 





 



         'Check' => sub { 




5276




9





 





 




  
9
  




 





17



             str_append_join  ($str, joinfunc => __PACKAGE__.'::Check->obj'); 




5277




9





 





 





 





 





20



             str_append_thing ($str, $thing->{expr}, NOT_IN_LIST, NO_PARENS); 




5278




9





 





 





 





 





416



             str_append_end   ($str); 




5279




 





 





 





 





 





 



         }, 




5280




 





 





 





 





 





 



         'Expr' => sub { 




5281




 





 





 





 





 





 



             switch($thing->{type}, 




5282




 





 





 





 





 





 



                 'limit' => sub { 




5283




24





 





 





 





 





58



                     my $limit_cnt_str= perl_val($thing->{arg}, 'Expr', 




5284




 





 





 





 





 





 



                                              ['interpol', 'interpolExpr', '?']); 




5285




24





 





 





 





 





194



                     str_append_perl ($str, __PACKAGE__."::limit_number($limit_cnt_str)"); 




5286




 





 





 





 





 





 



                 }, 




5287




 





 





 





 





 





 



                 'interpol' => sub { 




5288




 





 





 





 





 





 



                     my $func= $thing->{maybe_check} ? 




5289




 





 





 





 





 





 



                                    'expr_or_check' 




5290




 





 





 





 





 





 



                               : ($thing->{token}{type} eq 'num' || 




5291




375




  
100
  



  
100
  




 





 





1733



                                  $thing->{token}{type} eq 'string' || 




 




 




  
100
  




 





 





 





 



   




5292




 





 





 





 





 





 



                                  !$parens) ? 




5293




 





 





 





 





 





 



                                    'expr' 




5294




 





 





 





 





 





 



                               :    'exprparen'; 




5295




375





 





 





 





 





690



                     str_append_typed ($str, $func, 'Expr', $thing, $in_list, hash => 1); 




5296




 





 





 





 





 





 



                 }, 




5297




 





 





 





 





 





 



                 'column' => sub { 




5298




314





 





 





 





 





502



                     str_append_thing ($str, $thing->{arg}, $in_list, NO_PARENS); 




5299




 





 





 





 





 





 



                 }, 




5300




 





 





 





 





 





 



                 '()' => sub { 




5301




11





 





 





 





 





22



                     str_append_thing ($str, $thing->{arg}, $in_list, PARENS); 




5302




 





 





 





 





 





 



                 }, 




5303




 





 





 





 





 





 



                 'subquery' => sub { 




5304




6





 





 





 





 





10



                     str_append_funcall ($str, __PACKAGE__.'::subquery', $in_list); 




5305




6





 





 





 





 





10



                     str_append_thing ($str, $thing->{arg}, $in_list, NO_PARENS); 




5306




6





 





 





 





 





317



                     str_append_end   ($str); 




5307




 





 





 





 





 





 



                 }, 




5308




 





 





 





 





 





 



                 'prefix1' => sub { 




5309




2





 





 





 





 





4



                     $in_list= NOT_IN_LIST; # just to be sure 




5310




2




  
 50
  




 





 





 





5



                     return str_append_parens ($str, $thing, NOT_IN_LIST) 




5311




 





 





 





 





 





 



                         if $parens; 




5312




2




  
 50
  




 





 





 





2



                     die 'Expected exactly 1 argument' unless scalar(@{ $thing->{arg} }) == 1; 




 




2





 





 





 





 





6



   




5313




 





 





 





 





 





 



   




5314




2





 





 





 





 





8



                     str_append_join ($str, 




5315




 





 





 





 





 





 



                         prefix => "$thing->{functor}{value} ", 




5316




 





 





 





 





 





 



                         never_empty => 1 




5317




 





 





 





 





 





 



                     ); 




5318




2





 





 





 





 





6



                     str_append_thing ($str, $thing->{arg}[0], NOT_IN_LIST, PARENS); 




5319




1





 





 





 





 





54



                     str_append_end ($str); 




5320




 





 





 





 





 





 



                 }, 




5321




 





 





 





 





 





 



                 'prefixn' => sub { 




5322




1





 





 





 





 





2



                     $parens= NO_PARENS; # just to be sure 




5323




1




  
 50
  




 





 





 





1



                     die 'Expected exactly 1 argument' unless scalar(@{ $thing->{arg} }) == 1; 




 




1





 





 





 





 





4



   




5324




 





 





 





 





 





 



   




5325




1




  
 50
  




 





 





 





2



                     if ($in_list) { 




5326



  
0
  




 





 





 





 





0



                         str_append_map ($str, "'$thing->{functor}{value} '.(\$_)"); 




5327




 





 





 





 





 





 



                     } 




5328




 





 





 





 





 





 



                     else { 




5329




1





 





 





 





 





3



                         str_append_join ($str, 




5330




 





 





 





 





 





 



                             prefix => "$thing->{functor}{value} ", 




5331




 





 





 





 





 





 



                             never_empty => 1 




5332




 





 





 





 





 





 



                         ); 




5333




 





 





 





 





 





 



                     } 




5334




1





 





 





 





 





4



                     str_append_thing ($str, $thing->{arg}[0], $in_list, PARENS); 




5335




1





 





 





 





 





41



                     str_append_end ($str); 




5336




 





 





 





 





 





 



                 }, 




5337




 





 





 





 





 





 



   




5338




 





 





 





 





 





 



                 'infix2' => sub { 




5339




89





 





 





 





 





80



                     $in_list= NOT_IN_LIST; # just to be sure 




5340




89




  
100
  




 





 





 





152



                     return str_append_parens ($str, $thing, NOT_IN_LIST) 




5341




 





 





 





 





 





 



                         if $parens; 




5342




 





 





 





 





 





 



   




5343




85





 





 





 





 





91



                     my $f= $thing->{functor}; 




5344




85





 





 





 





 





174



                     str_append_join  ($str, joinfunc => __PACKAGE__.'::Infix->obj'); 




5345




85





 





 





 





 





225



                     str_append_str   ($str, $thing->{functor}{value}); 




5346




85





 





 





 





 





182



                     str_append_thing ($str, $thing->{arg}[0], NOT_IN_LIST, PARENS); 




5347




85





 





 





 





 





5586



                     str_append_thing ($str, $thing->{arg}[1], NOT_IN_LIST, PARENS); 




5348




85





 





 





 





 





3916



                     str_append_end   ($str); 




5349




 





 





 





 





 





 



                 }, 




5350




 





 





 





 





 





 



   




5351




 





 





 





 





 





 



                 'infix23' => 'infix3', 




5352




 





 





 





 





 





 



                 'infix3' => sub { 




5353




5





 





 





 





 





7



                     $in_list= NOT_IN_LIST; # just to be sure 




5354




5




  
100
  




 





 





 





14



                     return str_append_parens ($str, $thing, NOT_IN_LIST) 




5355




 





 





 





 





 





 



                         if $parens; 




5356




 





 





 





 





 





 



   




5357




4





 





 





 





 





8



                     my $f= $thing->{functor}; 




5358




4





 





 





 





 





8



                     str_append_join  ($str, never_empty => 1); 




5359




4





 





 





 





 





13



                     str_append_thing ($str, $thing->{arg}[0], NOT_IN_LIST, PARENS); 




5360




4





 





 





 





 





355



                     str_append_str   ($str, " $thing->{functor}{value} "); 




5361




4





 





 





 





 





59



                     str_append_thing ($str, $thing->{arg}[1], NOT_IN_LIST, PARENS); 




5362




4




  
100
  




 





 





 





265



                     if (scalar(@{ $thing->{arg} }) == 3) { 




 




4





 





 





 





 





17



   




5363




2





 





 





 





 





6



                         str_append_str   ($str, " $thing->{functor}{value2} "); 




5364




2





 





 





 





 





4



                         str_append_thing ($str, $thing->{arg}[2], NOT_IN_LIST, PARENS); 




5365




 





 





 





 





 





 



                     } 




5366




4





 





 





 





 





129



                     str_append_end   ($str); 




5367




 





 





 





 





 





 



                 }, 




5368




 





 





 





 





 





 



   




5369




 





 





 





 





 





 



                 # prefix and suffix allow bitwise application: 




5370




 





 





 





 





 





 



                 # Currently not supported via _prefix() and _suffix() helper 




5371




 





 





 





 





 





 



                 # functions, but may be later.  (Needs only a little rewrite 




5372




 





 





 





 





 





 



                 # here.  The helper functions don't need to be changed.) 




5373




 





 





 





 





 





 



                 'prefix()' => 'prefix', 




5374




 





 





 





 





 





 



                 'suffix' => 'prefix', 




5375




 





 





 





 





 





 



                 'prefix' => sub { 




5376




63




  
100
  




 





 





 





112



                     if ($thing->{type} eq 'prefix()') { # for AND() and OR() as functors 




5377




20





 





 





 





 





21



                         $in_list = NOT_IN_LIST; 




5378




 





 





 





 





 





 



                     } 




5379




63





 





 





 





 





68



                     my $f= $thing->{functor}; 




5380




63




  
 50
  



  
 50
  




 





 





213



                     my $fk= $functor_kind{$f->{type} || ''} 




5381




 





 





 





 





 





 



                             or die "Expected $thing->{type} to be mapped by \%functor_kind"; 




5382




63




  
100
  




 





 





 





76



                     if ($in_list) { 




5383




27





 





 





 





 





43



                         my $qt= quote_perl($f->{value}); 




5384




27




  
100
  




 





 





 





101



                         str_append_map ($str, __PACKAGE__."::_".$fk."($qt,".($parens?1:0).",\$_)"); 




5385




27





 





 





 





 





24



                         for my $l (@{ $thing->{arg} }) { 




 




27





 





 





 





 





44



   




5386




35





 





 





 





 





63



                             str_append_thing ($str, $l, IN_LIST, PARENS); 




5387




 





 





 





 





 





 



                         } 




5388




27





 





 





 





 





49



                         str_append_end ($str); 




5389




 





 





 





 





 





 



                     } 




5390




 





 





 





 





 





 



                     else { 




5391




36





 





 





 





 





78



                         str_append_funcall($str, __PACKAGE__."::_".$fk, NOT_IN_LIST); 




5392




36





 





 





 





 





59



                         str_append_thing ($str, $f->{value}, IN_LIST, NO_PARENS); 




5393




36




  
100
  




 





 





 





64



                         str_append_thing ($str, $parens?1:0, IN_LIST, NO_PARENS); 




5394




36





 





 





 





 





27



                         for my $l (@{ $thing->{arg} }) { 




 




36





 





 





 





 





66



   




5395




46





 





 





 





 





65



                             str_append_thing ($str, $l, IN_LIST, PARENS); 




5396




 





 





 





 





 





 



                         } 




5397




36





 





 





 





 





65



                         str_append_end ($str); 




5398




 





 





 





 





 





 



                     } 




5399




 





 





 





 





 





 



                 }, 




5400




 





 





 





 





 





 



   




5401




 





 





 





 





 





 



                 # funcall and infix use args inline if they are in list context. 




5402




 





 





 





 





 





 



                 # They are handled by _prefix() and _suffix() helper functions in order 




5403




 





 





 





 





 





 



                 # to allow dialect conversion: 




5404




 





 





 





 





 





 



                 'funcall' => 'infix()', 




5405




 





 





 





 





 





 



                 'infix()' => sub { 




5406




95





 





 





 





 





87



                     $in_list= NOT_IN_LIST; # just to be sure 




5407




95





 





 





 





 





98



                     my $f= $thing->{functor}; 




5408




95




  
 50
  



  
 50
  




 





 





292



                     my $fk= $functor_kind{$f->{type} || ''} 




5409




 





 





 





 





 





 



                             or die 'Expected $thing->{type} to be mapped by %functor_kind'; 




5410




 





 





 





 





 





 



   




5411




95





 





 





 





 





216



                     str_append_funcall($str, __PACKAGE__."::_".$fk, NOT_IN_LIST); 




5412




95





 





 





 





 





175



                     str_append_thing ($str, $f->{value}, IN_LIST, NO_PARENS); 




5413




95




  
100
  




 





 





 





177



                     str_append_thing ($str, $parens?1:0, IN_LIST, NO_PARENS); 




5414




95





 





 





 





 





61



                     for my $l (@{ $thing->{arg} }) { 




 




95





 





 





 





 





186



   




5415




185





 





 





 





 





280



                         str_append_thing ($str, $l, IN_LIST, PARENS); 




5416




 





 





 





 





 





 



                     } 




5417




95





 





 





 





 





186



                     str_append_end ($str); 




5418




 





 





 





 





 





 



                 }, 




5419




 





 





 





 





 





 



   




5420




 





 





 





 





 





 



                 'funcsep' => sub { 




5421




6





 





 





 





 





6



                     $in_list= NOT_IN_LIST; # just to be sure 




5422




6





 





 





 





 





9



                     str_append_join ($str, never_empty => 1, sep => ' '); 




5423




6





 





 





 





 





16



                     str_append_str  ($str, "$thing->{functor}{value}("); 




5424




6





 





 





 





 





5



                     for my $t (@{ $thing->{arg} }) { 




 




6





 





 





 





 





12



   




5425




27





 





 





 





 





42



                         str_append_thing ($str, $t, NOT_IN_LIST, NO_PARENS); 




5426




 





 





 





 





 





 



                     } 




5427




6





 





 





 





 





8



                     str_append_end  ($str); 




5428




 





 





 





 





 





 



                 }, 




5429




 





 





 





 





 





 



   




5430




 





 





 





 





 





 



                 'case' => sub { 




5431




47





 





 





 





 





41



                     $in_list= NOT_IN_LIST; # just to be sure 




5432




 





 





 





 





 





 



   




5433




 





 





 





 





 





 



                     # FIXME (maybe): we add parens here, so if there are no 




5434




 





 





 





 





 





 



                     # when-then pairs at all and only the else part is printed, 




5435




 





 





 





 





 





 



                     # it will get parens, too, no matter what.  That's ok, 




5436




 





 





 





 





 





 



                     # since it's a non-standard, marginal special case. 




5437




47




  
100
  




 





 





 





118



                     return str_append_parens ($str, $thing, NOT_IN_LIST) 




5438




 





 





 





 





 





 



                         if $parens; 




5439




 





 





 





 





 





 



   




5440




34





 





 





 





 





37



                     my $sw= $thing->{switchval}; 




5441




34




  
100
  




 





 





 





72



                     if ($sw) { 




5442




22





 





 





 





 





69



                         str_append_funcall ($str, __PACKAGE__."::caseswitch", NOT_IN_LIST); 




5443




22





 





 





 





 





37



                         str_append_thing ($str, $sw, NOT_IN_LIST, NO_PARENS); 




5444




 





 





 





 





 





 



                     } 




5445




 





 





 





 





 





 



                     else { 




5446




12





 





 





 





 





18



                         str_append_funcall ($str, __PACKAGE__."::casecond", NOT_IN_LIST); 




5447




 





 





 





 





 





 



                     } 




5448




 





 





 





 





 





 



   




5449




34




  
100
  




 





 





 





1633



                     if (my $e= $thing->{otherwise}) { 




5450




24





 





 





 





 





39



                         str_append_thing ($str, $e, NOT_IN_LIST, NO_PARENS); 




5451




 





 





 





 





 





 



                     } 




5452




 





 





 





 





 





 



                     else { 




5453




10





 





 





 





 





15



                         str_append_str ($str, 'NULL'); 




5454




 





 





 





 





 





 



                     } 




5455




 





 





 





 





 





 



   




5456




34





 





 





 





 





1074



                     for my $wh (@{ $thing->{arg} }) { 




 




34





 





 





 





 





72



   




5457




30




  
 50
  




 





 





 





64



                         if (ref($wh) eq 'ARRAY') { 




5458




30





 





 





 





 





47



                             my ($when,$expr)= @$wh; 




5459




30





 





 





 





 





56



                             str_append_funcall ($str, __PACKAGE__.'::whenthen', NOT_IN_LIST); 




5460




30





 





 





 





 





48



                             str_append_thing ($str, $when, NOT_IN_LIST, NO_PARENS); 




5461




30





 





 





 





 





1281



                             str_append_thing ($str, $expr, NOT_IN_LIST, NO_PARENS); 




5462




30





 





 





 





 





1349



                             str_append_end ($str); 




5463




 





 





 





 





 





 



                         } 




5464




 





 





 





 





 





 



                         else { 




5465



  
0
  




 





 





 





 





0



                             die 'expected array'; 




5466




 





 





 





 





 





 



                         } 




5467




 





 





 





 





 





 



                     } 




5468




 





 





 





 





 





 



   




5469




34





 





 





 





 





53



                     str_append_end ($str); 




5470




 





 





 





 





 





 



                 }, 




5471




1038





 





 




  
618
  




 





13038



             ); 




5472




 





 





 





 





 





 



         }, 




5473




 





 





 





 





 





 



   




5474




 





 





 





 





 





 



         'ColumnName' => sub { 




5475




 





 





 





 





 





 



             switch ($thing->{type}, 




5476




 





 





 





 





 





 



                 'interpol' => 'ident', 




5477




 





 





 





 





 





 



                 'ident' => sub { 




5478




48





 





 





 





 





78



                     str_append_typed ($str, 'colname', 'none', $thing, $in_list, hashkeys => 1); 




5479




 





 





 





 





 





 



                 } 




5480




48





 





 




  
11
  




 





126



             ); 




5481




 





 





 





 





 





 



         }, 




5482




 





 





 





 





 





 



   




5483




 





 





 





 





 





 



         'ColumnIndex' => sub { 




5484




2




  
 50
  



  
 66
  



  
0
  




 





7



             if (defined $thing->{length} || $thing->{desc}) { 




5485




2





 





 





 





 





4



                 str_append_join  ($str, sep => ' '); 




5486




2





 





 





 





 





757



                 str_append_thing ($str, $thing->{name}, NOT_IN_LIST, NO_PARENS); 




5487




2




  
100
  




 





 





 





63



                 if (defined $thing->{length}) { 




5488




1





 





 





 





 





2



                     str_append_join  ($str, prefix => '(', suffix => ')'); 




5489




1





 





 





 





 





2



                     str_append_thing ($str, $thing->{length}, NOT_IN_LIST, NO_PARENS); 




5490




1





 





 





 





 





51



                     str_append_end   ($str); 




5491




 





 





 





 





 





 



                 } 




5492




2




  
100
  




 





 





 





4



                 if ($thing->{desc}) { 




5493




1





 





 





 





 





3



                     str_append_str ($str, 'DESC'); 




5494




 





 





 





 





 





 



                 } 




5495




2





 





 





 





 





3



                 str_append_end   ($str); 




5496




 





 





 





 





 





 



             } 




5497




 





 





 





 





 





 



             else { 




5498



  
0
  




 





 





 





 





0



                 str_append_thing ($str, $thing->{name}, $in_list, $parens); 




5499




 





 





 





 





 





 



             } 




5500




 





 





 





 





 





 



         }, 




5501




 





 





 





 





 





 



   




5502




 





 





 





 





 





 



         'TableName' => sub { 




5503




 





 





 





 





 





 



             switch ($thing->{type}, 




5504




 





 





 





 





 





 



                 'interpol' => 'ident', 




5505




 





 





 





 





 





 



                 'ident' => sub { 




5506




3





 





 





 





 





7



                     str_append_typed ($str, 'tabname', 'none', $thing, $in_list, hashkeys => 1); 




5507




 





 





 





 





 





 



                 } 




5508




3





 





 




  
1
  




 





10



             ); 




5509




 





 





 





 





 





 



         }, 




5510




 





 





 





 





 





 



   




5511




 





 





 





 





 





 



         'Fetch' => 'Do', 




5512




 





 





 





 





 





 



         'Do' => sub { 




5513




12





 





 




  
12
  




 





15



             str_append_thing ($str, $thing->{stmt}, $in_list, $parens); 




5514




 





 





 





 





 





 



         }, 




5515




2423





 





 





 





 





49852



     ); 




5516




 





 





 





 





 





 



 } 




5517




 





 





 





 





 





 



   




5518




 





 





 





 





 





 



 sub to_perl($$\@) 




5519




 





 





 





 





 





 



 { 




5520




278





 





 




  
278
  



  
0
  




283



     my ($line_start, $kind, $things)= @_; 




5521




278





 





 





 





 





344



     my $str= str_new($line_start); 




5522




278





 





 





 





 





384



     for my $thing (@$things) { 




5523




383





 





 





 





 





598



         str_append_thing ($str, $thing, IN_LIST, NO_PARENS); 




5524




 





 





 





 





 





 



     } 




5525




275





 





 





 





 





455



     my $text= str_get_string($str); 




5526




275





 





 





 





 





1238



     return "do{".__PACKAGE__."::_max1_if_scalar map{".__PACKAGE__."::${kind}->obj(\$_)} $text}", 




5527




 





 





 





 





 





 



 } 




5528




 





 





 





 





 





 



   




5529




 





 





 





 





 





 



 ###################################################################### 




5530




 





 





 





 





 





 



 # Top-level parser interface: 




5531




 





 





 





 





 





 



   




5532




 





 





 





 





 





 



 sub lx_die_perhaps($;$) 




5533




 





 





 





 





 





 



 { 




5534




559





 





 




  
559
  



  
0
  




477



     my $lx= shift; 




5535




 





 





 





 





 





 



   




5536




 





 





 





 





 





 



     # if a test value is given, check that it is defined: 




5537




559




  
100
  




 





 





 





923



     if (scalar(@_)) { 




5538




280





 





 





 





 





222



         my ($check_val)= @_; 




5539




280




  
100
  




 





 





 





427



         unless (defined $check_val) { 




5540




1





 




  
 50
  




 





 





3



             $lx->{error}||= 'Unknown error'; 




5541




 





 





 





 





 





 



         } 




5542




 





 





 





 





 





 



     } 




5543




 





 





 





 





 





 



   




5544




 





 





 





 





 





 



     # if an error is set, then die: 




5545




559




  
100
  




 





 





 





842



     if ($lx->{error}) { 




5546




2





 





 





 





 





7



         die lx_pos($lx).": Error: $lx->{error}\n"; 




5547




 





 





 





 





 





 



     } 




5548




 





 





 





 





 





 



 } 




5549




 





 





 





 





 





 



   




5550




 





 





 





 





 





 



   




5551




 





 





 





 





 





 



 sub parse_1_or_list($$$;$) 




5552




 





 





 





 





 





 



 { 




5553




273





 





 




  
273
  



  
0
  




293



     my ($lx, $parse_elem, $list_sep, $end)= @_; 




5554




273





 





 





 





 





434



     my $r= parse_list([], $lx, $parse_elem, $list_sep, $end); 




5555




273





 





 





 





 





478



     lx_die_perhaps($lx, $r); 




5556




272





 





 





 





 





538



     return @$r; 




5557




 





 





 





 





 





 



 } 




5558




 





 





 





 





 





 



   




5559




 





 





 





 





 





 



 sub parse_0_try_list($$) 




5560




 





 





 





 





 





 



 { 




5561




7





 





 




  
7
  



  
0
  




7



     my ($lx, $parse_elem)= @_; 




5562




7





 





 





 





 





18



     my $r= parse_try_list([], $lx, $parse_elem); 




5563




7





 





 





 





 





15



     lx_die_perhaps($lx, $r); 




5564




7





 





 





 





 





15



     return @$r; 




5565




 





 





 





 





 





 



 } 




5566




 





 





 





 





 





 



   




5567




 





 





 





 





 





 



 sub parse_stmt_list($) 




5568




 





 





 





 





 





 



 { 




5569




137





 





 




  
137
  



  
0
  




370



     parse_1_or_list ($_[0], \&parse_stmt,  ';', ['}',')',']']); 




5570




 





 





 





 





 





 



 } 




5571




 





 





 





 





 





 



   




5572




 





 





 





 





 





 



 sub parse_do_stmt($) 




5573




 





 





 





 





 





 



 { 




5574




2





 





 




  
2
  



  
0
  




2



     my ($lx) = @_; 




5575




 





 





 





 





 





 



     map { 




5576




2





 





 





 





 





4



         my $stmt = $_; 




 




2





 





 





 





 





2



   




5577




2





 





 





 





 





4



         my $r = create($lx, 'Do', qw(stmt)); 




5578




2





 





 





 





 





3



         $r->{stmt} = $stmt; 




5579




2





 





 





 





 





5



         $r; 




5580




 





 





 





 





 





 



     } 




5581




 





 





 





 





 





 



     parse_stmt_list($lx); 




5582




 





 





 





 





 





 



 } 




5583




 





 





 





 





 





 



   




5584




 





 





 





 





 





 



 sub parse_fetch_stmt($) 




5585




 





 





 





 





 





 



 { 




5586




10





 





 




  
10
  



  
0
  




10



     my ($lx) = @_; 




5587




 





 





 





 





 





 



     map { 




5588




10





 





 





 





 





12



         my $stmt = $_; 




 




10





 





 





 





 





9



   




5589




10





 





 





 





 





15



         my $r = create($lx, 'Fetch', qw(stmt)); 




5590




10





 





 





 





 





11



         $r->{stmt} = $stmt; 




5591




10





 





 





 





 





24



         $r; 




5592




 





 





 





 





 





 



     } 




5593




 





 





 





 





 





 



     parse_stmt_list($lx); 




5594




 





 





 





 





 





 



 } 




5595




 





 





 





 





 





 



   




5596




 





 





 





 





 





 



 my %top_parse= ( 




5597




 





 





 





 





 





 



     # pure parse actions: 




5598




 





 





 





 





 





 



     'Stmt'            => \&parse_stmt_list, 




5599




 





 





 





 





 





 



   




5600




 





 





 





 





 





 



     'Join'            => sub { parse_0_try_list($_[0], \&parse_join)                 }, 




5601




 





 





 





 





 





 



     'TableOption'     => sub { parse_0_try_list($_[0], \&parse_table_option)         }, 




5602




 





 





 





 





 





 



   




5603




 





 





 





 





 





 



     'Expr'            => sub { parse_1_or_list ($_[0], \&parse_expr,            ',') }, 




5604




 





 





 





 





 





 



     'Check'           => sub { parse_1_or_list ($_[0], \&parse_check,           ',') }, 




5605




 





 





 





 





 





 



     'Type'            => sub { parse_1_or_list ($_[0], \&parse_type,            ',') }, 




5606




 





 





 





 





 





 



     'Column'          => sub { parse_1_or_list ($_[0], \&parse_column,          ',') }, 




5607




 





 





 





 





 





 



     'Table'           => sub { parse_1_or_list ($_[0], \&parse_table,           ',') }, 




5608




 





 





 





 





 





 



     'Index'           => sub { parse_1_or_list ($_[0], \&parse_index,           ',') }, 




5609




 





 





 





 





 





 



     'CharSet'         => sub { parse_1_or_list ($_[0], \&parse_charset,         ',') }, 




5610




 





 





 





 





 





 



     'Collate'         => sub { parse_1_or_list ($_[0], \&parse_collate,         ',') }, 




5611




 





 





 





 





 





 



     'Constraint'      => sub { parse_1_or_list ($_[0], \&parse_constraint,      ',') }, 




5612




 





 





 





 





 





 



     'Transliteration' => sub { parse_1_or_list ($_[0], \&parse_transliteration, ',') }, 




5613




 





 





 





 





 





 



     'Transcoding'     => sub { parse_1_or_list ($_[0], \&parse_transcoding,     ',') }, 




5614




 





 





 





 





 





 



     'Order'           => sub { parse_1_or_list ($_[0], \&parse_order,           ',') }, 




5615




 





 





 





 





 





 



     'ColumnSpec'      => sub { parse_1_or_list ($_[0], \&parse_column_spec,     ',') }, 




5616




 





 





 





 





 





 



   




5617




 





 





 





 





 





 



     # parse & execute actions: 




5618




 





 





 





 





 





 



     'Do'              => sub { parse_do_stmt   ($_[0]) }, 




5619




 





 





 





 





 





 



     'Fetch'           => sub { parse_fetch_stmt($_[0]) }, 




5620




 





 





 





 





 





 



 ); 




5621




 





 





 





 





 





 



 my $top_parse_re=  '(?:'.join('|', sort { length($b) <=> length($a) } '',     keys %top_parse).')'; 




5622




 





 





 





 





 





 



 my $top_parse_re2= '(?:'.join('|', sort { length($b) <=> length($a) } 'none', keys %top_parse).')'; 




5623




 





 





 





 





 





 



   




5624




 





 





 





 





 





 



 sub interpol_set_context ($$) 




5625




 





 





 





 





 





 



 { 




5626




515





 





 




  
515
  



  
0
  




533



     my ($text, $ctxt)= @_; 




5627




515





 





 





 





 





424



     $text=~ s/(\Q${\SQL_MARK}\E$top_parse_re)(?::$top_parse_re2)?(\s*\{)/$1:$ctxt$2/gs; 




 




515





 





 





 





 





2638



   




5628




515





 





 





 





 





1489



     return $text; 




5629




 





 





 





 





 





 



 } 




5630




 





 





 





 





 





 



   




5631




 





 





 





 





 





 



 sub good_interpol_type($) 




5632




 





 





 





 





 





 



 { 




5633




8





 





 




  
8
  



  
0
  




10



     my ($type)= @_; 




5634




8





 





 





 





 





28



     return !!$top_parse{$type}; 




5635




 





 





 





 





 





 



 } 




5636




 





 





 





 





 





 



   




5637




 





 





 





 





 





 



 sub mark_sql() 




5638




 





 





 





 





 





 



 { 




5639




 





 





 





 





 





 



     # Step 1: 




5640




 





 





 





 





 





 



     # This function will get the text without comments, strings, etc., 




5641




 





 





 





 





 





 



     # and replace the initial SQL marking the start of SQL syntax by 




5642




 





 





 





 





 





 



     # our special SQL_MARK.  Then, the unprocessed text will be 




5643




 





 





 





 





 





 



     # processed by replace_sql(). 




5644




5





 





 




  
5
  



  
0
  




303



     s/\b\Q$sql_marker\E($top_parse_re\s*\{)/${\SQL_MARK}$1/gs; 




 




259





 





 





 





 





490



   




5645




 





 





 





 





 





 



   




5646




 





 





 





 





 





 



     # Step 2: 




5647




 





 





 





 





 





 



     # Unmark false positives.  The above finds false matches in 




5648




 





 





 





 





 





 



     # variables: 




5649




 





 





 





 





 





 



     # 




5650




 





 





 





 





 





 



     #    $sql{...} 




5651




 





 





 





 





 





 



     # 




5652




 





 





 





 





 





 



     # We cannot(?) do this in one go, as we'd need a variable-width 




5653




 





 





 





 





 





 



     # negative look-behind regexp, which Perl does not have.  This 




5654




 





 





 





 





 





 



     # is because there can be arbitrary white space between $ and 




5655




 





 





 





 





 





 



     # a variable name. 




5656




5





 





 





 





 





10



     s/([\$\@\%]\s*)\Q${\SQL_MARK}\E/$1$sql_marker/gs; 




 




5





 





 





 





 





343



   




5657




 





 





 





 





 





 



   




5658




 





 





 





 





 





 



     # Note that there are still false positives, which are really hard 




5659




 





 





 





 





 





 



     # to find unless we start parsing Perl completely: 




5660




 





 





 





 





 





 



     # 




5661




 





 





 





 





 





 



     #   ${ sql{blah} } 




5662




 





 





 





 





 





 



 } 




5663




 





 





 





 





 





 



   




5664




 





 





 





 





 





 



 sub parse($$) 




5665




 





 





 





 





 





 



 { 




5666




22





 





 




  
22
  



  
0
  




10217



     my ($kind, $str)= @_; 




5667




22





 





 





 





 





52



     my $lx= lexer_new ($str, "", 0); 




5668




22





 





 





 





 





33



     my $func= $top_parse{$kind}; 




5669




22




  
 50
  




 





 





 





38



     return undef unless $func; 




5670




22




  
 50
  




 





 





 





43



     return () if looking_at($lx, ''); 




5671




22





 





 





 





 





39



     my @thing= $func->($lx); 




5672




21





 





 





 





 





52



     expect($lx, '', SHIFT); 




5673




21





 





 





 





 





30



     lx_die_perhaps ($lx); 




5674




20





 





 





 





 





37



     return to_perl(1, $kind, @thing); 




5675




 





 





 





 





 





 



 } 




5676




 





 





 





 





 





 



   




5677




 





 





 





 





 





 



 sub replace_sql() 




5678




 





 





 





 





 





 



 { 




5679




5





 





 




  
5
  



  
0
  




7232



     my ($module, $file, $line)= caller(4); # find our from where we were invoked 




5680




 





 





 





 





 





 



   




5681




5





 





 





 





 





14



     mark_sql(); 




5682




 





 





 





 





 





 



     #print STDERR "DEBUG: BEFORE: $_\n"; 




5683




 





 





 





 





 





 



   




5684




5





 





 





 





 





12



     pos($_)= 0; 




5685




5





 





 





 





 





9



     REPLACEMENT: while (/(\Q${\SQL_MARK}\E($top_parse_re)(?::($top_parse_re2))?\s*\{)/gs) { 




 




263





 





 





 





 





6714



   




5686




 





 





 





 





 





 



         # prepare lexer: 




5687




258





 




  
100
  




 





 





1096



         my $ctxt=     $3 || 'Stmt'; 




5688




258





 





 





 





 





303



         my $speckind= $2; 




5689




258





 




  
 66
  




 





 





511



         my $kind=     $speckind || $ctxt; 




5690




258





 





 





 





 





368



         my $start=    pos($_) - length($1); 




5691




258





 





 





 





 





1543



         my $prefix=   substr($_, 0, $start); 




5692




258





 





 





 





 





5418



         my $line_rel= ($prefix =~ tr/\n//); 




5693




258





 





 





 





 





602



         my $lx=       lexer_new ($_, $file, $line + $line_rel); 




5694




 





 





 





 





 





 



   




5695




 





 





 





 





 





 



         # select parser: 




5696




258





 





 





 





 





310



         my $func= $top_parse{$kind}; 




5697




258




  
 50
  




 





 





 





390



         unless ($func) { 




5698



  
0
  




 





 





 





 





0



             die "$file:".($line+$line_rel+1). 




5699




 





 





 





 





 





 



                   ": Error: Plain ${sql_marker}${speckind}{...} is illegal, because the ". 




5700




 





 





 





 





 





 



                   "surrounding block must not return an object.\n\tPlease use ". 




5701




 





 





 





 





 





 



                   (english_or map "${sql_marker}${_}{...}", keys %top_parse)." to disambiguate.\n"; 




5702



  
0
  




 





 





 





 





0



             last REPLACEMENT; 




5703




 





 





 





 





 





 



         } 




5704




 





 





 





 





 





 



   




5705




 





 





 





 





 





 



         # parse (including closing brace): 




5706




258





 





 





 





 





379



         my @thing= $func->($lx); 




5707




258





 





 





 





 





402



         expect ($lx, '}', SHIFT); 




5708




258





 





 





 





 





351



         lx_die_perhaps ($lx); 




5709




 





 





 





 





 





 



   




5710




258





 





 





 





 





287



         my $end= $lx->{token}{pos}; 




5711




258




  
 50
  



  
 33
  




 





 





912



         my_confess unless defined $end && $start < $end; 




5712




 





 





 





 





 





 



   




5713




 





 





 





 





 





 



         # Make Perl code: 




5714




 





 





 





 





 





 



         # Represent the parse result as a list in Perl (if it's only 




5715




 





 





 





 





 





 



         # one element, the parens don't hurt).  Each thing is 




5716




 





 





 





 





 





 



         # handled individually by to_perl(): 




5717




258





 





 





 





 





421



         my $perl= to_perl($line + $line_rel, $kind, @thing); 




5718




 





 





 





 





 





 



   




5719




 





 





 





 





 





 



         # replace: 




5720




258




  
 50
  




 





 





 





427



         print STDERR "$file:".($line+$line_rel+1).': DEBUG: '.__PACKAGE__." replacement: $perl\n" 




5721




 





 





 





 





 





 



             if $debug; 




5722




 





 





 





 





 





 



   




5723




258





 





 





 





 





11517



         my $old_text= substr($_, $start, $end-$start, $perl); # extract and replace text 




5724




 





 





 





 





 





 



             # pos($_) is now undef, which is ok, we will 




5725




 





 





 





 





 





 



             # rescan the text anyway. 




5726




 





 





 





 





 





 



   




5727




 





 





 





 





 





 



         # Insert newlines at the end that have been dropped so that the line 




5728




 





 





 





 





 





 



         # count does not change and Perl's error messages are useful: 




5729




258





 





 





 





 





361



         my $line_cnt_old= ($old_text =~ tr/\n//); 




5730




258





 





 





 





 





333



         my $line_cnt_new= ($perl     =~ tr/\n//); 




5731




258




  
 50
  




 





 





 





443



         my_confess "More newlines than before" #.": \n###\n$old_text\n###$perl\n###\n" 




5732




 





 





 





 





 





 



             if $line_cnt_new > $line_cnt_old; 




5733




 





 





 





 





 





 



   




5734




258




  
100
  




 





 





 





532



         if (my $line_cnt_less= $line_cnt_old - $line_cnt_new) { 




5735




101





 





 





 





 





1383



             substr($_, $start + length($perl), 0, "\n" x $line_cnt_less); 




5736




 





 





 





 





 





 



         } 




5737




 





 





 





 





 





 



   




5738




 





 





 





 





 





 



         # rescan everything in order to recurse into embedded sql{...}: 




5739




258





 





 





 





 





3878



         pos($_)= 0; 




5740




 





 





 





 





 





 



     } 




5741




5





 





 





 





 





21



     pos($_)= undef; 




5742




 





 





 





 





 





 



   




5743




 





 





 





 





 





 



     #print STDERR "DEBUG: AFTER: $_\n"; 




5744




 





 





 





 





 





 



 }; 




5745




 





 





 





 





 





 



   




5746




 





 





 





 





 





 



 FILTER_ONLY 




5747




 





 





 





 





 





 



     # code_no_comments => \&mark_sql,    # This is way to slow. 




5748




 





 





 





 





 





 



     all  => \&replace_sql; 




5749




 





 





 





 





 





 



   




5750




 





 





 





 





 





 



 ###################################################################### 




5751




 





 





 





 





 





 



 # Functions used in generated code: 




5752




 





 





 





 





 





 



   




5753




 





 





 





 





 





 



 # Obj: 




5754




 





 





 





 





 





 



 { 




5755




 





 





 





 





 





 



     package SQL::Yapp::Obj; 




5756




 





 





 





 





 





 



   




5757




5





 





 




  
5
  




 





40



     use strict; 




 




5





 





 





 





 





7



   




 




5





 





 





 





 





131



   




5758




5





 





 




  
5
  




 





16



     use warnings; 




 




5





 





 





 





 





8



   




 




5





 





 





 





 





164



   




5759




5





 





 




  
5
  




 





20



     use Carp qw(croak); 




 




5





 





 





 





 





6



   




 




5





 





 





 





 





475



   




5760




 





 





 





 





 





 



   




5761



  
0
  




 





 




  
0
  




 





0



     sub op($) { return ''; } 




5762




 





 





 





 





 





 



   




5763




 





 





 





 





 





 



     ###################################################################### 




5764




 





 





 





 





 





 



     # stringify: simply return second entry in array, the string: 




5765




 





 





 





 





 





 



     use overload '""' => 'value', 




5766




5





 





 




  
5
  




 





22



                  cmp  => sub { "$_[0]" cmp "$_[1]" }; 




 




5





 





 




  
173
  




 





9



   




 




5





 





 





 





 





56



   




 




173





 





 





 





 





17317



   




5767




 





 





 





 





 





 



   




5768




 





 





 





 





 





 



     sub type_error($$) 




5769




 





 





 





 





 





 



     { 




5770




3





 





 




  
3
  




 





4



         my ($x, $want)= @_; 




5771




3





 





 





 





 





6



         my $r= ref($x); 




5772




3





 





 





 





 





11



         $r=~ s/^SQL::Yapp:://; 




5773




3





 





 





 





 





368



         croak "Error: Expected $want, but found ".$r; 




5774




 





 





 





 





 





 



     } 




5775




 





 





 





 





 





 



   




5776



  
0
  




 





 




  
0
  




 





0



     sub asc($)              { $_[0]->type_error('Asc');             } 




5777



  
0
  




 





 




  
0
  




 





0



     sub assign($)           { $_[0]->type_error('assignment');      } 




5778



  
0
  




 





 




  
0
  




 





0



     sub charset($)          { $_[0]->type_error('CharSet');         } 




5779



  
0
  




 





 




  
0
  




 





0



     sub constraint($)       { $_[0]->type_error('Constraint');      } 




5780



  
0
  




 





 




  
0
  




 





0



     sub charset1($)         { $_[0]->type_error('CharSet');         } 




5781



  
0
  




 





 




  
0
  




 





0



     sub collate1($)         { $_[0]->type_error('Collate');         } 




5782



  
0
  




 





 




  
0
  




 





0



     sub colname($)          { $_[0]->type_error('ColumnName');      } 




5783



  
0
  




 





 




  
0
  




 





0



     sub colspec($)          { $_[0]->type_error('ColumnSpec');      } 




5784



  
0
  




 





 




  
0
  




 





0



     sub column1($)          { $_[0]->type_error('Column');          } 




5785




1





 





 




  
1
  




 





6



     sub column1_single($)   { $_[0]->type_error('Column');          } 




5786



  
0
  




 





 




  
0
  




 





0



     sub constraint1($)      { $_[0]->type_error('Constraint');      } 




5787



  
0
  




 





 




  
0
  




 





0



     sub desc($)             { $_[0]->type_error('Desc');            } 




5788



  
0
  




 





 




  
0
  




 





0



     sub engine1($)          { $_[0]->type_error('Engine');          } 




5789



  
0
  




 





 




  
0
  




 





0



     sub expr($)             { $_[0]->type_error('Expr');            } 




5790



  
0
  




 





 




  
0
  




 





0



     sub expr_or_check($)    { $_[0]->type_error('Expr or Check');   } 




5791



  
0
  




 





 




  
0
  




 





0



     sub check($)            { $_[0]->type_error('Check');           } 




5792




1





 





 




  
1
  




 





5



     sub exprparen($)        { $_[0]->type_error('Expr');            } 




5793



  
0
  




 





 




  
0
  




 





0



     sub index1($)           { $_[0]->type_error('Index');           } 




5794



  
0
  




 





 




  
0
  




 





0



     sub joinclause($)       { $_[0]->type_error('JOIN clause');     } 




5795



  
0
  




 





 




  
0
  




 





0



     sub limit_number($)     { $_[0]->type_error('number or ?');     } 




5796



  
0
  




 





 




  
0
  




 





0



     sub stmt($)             { $_[0]->type_error('Stmt');            } 




5797



  
0
  




 





 




  
0
  




 





0



     sub subquery($)         { $_[0]->type_error('subquery');        } 




5798



  
0
  




 





 




  
0
  




 





0



     sub table1($)           { $_[0]->type_error('Table');           } 




5799



  
0
  




 





 




  
0
  




 





0



     sub tabname($)          { $_[0]->type_error('TableName');       } 




5800



  
0
  




 





 




  
0
  




 





0



     sub tableopt($)         { $_[0]->type_error('TableOption');     } 




5801



  
0
  




 





 




  
0
  




 





0



     sub transcoding($)      { $_[0]->type_error('Transcoding');     } 




5802



  
0
  




 





 




  
0
  




 





0



     sub transliteration1($) { $_[0]->type_error('Transliteration'); } 




5803



  
0
  




 





 




  
0
  




 





0



     sub type($)             { $_[0]->type_error('Type');            } 




5804




 





 





 





 





 





 



   




5805



  
0
  




 





 




  
0
  




 





0



     sub do($)               { $_[0]->type_error('Do');              } 




5806



  
0
  




 





 




  
0
  




 





0



     sub fetch($)            { $_[0]->type_error('Fetch');           } 




5807




 





 





 





 





 





 



 } 




5808




 





 





 





 





 





 



   




5809




 





 





 





 





 





 



 # Obj1: 




5810




 





 





 





 





 





 



 { 




5811




 





 





 





 





 





 



     package SQL::Yapp::Obj1; 




5812




 





 





 





 





 





 



   




5813




5





 





 




  
5
  




 





3004



     use strict; 




 




5





 





 





 





 





6



   




 




5





 





 





 





 





111



   




5814




5





 





 




  
5
  




 





16



     use warnings; 




 




5





 





 





 





 





69



   




 




5





 





 





 





 





152



   




5815




5





 





 




  
5
  




 





19



     use base qw(SQL::Yapp::Obj); 




 




5





 





 





 





 





6



   




 




5





 





 





 





 





1630



   




5816




5





 





 




  
5
  




 





22



     use Scalar::Util qw(blessed); 




 




5





 





 





 





 





6



   




 




5





 





 





 





 





664



   




5817




 





 





 





 





 





 



   




5818




 





 





 





 





 





 



     sub obj($$) 




5819




 





 





 





 





 





 



     { 




5820




890





 





 




  
890
  




 





3239



         my ($class,$x)= @_; 




5821




890




  
100
  



  
 66
  




 





 





2536



         return $x 




5822




 





 





 





 





 





 



             if blessed($x) && $x->isa(__PACKAGE__); 




5823




731





 





 





 





 





1989



         return bless([$x], $class); 




5824




 





 





 





 





 





 



     } 




5825




 





 





 





 





 





 



   




5826




814





 





 




  
814
  




 





3401



     sub value($) { return $_[0][0]; } 




5827




 





 





 





 





 





 



 } 




5828




 





 





 





 





 





 



   




5829




 





 





 





 





 





 



 ############### 




5830




 





 





 





 





 





 



 # Asterisk: 




5831




 





 





 





 





 





 



 { 




5832




 





 





 





 





 





 



     package SQL::Yapp::Asterisk; 




5833




 





 





 





 





 





 



   




5834




5





 





 




  
5
  




 





21



     use strict; 




 




5





 





 





 





 





6



   




 




5





 





 





 





 





98



   




5835




5





 





 




  
5
  




 





18



     use warnings; 




 




5





 





 





 





 





19



   




 




5





 





 





 





 





143



   




5836




5





 





 




  
5
  




 





19



     use base qw(SQL::Yapp::Obj); 




 




5





 





 





 





 





6



   




 




5





 





 





 





 





1765



   




5837




 





 





 





 





 





 



   




5838




 





 





 





 





 





 



     sub obj($) 




5839




 





 





 





 





 





 



     { 




5840




2





 





 




  
2
  




 





2



         my ($class)= @_; 




5841




2





 





 





 





 





6



         return bless([], $class); 




5842




 





 





 





 





 





 



     } 




5843




 





 





 





 





 





 



   




5844




2





 





 




  
2
  




 





9



     sub value($)          { return '*'; } 




5845




 





 





 





 





 





 



   




5846




2





 





 




  
2
  




 





8



     sub column1($)        { return $_[0]; } 




5847



  
0
  




 





 




  
0
  




 





0



     sub column1_single($) { return $_[0]; } 




5848



  
0
  




 





 




  
0
  




 





0



     sub expr($)           { return $_[0]; } 




5849



  
0
  




 





 




  
0
  




 





0



     sub expr_or_check($)  { return $_[0]; } 




5850




 





 





 





 





 





 



   




5851



  
0
  




 





 




  
0
  




 





0



     sub asterisk($)       { return $_[0]; } 




5852




 





 





 





 





 





 



 } 




5853




 





 





 





 





 





 



   




5854




 





 





 





 





 





 



 # Question: 




5855




 





 





 





 





 





 



 { 




5856




 





 





 





 





 





 



     package SQL::Yapp::Question; 




5857




 





 





 





 





 





 



   




5858




5





 





 




  
5
  




 





21



     use strict; 




 




5





 





 





 





 





8



   




 




5





 





 





 





 





87



   




5859




5





 





 




  
5
  




 





14



     use warnings; 




 




5





 





 





 





 





4



   




 




5





 





 





 





 





106



   




5860




5





 





 




  
5
  




 





15



     use base qw(SQL::Yapp::Obj); 




 




5





 





 





 





 





3



   




 




5





 





 





 





 





1894



   




5861




 





 





 





 





 





 



   




5862




 





 





 





 





 





 



     sub obj($) 




5863




 





 





 





 





 





 



     { 




5864




1





 





 




  
1
  




 





2



         my ($class)= @_; 




5865




1





 





 





 





 





3



         return bless([], $class); 




5866




 





 





 





 





 





 



     } 




5867




 





 





 





 





 





 



   




5868




1





 





 




  
1
  




 





3



     sub value($)         { return '?' } 




5869




 





 





 





 





 





 



   




5870



  
0
  




 





 




  
0
  




 





0



     sub limit_number($)  { return $_[0]; } 




5871




1





 





 




  
1
  




 





3



     sub exprparen($)     { return $_[0]; } 




5872



  
0
  




 





 




  
0
  




 





0



     sub expr($)          { return $_[0]; } 




5873



  
0
  




 





 




  
0
  




 





0



     sub expr_or_check($) { return $_[0]; } 




5874



  
0
  




 





 




  
0
  




 





0



     sub asc($)           { return $_[0]; } 




5875



  
0
  




 





 




  
0
  




 





0



     sub desc($)          { return SQL::Yapp::Desc->obj($_[0]); } 




5876




 





 





 





 





 





 



 } 




5877




 





 





 





 





 





 



   




5878




 





 





 





 





 





 



 # ExprSpecial: 




5879




 





 





 





 





 





 



 { 




5880




 





 





 





 





 





 



     package SQL::Yapp::ExprSpecial; 




5881




 





 





 





 





 





 



   




5882




5





 





 




  
5
  




 





21



     use strict; 




 




5





 





 





 





 





5



   




 




5





 





 





 





 





83



   




5883




5





 





 




  
5
  




 





13



     use warnings; 




 




5





 





 





 





 





6



   




 




5





 





 





 





 





123



   




5884




5





 





 




  
5
  




 





16



     use base qw(SQL::Yapp::Obj1); 




 




5





 





 





 





 





7



   




 




5





 





 





 





 





1724



   




5885




 





 





 





 





 





 



   




5886



  
0
  




 





 




  
0
  




 





0



     sub exprparen($)     { return $_[0]; } 




5887



  
0
  




 





 




  
0
  




 





0



     sub expr($)          { return $_[0]; } 




5888



  
0
  




 





 




  
0
  




 





0



     sub expr_or_check($) { return $_[0]; } 




5889



  
0
  




 





 




  
0
  




 





0



     sub asc($)           { return $_[0]; } 




5890



  
0
  




 





 




  
0
  




 





0



     sub desc($)          { return SQL::Yapp::Desc->obj($_[0]); } 




5891




 





 





 





 





 





 



 } 




5892




 





 





 





 





 





 



   




5893




 





 





 





 





 





 



 # Stmt: 




5894




 





 





 





 





 





 



 { 




5895




 





 





 





 





 





 



     package SQL::Yapp::Stmt; 




5896




 





 





 





 





 





 



   




5897




5





 





 




  
5
  




 





21



     use strict; 




 




5





 





 





 





 





6



   




 




5





 





 





 





 





96



   




5898




5





 





 




  
5
  




 





21



     use warnings; 




 




5





 





 





 





 





5



   




 




5





 





 





 





 





123



   




5899




5





 





 




  
5
  




 





17



     use Carp qw(croak); 




 




5





 





 





 





 





5



   




 




5





 





 





 





 





208



   




5900




5





 





 




  
5
  




 





17



     use base qw(SQL::Yapp::Obj1); 




 




5





 





 





 





 





4



   




 




5





 





 





 





 





1767



   




5901




 





 





 





 





 





 



   




5902




1





 





 




  
1
  




 





9



     sub subquery($)      { $_[0]->type_error('SELECT statement'); } 




5903



  
0
  




 





 




  
0
  




 





0



     sub exprparen($)     { $_[0]->subquery(); } 




5904




2





 





 




  
2
  




 





7



     sub expr($)          { $_[0]->subquery(); } 




5905



  
0
  




 





 




  
0
  




 





0



     sub expr_or_check($) { $_[0]->subquery(); } 




5906




 





 





 





 





 





 



   




5907




3





 





 




  
3
  




 





6



     sub stmt($)          { return $_[0]; } 




5908




 





 





 





 





 





 



   




5909




 





 





 





 





 





 



     sub do($) 




5910




 





 





 





 





 





 



     { 




5911



  
0
  




 





 




  
0
  




 





0



         my ($stmt) = @_; 




5912



  
0
  




 





 





 





 





0



         my $dbh = SQL::Yapp::get_dbh(); 




5913



  
0
  




 





 





 





 





0



         $dbh->do($stmt); 




5914



  
0
  




 





 





 





 





0



         return; # return no statements so that _max1_if_scalar is ok with void context 




5915




 





 





 





 





 





 



     } 




5916




 





 





 





 





 





 



 } 




5917




 





 





 





 





 





 



   




5918




 





 





 





 





 





 



 # SelectStmt: 




5919




 





 





 





 





 





 



 { 




5920




 





 





 





 





 





 



     package SQL::Yapp::SelectStmt; 




5921




 





 





 





 





 





 



   




5922




5





 





 




  
5
  




 





20



     use strict; 




 




5





 





 





 





 





5



   




 




5





 





 





 





 





102



   




5923




5





 





 




  
5
  




 





15



     use warnings; 




 




5





 





 





 





 





5



   




 




5





 





 





 





 





121



   




5924




5





 





 




  
5
  




 





14



     use Carp qw(croak); 




 




5





 





 





 





 





6



   




 




5





 





 





 





 





242



   




5925




5





 





 




  
5
  




 





21



     use base qw(SQL::Yapp::Stmt); 




 




5





 





 





 





 





4



   




 




5





 





 





 





 





1577



   




5926




 





 





 





 





 





 



   




5927




2





 





 




  
2
  




 





7



     sub subquery($)      { return '('.($_[0]->value).')'; } 




5928




 





 





 





 





 





 



   




5929




 





 





 





 





 





 



     sub fetch($) 




5930




 





 





 





 





 





 



     { 




5931



  
0
  




 





 




  
0
  




 





0



         my ($stmt) = @_; 




5932



  
0
  




 





 





 





 





0



         my $dbh = SQL::Yapp::get_dbh(); 




5933



  
0
  




 





 





 





 





0



         my $sth = $dbh->prepare($stmt); 




5934



  
0
  




 





 





 





 





0



         my $aref = $dbh->selectall_arrayref($sth, { Slice => {} }); 




5935



  
0
  



  
  0
  




 





 





 





0



         return unless $aref; 




5936



  
0
  




 





 





 





 





0



         return @$aref; 




5937




 





 





 





 





 





 



     } 




5938




 





 





 





 





 





 



 } 




5939




 





 





 





 





 





 



   




5940




 





 





 





 





 





 



 # SelectStmtSingle: 




5941




 





 





 





 





 





 



 { 




5942




 





 





 





 





 





 



     package SQL::Yapp::SelectStmtSingle; 




5943




 





 





 





 





 





 



   




5944




5





 





 




  
5
  




 





22



     use strict; 




 




5





 





 





 





 





5



   




 




5





 





 





 





 





79



   




5945




5





 





 




  
5
  




 





15



     use warnings; 




 




5





 





 





 





 





12



   




 




5





 





 





 





 





123



   




5946




5





 





 




  
5
  




 





18



     use Carp qw(croak); 




 




5





 





 





 





 





10



   




 




5





 





 





 





 





182



   




5947




5





 





 




  
5
  




 





15



     use base qw(SQL::Yapp::SelectStmt); 




 




5





 





 





 





 





5



   




 




5





 





 





 





 





1595



   




5948




 





 





 





 





 





 



   




5949




 





 





 





 





 





 



     sub fetch($) 




5950




 





 





 





 





 





 



     { 




5951



  
0
  




 





 




  
0
  




 





0



         my ($stmt) = @_; 




5952



  
0
  




 





 





 





 





0



         my $dbh = SQL::Yapp::get_dbh(); 




5953



  
0
  




 





 





 





 





0



         my $sth = $dbh->prepare($stmt); 




5954



  
0
  



  
  0
  




 





 





 





0



         return unless $sth->execute; 




5955



  
0
  




 





 





 





 





0



         my @r= (); 




5956



  
0
  




 





 





 





 





0



         while (my $a= $sth->fetchrow_arrayref) { 




5957



  
0
  



  
  0
  




 





 





 





0



             die unless scalar(@$a) == 1; 




5958



  
0
  




 





 





 





 





0



             push @r, $a->[0]; 




5959




 





 





 





 





 





 



         } 




5960



  
0
  




 





 





 





 





0



         return @r; 




5961




 





 





 





 





 





 



     } 




5962




 





 





 





 





 





 



 } 




5963




 





 





 





 





 





 



   




5964




 





 





 





 





 





 



 # Do: 




5965




 





 





 





 





 





 



 # This is a bit different, since the obj() method will actually execute the statement. 




5966




 





 





 





 





 





 



 { 




5967




 





 





 





 





 





 



     package SQL::Yapp::Do; 




5968




 





 





 





 





 





 



   




5969




5





 





 




  
5
  




 





19



     use strict; 




 




5





 





 





 





 





5



   




 




5





 





 





 





 





79



   




5970




5





 





 




  
5
  




 





12



     use warnings; 




 




5





 





 





 





 





5



   




 




5





 





 





 





 





131



   




5971




5





 





 




  
5
  




 





15



     use Carp qw(confess); 




 




5





 





 





 





 





4



   




 




5





 





 





 





 





353



   




5972




 





 





 





 





 





 



   




5973




 





 





 





 





 





 



     sub obj($$) 




5974




 





 





 





 





 





 



     { 




5975



  
0
  




 





 




  
0
  




 





0



         my ($class, $stmt) = @_; 




5976



  
0
  




 





 





 





 





0



         return $stmt->do; 




5977




 





 





 





 





 





 



     } 




5978




 





 





 





 





 





 



 } 




5979




 





 





 





 





 





 



   




5980




 





 





 





 





 





 



 # Fetch: 




5981




 





 





 





 





 





 



 # This is a bit different, since the obj() method will actually execute the statement. 




5982




 





 





 





 





 





 



 { 




5983




 





 





 





 





 





 



     package SQL::Yapp::Fetch; 




5984




 





 





 





 





 





 



   




5985




5





 





 




  
5
  




 





18



     use strict; 




 




5





 





 





 





 





8



   




 




5





 





 





 





 





75



   




5986




5





 





 




  
5
  




 





11



     use warnings; 




 




5





 





 





 





 





7



   




 




5





 





 





 





 





273



   




5987




 





 





 





 





 





 



   




5988




 





 





 





 





 





 



     sub obj($$) 




5989




 





 





 





 





 





 



     { 




5990



  
0
  




 





 




  
0
  




 





0



         my ($class, $stmt) = @_; 




5991



  
0
  




 





 





 





 





0



         return $stmt->fetch; 




5992




 





 





 





 





 





 



     } 




5993




 





 





 





 





 





 



 } 




5994




 





 





 





 





 





 



   




5995




 





 





 





 





 





 



 # ColumnName: 




5996




 





 





 





 





 





 



 { 




5997




 





 





 





 





 





 



     package SQL::Yapp::ColumnName; 




5998




 





 





 





 





 





 



   




5999




5





 





 




  
5
  




 





17



     use strict; 




 




5





 





 





 





 





3



   




 




5





 





 





 





 





118



   




6000




5





 





 




  
5
  




 





18



     use warnings; 




 




5





 





 





 





 





4



   




 




5





 





 





 





 





116



   




6001




5





 





 




  
5
  




 





15



     use base qw(SQL::Yapp::Obj1); 




 




5





 





 





 





 





5



   




 




5





 





 





 





 





1223



   




6002




 





 





 





 





 





 



   




6003



  
0
  




 





 




  
0
  




 





0



     sub colname($) { return $_[0]; } 




6004




 





 





 





 





 





 



 } 




6005




 





 





 





 





 





 



   




6006




 





 





 





 





 





 



 # TableName: 




6007




 





 





 





 





 





 



 { 




6008




 





 





 





 





 





 



     package SQL::Yapp::TableName; 




6009




 





 





 





 





 





 



   




6010




5





 





 




  
5
  




 





18



     use strict; 




 




5





 





 





 





 





5



   




 




5





 





 





 





 





77



   




6011




5





 





 




  
5
  




 





13



     use warnings; 




 




5





 





 





 





 





4



   




 




5





 





 





 





 





100



   




6012




5





 





 




  
5
  




 





13



     use base qw(SQL::Yapp::Obj1); 




 




5





 





 





 





 





5



   




 




5





 





 





 





 





1117



   




6013




 





 





 





 





 





 



   




6014



  
0
  




 





 




  
0
  




 





0



     sub tabname($) { return $_[0]; } 




6015




 





 





 





 





 





 



 } 




6016




 





 





 





 





 





 



   




6017




 





 





 





 





 





 



 # Column: 




6018




 





 





 





 





 





 



 { 




6019




 





 





 





 





 





 



     package SQL::Yapp::Column; 




6020




 





 





 





 





 





 



   




6021




5





 





 




  
5
  




 





18



     use strict; 




 




5





 





 





 





 





7



   




 




5





 





 





 





 





79



   




6022




5





 





 




  
5
  




 





13



     use warnings; 




 




5





 





 





 





 





6



   




 




5





 





 





 





 





95



   




6023




5





 





 




  
5
  




 





16



     use base qw(SQL::Yapp::Obj1); 




 




5





 





 





 





 





5



   




 




5





 





 





 





 





1452



   




6024




 





 





 





 





 





 



   




6025




2





 





 




  
2
  




 





6



     sub column1($)       { return $_[0]; } 




6026




3





 





 




  
3
  




 





8



     sub exprparen($)     { return $_[0]; } 




6027




1





 





 




  
1
  




 





3



     sub expr($)          { return $_[0]; } 




6028



  
0
  




 





 




  
0
  




 





0



     sub expr_or_check($) { return $_[0]; } 




6029




2





 





 




  
2
  




 





6



     sub asc($)           { return $_[0]; } 




6030




5





 





 




  
5
  




 





13



     sub desc($)          { return SQL::Yapp::Desc->obj($_[0]); } 




6031




 





 





 





 





 





 



 } 




6032




 





 





 





 





 





 



   




6033




 





 





 





 





 





 



 # Table: 




6034




 





 





 





 





 





 



 { 




6035




 





 





 





 





 





 



     package SQL::Yapp::Table; 




6036




5





 





 




  
5
  




 





23



     use strict; 




 




5





 





 





 





 





3



   




 




5





 





 





 





 





79



   




6037




5





 





 




  
5
  




 





14



     use warnings; 




 




5





 





 





 





 





5



   




 




5





 





 





 





 





187



   




6038




5





 





 




  
5
  




 





16



     use base qw(SQL::Yapp::Obj1); 




 




5





 





 





 





 





5



   




 




5





 





 





 





 





1067



   




6039




5





 





 




  
5
  




 





10



     sub table1($) { return $_[0]; } 




6040




 





 





 





 





 





 



 } 




6041




 





 





 





 





 





 



   




6042




 





 





 





 





 





 



 # CharSet: 




6043




 





 





 





 





 





 



 { 




6044




 





 





 





 





 





 



     package SQL::Yapp::CharSet; 




6045




5





 





 




  
5
  




 





20



     use strict; 




 




5





 





 





 





 





5



   




 




5





 





 





 





 





89



   




6046




5





 





 




  
5
  




 





22



     use warnings; 




 




5





 





 





 





 





6



   




 




5





 





 





 





 





118



   




6047




5





 





 




  
5
  




 





107



     use base qw(SQL::Yapp::Obj1); 




 




5





 





 





 





 





7



   




 




5





 





 





 





 





1308



   




6048



  
0
  




 





 




  
0
  




 





0



     sub charset1($) { return $_[0]; } 




6049




 





 





 





 





 





 



 } 




6050




 





 





 





 





 





 



   




6051




 





 





 





 





 





 



 # Collate: 




6052




 





 





 





 





 





 



 { 




6053




 





 





 





 





 





 



     package SQL::Yapp::Collate; 




6054




5





 





 




  
5
  




 





21



     use strict; 




 




5





 





 





 





 





7



   




 




5





 





 





 





 





87



   




6055




5





 





 




  
5
  




 





18



     use warnings; 




 




5





 





 





 





 





4



   




 




5





 





 





 





 





119



   




6056




5





 





 




  
5
  




 





14



     use base qw(SQL::Yapp::Obj1); 




 




5





 





 





 





 





10



   




 




5





 





 





 





 





1233



   




6057



  
0
  




 





 




  
0
  




 





0



     sub collate1($) { return $_[0]; } 




6058




 





 





 





 





 





 



 } 




6059




 





 





 





 





 





 



   




6060




 





 





 





 





 





 



 # Constraint: 




6061




 





 





 





 





 





 



 { 




6062




 





 





 





 





 





 



     package SQL::Yapp::Constraint; 




6063




5





 





 




  
5
  




 





46



     use strict; 




 




5





 





 





 





 





5



   




 




5





 





 





 





 





82



   




6064




5





 





 




  
5
  




 





13



     use warnings; 




 




5





 





 





 





 





6



   




 




5





 





 





 





 





112



   




6065




5





 





 




  
5
  




 





16



     use base qw(SQL::Yapp::Obj1); 




 




5





 





 





 





 





4



   




 




5





 





 





 





 





1253



   




6066



  
0
  




 





 




  
0
  




 





0



     sub constraint1($) { return $_[0]; } 




6067




 





 





 





 





 





 



 } 




6068




 





 





 





 





 





 



   




6069




 





 





 





 





 





 



 # Index: 




6070




 





 





 





 





 





 



 { 




6071




 





 





 





 





 





 



     package SQL::Yapp::Index; 




6072




5





 





 




  
5
  




 





29



     use strict; 




 




5





 





 





 





 





6



   




 




5





 





 





 





 





97



   




6073




5





 





 




  
5
  




 





15



     use warnings; 




 




5





 





 





 





 





4



   




 




5





 





 





 





 





124



   




6074




5





 





 




  
5
  




 





14



     use base qw(SQL::Yapp::Obj1); 




 




5





 





 





 





 





5



   




 




5





 





 





 





 





1186



   




6075



  
0
  




 





 




  
0
  




 





0



     sub index1($) { return $_[0]; } 




6076




 





 





 





 





 





 



 } 




6077




 





 





 





 





 





 



   




6078




 





 





 





 





 





 



 # Transliteration: 




6079




 





 





 





 





 





 



 { 




6080




 





 





 





 





 





 



     package SQL::Yapp::Transliteration; 




6081




5





 





 




  
5
  




 





24



     use strict; 




 




5





 





 





 





 





6



   




 




5





 





 





 





 





100



   




6082




5





 





 




  
5
  




 





20



     use warnings; 




 




5





 





 





 





 





5



   




 




5





 





 





 





 





120



   




6083




5





 





 




  
5
  




 





14



     use base qw(SQL::Yapp::Obj1); 




 




5





 





 





 





 





5



   




 




5





 





 





 





 





1220



   




6084



  
0
  




 





 




  
0
  




 





0



     sub transliteration($) { return $_[0]; } 




6085




 





 





 





 





 





 



 } 




6086




 





 





 





 





 





 



   




6087




 





 





 





 





 





 



 # Transcoding: 




6088




 





 





 





 





 





 



 { 




6089




 





 





 





 





 





 



     package SQL::Yapp::Transcoding; 




6090




5





 





 




  
5
  




 





24



     use strict; 




 




5





 





 





 





 





7



   




 




5





 





 





 





 





85



   




6091




5





 





 




  
5
  




 





14



     use warnings; 




 




5





 





 





 





 





4



   




 




5





 





 





 





 





122



   




6092




5





 





 




  
5
  




 





20



     use base qw(SQL::Yapp::Obj1); 




 




5





 





 





 





 





9



   




 




5





 





 





 





 





1196



   




6093



  
0
  




 





 




  
0
  




 





0



     sub transcoding($) { return $_[0]; } 




6094




 





 





 





 





 





 



 } 




6095




 





 





 





 





 





 



   




6096




 





 





 





 





 





 



 # TableOption: 




6097




 





 





 





 





 





 



 { 




6098




 





 





 





 





 





 



     package SQL::Yapp::TableOption; 




6099




5





 





 




  
5
  




 





27



     use strict; 




 




5





 





 





 





 





9



   




 




5





 





 





 





 





89



   




6100




5





 





 




  
5
  




 





13



     use warnings; 




 




5





 





 





 





 





6



   




 




5





 





 





 





 





140



   




6101




5





 





 




  
5
  




 





16



     use base qw(SQL::Yapp::Obj1); 




 




5





 





 





 





 





4



   




 




5





 





 





 





 





1231



   




6102




2





 





 




  
2
  




 





4



     sub tableopt($) { return $_[0]; } 




6103




 





 





 





 





 





 



 } 




6104




 





 





 





 





 





 



   




6105




 





 





 





 





 





 



 # Engine: 




6106




 





 





 





 





 





 



 { 




6107




 





 





 





 





 





 



     package SQL::Yapp::Engine; 




6108




5





 





 




  
5
  




 





19



     use strict; 




 




5





 





 





 





 





5



   




 




5





 





 





 





 





98



   




6109




5





 





 




  
5
  




 





14



     use warnings; 




 




5





 





 





 





 





7



   




 




5





 





 





 





 





136



   




6110




5





 





 




  
5
  




 





15



     use base qw(SQL::Yapp::Obj1); 




 




5





 





 





 





 





5



   




 




5





 





 





 





 





1238



   




6111



  
0
  




 





 




  
0
  




 





0



     sub engine1($) { return $_[0]; } 




6112




 





 





 





 





 





 



 } 




6113




 





 





 





 





 





 



   




6114




 





 





 





 





 





 



   




6115




 





 





 





 





 





 



 # Join: 




6116




 





 





 





 





 





 



 { 




6117




 





 





 





 





 





 



     package SQL::Yapp::Join; 




6118




 





 





 





 





 





 



   




6119




5





 





 




  
5
  




 





30



     use strict; 




 




5





 





 





 





 





5



   




 




5





 





 





 





 





111



   




6120




5





 





 




  
5
  




 





15



     use warnings; 




 




5





 





 





 





 





5



   




 




5





 





 





 





 





122



   




6121




5





 





 




  
5
  




 





16



     use base qw(SQL::Yapp::Obj1); 




 




5





 





 





 





 





5



   




 




5





 





 





 





 





1196



   




6122




 





 





 





 





 





 



   




6123




4





 





 




  
4
  




 





7



     sub joinclause($) { return $_[0]; } 




6124




 





 





 





 





 





 



 } 




6125




 





 





 





 





 





 



   




6126




 





 





 





 





 





 



 # Check: 




6127




 





 





 





 





 





 



 { 




6128




 





 





 





 





 





 



     package SQL::Yapp::Check; 




6129




 





 





 





 





 





 



   




6130




5





 





 




  
5
  




 





21



     use strict; 




 




5





 





 





 





 





10



   




 




5





 





 





 





 





85



   




6131




5





 





 




  
5
  




 





15



     use warnings; 




 




5





 





 





 





 





5



   




 




5





 





 





 





 





157



   




6132




5





 





 




  
5
  




 





15



     use base qw(SQL::Yapp::Obj1); 




 




5





 





 





 





 





5



   




 




5





 





 





 





 





1615



   




6133




 





 





 





 





 





 



   




6134




3





 





 




  
3
  




 





21



     sub check($)         { return $_[0]; } 




6135




3





 





 




  
3
  




 





7



     sub expr_or_check($) { return $_[0]; } 




6136




 





 





 





 





 





 



   




6137




 





 





 





 





 





 



     sub obj($$) 




6138




 





 





 





 





 





 



     { 




6139




18




  
100
  




 




  
18
  




 





49



         if (ref($_[1]) eq $_[0]) { 




 




 




  
100
  




 





 





 





 



   




6140




9





 





 





 





 





53



             return $_[1]; 




6141




 





 





 





 





 





 



         } 




6142




 





 





 





 





 





 



         elsif (ref($_[1])) { 




6143




7





 





 





 





 





15



             bless($_[1], $_[0]); 




6144




 





 





 





 





 





 



         } 




6145




 





 





 





 





 





 



         else { 




6146




2





 





 





 





 





8



             $_[0]->SUPER::obj($_[1]); 




6147




 





 





 





 





 





 



         } 




6148




 





 





 





 





 





 



     } 




6149




 





 





 





 





 





 



 } 




6150




 





 





 





 





 





 



   




6151




 





 





 





 





 





 



 # Expr: 




6152




 





 





 





 





 





 



 { 




6153




 





 





 





 





 





 



     package SQL::Yapp::Expr; 




6154




 





 





 





 





 





 



   




6155




5





 





 




  
5
  




 





23



     use strict; 




 




5





 





 





 





 





5



   




 




5





 





 





 





 





107



   




6156




5





 





 




  
5
  




 





19



     use warnings; 




 




5





 





 





 





 





4



   




 




5





 





 





 





 





119



   




6157




5





 





 




  
5
  




 





15



     use base qw(SQL::Yapp::Obj1); 




 




5





 





 





 





 





5



   




 




5





 





 





 





 





1584



   




6158




 





 





 





 





 





 



   




6159



  
0
  




 





 




  
0
  




 





0



     sub exprparen($)     { return '('.($_[0]->value).')'; } 




6160




18





 





 




  
18
  




 





41



     sub expr($)          { return $_[0]; } 




6161



  
0
  




 





 




  
0
  




 





0



     sub expr_or_check($) { return $_[0]; } 




6162



  
0
  




 





 




  
0
  




 





0



     sub asc($)           { return $_[0]; } 




6163



  
0
  




 





 




  
0
  




 





0



     sub desc($)          { return SQL::Yapp::Desc->obj($_[0]); } 




6164




 





 





 





 





 





 



 } 




6165




 





 





 





 





 





 



   




6166




 





 





 





 





 





 



 # Infix: 




6167




 





 





 





 





 





 



 { 




6168




 





 





 





 





 





 



     package SQL::Yapp::Infix; 




6169




 





 





 





 





 





 



   




6170




5





 





 




  
5
  




 





29



     use strict; 




 




5





 





 





 





 





6



   




 




5





 





 





 





 





89



   




6171




5





 





 




  
5
  




 





14



     use warnings; 




 




5





 





 





 





 





5



   




 




5





 





 





 





 





130



   




6172




5





 





 




  
5
  




 





16



     use base qw(SQL::Yapp::Expr); 




 




5





 





 





 





 





6



   




 




5





 





 





 





 





1251



   




6173




5





 





 




  
5
  




 





21



     use Carp qw(croak); 




 




5





 





 





 





 





13



   




 




5





 





 





 





 





1045



   




6174




 





 





 





 





 





 



   




6175




 





 





 





 





 





 



     sub obj($$$$) 




6176




 





 





 





 





 





 



     { 




6177




56





 





 




  
56
  




 





70



         my ($class, $op, $a1, $a2)= @_; 




6178




56





 





 





 





 





128



         return bless(["$a1 $op $a2", $op, $a1, $a2], $class); 




6179




 





 





 





 





 





 



     } 




6180




 





 





 





 





 





 



   




6181




14





 





 




  
14
  




 





25



     sub op($)     { return $_[0][1]; } 




6182




14





 





 




  
14
  




 





28



     sub arg1($)   { return $_[0][2]; } 




6183




14





 





 




  
14
  




 





19



     sub arg2($)   { return $_[0][3]; } 




6184




 





 





 





 





 





 



   




6185




 





 





 





 





 





 



     sub assign($) 




6186




 





 





 





 





 





 



     { 




6187




14





 





 




  
14
  




 





11



         my ($self)= @_; 




6188




14




  
 50
  




 





 





 





16



         if ($self->op() eq '=') { # we're not checking everything, just whether it's an assignment 




6189




14





 





 





 





 





21



             return $self; 




6190




 





 





 





 





 





 



         } 




6191



  
0
  




 





 





 





 





0



         croak "Assignment expected, but found top-level operator '".($self->op)."'."; 




6192




 





 





 





 





 





 



     } 




6193




 





 





 





 





 





 



 } 




6194




 





 





 





 





 





 



   




6195




 





 





 





 





 





 



 # Order: 




6196




 





 





 





 





 





 



 { 




6197




 





 





 





 





 





 



     package SQL::Yapp::Order; 




6198




 





 





 





 





 





 



   




6199




5





 





 




  
5
  




 





22



     use strict; 




 




5





 





 





 





 





6



   




 




5





 





 





 





 





103



   




6200




5





 





 




  
5
  




 





16



     use warnings; 




 




5





 





 





 





 





7



   




 




5





 





 





 





 





124



   




6201




5





 





 




  
5
  




 





16



     use base qw(SQL::Yapp::Obj1); 




 




5





 





 





 





 





8



   




 




5





 





 





 





 





1274



   




6202




5





 





 




  
5
  




 





24



     use Scalar::Util qw(blessed); 




 




5





 





 





 





 





6



   




 




5





 





 





 





 





523



   




6203




 





 





 





 





 





 



   




6204




 





 





 





 





 





 



     sub obj($$) 




6205




 





 





 





 





 





 



     { 




6206




7





 





 




  
7
  




 





22



         my ($class,$x)= @_; 




6207




7




  
 50
  



  
 33
  




 





 





58



         return $x 




6208




 





 





 





 





 





 



             if blessed($x) && $x->isa('SQL::Yapp::Obj'); 




6209



  
0
  




 





 





 





 





0



         return bless([$x], 'SQL::Yapp::Asc'); # not Order, but Asc. 




6210




 





 





 





 





 





 



     } 




6211




 





 





 





 





 





 



 } 




6212




 





 





 





 





 





 



   




6213




 





 





 





 





 





 



 # Asc: 




6214




 





 





 





 





 





 



 { 




6215




 





 





 





 





 





 



     package SQL::Yapp::Asc; 




6216




 





 





 





 





 





 



   




6217




5





 





 




  
5
  




 





19



     use strict; 




 




5





 





 





 





 





5



   




 




5





 





 





 





 





84



   




6218




5





 





 




  
5
  




 





20



     use warnings; 




 




5





 





 





 





 





9



   




 




5





 





 





 





 





122



   




6219




5





 





 




  
5
  




 





15



     use base qw(SQL::Yapp::Order); 




 




5





 





 





 





 





5



   




 




5





 





 





 





 





1587



   




6220




 





 





 





 





 





 



   




6221



  
0
  




 





 




  
0
  




 





0



     sub asc($)  { return $_[0]; } 




6222



  
0
  




 





 




  
0
  




 





0



     sub desc($) { return SQL::Yapp::Desc->obj($_[0]); } 




6223




 





 





 





 





 





 



 } 




6224




 





 





 





 





 





 



   




6225




 





 





 





 





 





 



 # Desc: 




6226




 





 





 





 





 





 



 { 




6227




 





 





 





 





 





 



     package SQL::Yapp::Desc; 




6228




 





 





 





 





 





 



   




6229




5





 





 




  
5
  




 





22



     use strict; 




 




5





 





 





 





 





4



   




 




5





 





 





 





 





91



   




6230




5





 





 




  
5
  




 





16



     use warnings; 




 




5





 





 





 





 





5



   




 




5





 





 





 





 





139



   




6231




5





 





 




  
5
  




 





16



     use base qw(SQL::Yapp::Order); 




 




5





 





 





 





 





4



   




 




5





 





 





 





 





1610



   




6232




 





 





 





 





 





 



   




6233




 





 





 





 





 





 



     sub obj($$) 




6234




 





 





 





 





 





 



     { 




6235




9





 





 




  
9
  




 





8



         my ($class, $orig)= @_; 




6236




9





 





 





 





 





14



         return bless(["$orig DESC",$orig],$class); 




6237




 





 





 





 





 





 



     } 




6238




 





 





 





 





 





 



   




6239




1





 





 




  
1
  




 





4



     sub orig($) { return $_[0][1]; } 




6240




 





 





 





 





 





 



   




6241




2





 





 




  
2
  




 





3



     sub asc($)  { return $_[0]; } 




6242




1





 





 




  
1
  




 





2



     sub desc($) { return &orig; } 




6243




 





 





 





 





 





 



 } 




6244




 





 





 





 





 





 



   




6245




 





 





 





 





 





 



 # Type: 




6246




 





 





 





 





 





 



 { 




6247




 





 





 





 





 





 



     package SQL::Yapp::Type; 




6248




 





 





 





 





 





 



   




6249




5





 





 




  
5
  




 





24



     use strict; 




 




5





 





 





 





 





11



   




 




5





 





 





 





 





124



   




6250




5





 





 




  
5
  




 





28



     use warnings; 




 




5





 





 





 





 





5



   




 




5





 





 





 





 





170



   




6251




5





 





 




  
5
  




 





16



     use base qw(SQL::Yapp::Obj); 




 




5





 





 





 





 





5



   




 




5





 





 





 





 





1258



   




6252




5





 





 




  
5
  




 





20



     use Hash::Util qw(lock_keys); 




 




5





 





 





 





 





6



   




 




5





 





 





 





 





39



   




6253




5





 





 




  
5
  




 





282



     use Carp qw(croak); 




 




5





 





 





 





 





6



   




 




5





 





 





 





 





3039



   




6254




 





 





 





 





 





 



   




6255




 





 





 





 





 





 



     sub set_base($$$) 




6256




 





 





 





 





 





 



     { 




6257




11





 





 




  
11
  




 





12



         my ($self, $base, $spec)= @_; 




6258




 





 





 





 





 





 



   




6259




 





 





 





 





 





 



         # set new spec: 




6260




11





 





 





 





 





14



         $self->{base}= $base; 




6261




11





 





 





 





 





11



         $self->{spec}= $spec; 




6262




 





 





 





 





 





 



   




6263




 





 





 





 





 





 



         # filter options by new spec: 




6264




11





 





 





 





 





7



         for my $o (keys %{ $self->{option} }) { 




 




11





 





 





 





 





27



   




6265




3




  
100
  




 





 





 





8



             unless ($spec->{$o}) { 




6266




1





 





 





 





 





2



                 delete $self->{option}{$o}; 




6267




 





 





 





 





 





 



             } 




6268




 





 





 





 





 





 



         } 




6269




 





 





 





 





 





 



   




6270




11





 





 





 





 





77



         return $self; 




6271




 





 





 





 





 





 



     } 




6272




 





 





 





 





 





 



   




6273




 





 





 





 





 





 



     sub set_property($$$) 




6274




 





 





 





 





 





 



     { 




6275




13





 





 




  
13
  




 





15



         my ($self, $key, $value)= @_; 




6276




13





 





 





 





 





30



         my %a= %$self; 




6277




13




  
 50
  




 





 





 





29



         croak "No $key for $self->{base} allowed." unless $self->{spec}{$key}; 




6278




13





 





 





 





 





15



         $self->{option}{$key}= $value; 




6279




13





 





 





 





 





15



         return $self; 




6280




 





 





 





 





 





 



     } 




6281




 





 





 





 





 





 



   




6282




 





 





 





 





 





 



     sub new($) 




6283




 





 





 





 





 





 



     { 




6284




9





 





 




  
9
  




 





1543



         my $r= bless({ base => undef, spec => undef, option => {} }, $_[0]); 




6285




9





 





 





 





 





88



         lock_keys %$r; 




6286




9





 





 





 





 





77



         return $r; 




6287




 





 





 





 





 





 



     } 




6288




 





 





 





 





 





 



   




6289




 





 





 





 





 





 



     sub obj($$) 




6290




 





 





 





 





 





 



     { 




6291




13





 





 




  
13
  




 





41



         return $_[1]; 




6292




 





 





 





 





 





 



     } 




6293




 





 





 





 





 





 



   




6294




 





 





 





 





 





 



     sub clone($) 




6295




 





 





 





 





 





 



     { 




6296




11





 





 




  
11
  




 





11



         my ($self)= @_; 




6297




 





 





 





 





 





 



         my $r= bless({ 




6298




 





 





 





 





 





 



                    %$self, 




6299




 





 





 





 





 





 



                    # no need to make a deep copy of 'spec', because it is never changed. 




6300




11





 





 





 





 





18



                    option => { %{ $self->{option} } }, 




 




11





 





 





 





 





42



   




6301




 





 





 





 





 





 



                }, __PACKAGE__); 




6302




11





 





 





 





 





26



         lock_keys %$r; 




6303




11





 





 





 





 





76



         return $r; 




6304




 





 





 





 





 





 



     } 




6305




 





 





 





 





 





 



   




6306




 





 





 





 





 





 



     sub type($) 




6307




 





 





 





 





 





 



     { 




6308




7





 





 




  
7
  




 





10



         return $_[0]->clone(); # make a copy before trying to modify this 




6309




 





 





 





 





 





 



     } 




6310




 





 





 





 





 





 



   




6311




 





 





 





 





 





 



     sub colspec($) 




6312




 





 





 





 





 





 



     { 




6313




1





 





 




  
1
  




 





6



         return SQL::Yapp::ColumnSpec->new($_[0]); # make a copy producing a ColumnSpec 




6314




 





 





 





 





 





 



     } 




6315




 





 





 





 





 





 



   




6316




 





 





 





 





 





 



     sub value($) 




6317




 





 





 





 





 





 



     { 




6318




38





 





 




  
38
  




 





44



         my ($self)= @_; 




6319




38




  
100
  




 





 





 





73



         return '' unless $self->{base}; 




6320




20





 





 





 





 





33



         my @r= ($self->{base}); 




6321




20




  
100
  



  
 66
  




 





 





79



         if ($self->{spec}{prec1} && defined $self->{option}{prec1}) { 




6322




19





 





 





 





 





18



             my $len_str= ''; 




6323




19





 





 





 





 





21



             $len_str.= $self->{option}{prec1}; 




6324




19




  
 50
  



  
 66
  




 





 





43



             if ($self->{spec}{prec2} && defined $self->{option}{prec2}) { 




6325



  
0
  




 





 





 





 





0



                 $len_str.= ', '.$self->{option}{prec2}; 




6326




 





 





 





 





 





 



             } 




6327




 





 





 





 





 





 



             else { 




6328




19




  
  0
  



  
 33
  




 





 





31



                 if ($self->{spec}{prec_mul} && $self->{option}{prec_mul}) { 




6329



  
0
  




 





 





 





 





0



                     $len_str.= ' '.$self->{option}{prec_mul}; 




6330




 





 





 





 





 





 



                 } 




6331




19




  
  0
  



  
 33
  




 





 





28



                 if ($self->{spec}{prec_unit} && $self->{option}{prec_unit}) { 




6332



  
0
  




 





 





 





 





0



                     $len_str.= ' '.$self->{option}{prec_unit}; 




6333




 





 





 





 





 





 



                 } 




6334




 





 





 





 





 





 



             } 




6335




19





 





 





 





 





28



             push @r, '('.$len_str.')'; 




6336




 





 





 





 





 





 



         } 




6337




20




  
 50
  



  
 33
  




 





 





48



         if (my $value_list= $self->{spec}{value_list} && $self->{option}{value_list}) { 




6338



  
0
  




 





 





 





 





0



             push @r, '('.join(', ',@$value_list).')'; 




6339




 





 





 





 





 





 



         } 




6340




20




  
100
  



  
 66
  




 





 





54



         if (my $x= $self->{spec}{charset} && $self->{option}{charset}) { 




6341




3





 





 





 





 





4



             push @r, 'CHARACTER SET', $x; 




6342




 





 





 





 





 





 



         } 




6343




20




  
 50
  



  
 66
  




 





 





46



         if (my $x= $self->{spec}{collate} && $self->{option}{collate}) { 




6344



  
0
  




 





 





 





 





0



             push @r, 'COLLATE', $x; 




6345




 





 





 





 





 





 



         } 




6346




20





 





 





 





 





23



         for my $key ('sign', 'zerofill', 'timezone') { 




6347




60




  
 50
  



  
 66
  




 





 





127



             if (my $x= $self->{spec}{$key} && $self->{option}{$key}) { 




6348



  
0
  




 





 





 





 





0



                 push @r, $x; 




6349




 





 





 





 





 





 



             } 




6350




 





 





 





 





 





 



         } 




6351




 





 





 





 





 





 



   




6352




20





 





 





 





 





113



         return join(' ', @r); 




6353




 





 





 





 





 





 



     } 




6354




 





 





 





 





 





 



 } 




6355




 





 





 





 





 





 



   




6356




 





 





 





 





 





 



   




6357




 





 





 





 





 





 



 # ColumnSpec: 




6358




 





 





 





 





 





 



 { 




6359




 





 





 





 





 





 



     package SQL::Yapp::ColumnSpec; 




6360




 





 





 





 





 





 



   




6361




5





 





 




  
5
  




 





23



     use strict; 




 




5





 





 





 





 





6



   




 




5





 





 





 





 





91



   




6362




5





 





 




  
5
  




 





25



     use warnings; 




 




5





 





 





 





 





5



   




 




5





 





 





 





 





117



   




6363




5





 





 




  
5
  




 





17



     use base qw(SQL::Yapp::Obj); 




 




5





 





 





 





 





11



   




 




5





 





 





 





 





1117



   




6364




5





 





 




  
5
  




 





23



     use Hash::Util qw(lock_keys); 




 




5





 





 





 





 





7



   




 




5





 





 





 





 





16



   




6365




5





 





 




  
5
  




 





233



     use Carp qw(croak); 




 




5





 





 





 





 





9



   




 




5





 





 





 





 





28910



   




6366




 





 





 





 





 





 



   




6367




 





 





 





 





 





 



     sub new($$) 




6368




 





 





 





 





 





 



     { 




6369




3





 





 




  
3
  




 





9



         my ($class, $type)= @_; 




6370




3





 





 





 





 





7



         my $r= bless({ datatype => $type->clone(), name => {}, option => {} }, $class); 




6371




3





 





 





 





 





33



         lock_keys %$r; 




6372




3





 





 





 





 





22



         return $r; 




6373




 





 





 





 





 





 



     } 




6374




 





 





 





 





 





 



   




6375




 





 





 





 





 





 



     sub obj($$) 




6376




 





 





 





 





 





 



     { 




6377




3





 





 




  
3
  




 





11



         return $_[1]; 




6378




 





 





 





 





 





 



     } 




6379




 





 





 





 





 





 



   




6380




 





 





 





 





 





 



     sub clone($) 




6381




 





 





 





 





 





 



     { 




6382




1





 





 




  
1
  




 





2



         my ($self)= @_; 




6383




 





 





 





 





 





 



         my $r= bless({ 




6384




 





 





 





 





 





 



                    datatype => $self->{datatype}->clone(), 




6385




1





 





 





 





 





3



                    name   => { %{ $self->{name}   } }, 




6386




1





 





 





 





 





3



                    option => { %{ $self->{option} } }, 




 




1





 





 





 





 





4



   




6387




 





 





 





 





 





 



                }, __PACKAGE__); 




6388




1





 





 





 





 





4



         lock_keys %$r; 




6389




1





 





 





 





 





6



         return $r; 




6390




 





 





 





 





 





 



     } 




6391




 





 





 





 





 





 



   




6392




 





 





 





 





 





 



     sub colspec($) 




6393




 





 





 





 





 





 



     { 




6394




1





 





 




  
1
  




 





3



         return $_[0]->clone(); # make a copy before trying to modify this 




6395




 





 





 





 





 





 



     } 




6396




 





 





 





 





 





 



   




6397




 





 





 





 





 





 



     sub name($$) 




6398




 





 





 





 





 





 



     { 




6399




6





 





 




  
6
  




 





7



         my ($self, $key)= @_; 




6400




6




  
 50
  




 





 





 





11



         if (my $x= $self->{name}{$key}) { 




6401



  
0
  




 





 





 





 





0



             return ('CONSTRAINT', $x); 




6402




 





 





 





 





 





 



         } 




6403




6





 





 





 





 





10



         return; 




6404




 





 





 





 





 





 



     } 




6405




 





 





 





 





 





 



   




6406




 





 





 





 





 





 



     sub value($) 




6407




 





 





 





 





 





 



     { 




6408




4





 





 




  
4
  




 





6



         my ($self)= @_; 




6409




4





 





 





 





 





8



         my @r= ($self->{datatype}); 




6410




 





 





 





 





 





 



   




6411




4





 





 





 





 





7



         for my $key ('notnull', 'autoinc', 'unique', 'primary', 'key') { 




6412




20




  
100
  




 





 





 





34



             if (my $x= $self->{option}{$key}) { 




6413




4





 





 





 





 





7



                 push @r, $self->name($key), $x; 




6414




 





 





 





 





 





 



             } 




6415




 





 





 





 





 





 



         } 




6416




 





 





 





 





 





 



   




6417




4





 





 





 





 





6



         for my $key ('default', 'column_format', 'storage') { 




6418




12




  
100
  




 





 





 





21



             if (my $x= $self->{option}{$key}) { 




6419




2





 





 





 





 





3



                 push @r, $self->name($key), uc($key), $x; 




6420




 





 





 





 





 





 



             } 




6421




 





 





 





 





 





 



         } 




6422




 





 





 





 





 





 



   




6423




4





 





 





 





 





7



         for my $key ('check') { 




6424




4




  
 50
  




 





 





 





10



             if (my $x= $self->{option}{$key}) { 




6425



  
0
  




 





 





 





 





0



                 push @r, $self->name($key), uc($key), '('.$x.')'; 




6426




 





 





 





 





 





 



             } 




6427




 





 





 





 





 





 



         } 




6428




 





 





 





 





 





 



   




6429




4





 





 





 





 





5



         for my $key ('references') { 




6430




4




  
 50
  




 





 





 





7



             if (my $x= $self->{option}{$key}) { 




6431



  
0
  




 





 





 





 





0



                 push @r, $self->name($key), $x; 




6432




 





 





 





 





 





 



             } 




6433




 





 





 





 





 





 



         } 




6434




 





 





 





 





 





 



   




6435




4





 





 





 





 





8



         return join(' ', @r); 




6436




 





 





 





 





 





 



     } 




6437




 





 





 





 





 





 



 } 




6438




 





 





 





 





 





 



   




6439




 





 





 





 





 





 



   




6440




 





 





 





 





 





 



 # Special Constants: 




6441




2





 





 




  
2
  



  
0
  




308



 sub ASTERISK { SQL::Yapp::Asterisk->obj(); } 




6442




1





 





 




  
1
  



  
0
  




6



 sub QUESTION { SQL::Yapp::Question->obj(); } 




6443



  
0
  




 





 




  
0
  



  
0
  




0



 sub NULL     { SQL::Yapp::ExprSpecial->obj('NULL'); } 




6444



  
0
  




 





 




  
0
  



  
0
  




0



 sub TRUE     { SQL::Yapp::ExprSpecial->obj('TRUE'); } 




6445



  
0
  




 





 




  
0
  



  
0
  




0



 sub FALSE    { SQL::Yapp::ExprSpecial->obj('FALSE'); } 




6446



  
0
  




 





 




  
0
  



  
0
  




0



 sub UNKNOWN  { SQL::Yapp::ExprSpecial->obj('UNKNOWN'); } 




6447



  
0
  




 





 




  
0
  



  
0
  




0



 sub DEFAULT  { SQL::Yapp::ExprSpecial->obj('DEFAULT'); } 




6448




 





 





 





 





 





 



   




6449




 





 





 





 





 





 



   




6450




 





 





 





 





 





 



 # Wrapped DBI methods: 




6451




 





 





 





 





 





 



 sub croak_no_ref($) 




6452




 





 





 





 





 





 



 { 




6453




1





 





 




  
1
  



  
0
  




2



     my ($self)= @_; 




6454




1





 





 





 





 





3



     croak "Error: Wrong type argument from interpolated code:\n". 




6455




 





 





 





 





 





 



         "\tExpected scalar, but found ".my_dumper($self); 




6456




 





 





 





 





 





 



 } 




6457




 





 





 





 





 





 



   




6458




 





 





 





 





 





 



 ######################################## 




6459




 





 





 





 





 





 



 # Generators: 




6460




 





 





 





 





 





 



   




6461




 





 





 





 





 





 



 # These functions are used to typecheck interpolated Perl code's 




6462




 





 





 





 





 





 



 # result values and to generate objects on the fly if that's possible. 




6463




 





 





 





 





 





 



 # Usually on-the-fly generation coerces basic Perl types to a blessed 




6464




 





 





 





 





 





 



 # object, but it would also be feasible to coerce objects to objects. 




6465




 





 





 





 





 





 



 # Some 'generator' functions don't generate at all, but simply type 




6466




 





 





 





 





 





 



 # check. 




6467




 





 





 





 





 





 



 # 




6468




 





 





 





 





 





 



 # Note: often these functions are invoked in string context, which 




6469




 





 





 





 





 





 



 # means that directly after their invocation, the string cast operator 




6470




 





 





 





 





 





 



 # is invoked.  However, there's no easy way to prevent object creation 




6471




 





 





 





 





 





 



 # in that case, because there is no such thing as 'wantstring' 




6472




 





 





 





 





 





 



 # (would-be analog to 'wantarray').  So these functions must always 




6473




 





 





 





 





 





 



 # return a blessed reference. 




6474




 





 





 





 





 





 



   




6475




 





 





 





 





 





 



 sub _functor($$@) 




6476




 





 





 





 





 





 



 { 




6477




106





 





 




  
106
  




 





137



     my ($functor, $parens, @arg)= @_; 




6478




 





 





 





 





 





 



   




6479




 





 





 





 





 





 



     # possibly translate the functor to a different SQL dialect: 




6480




106




  
100
  




 





 





 





211



     if (my $dialect= $functor->{dialect}) { 




6481




97




  
100
  




 





 





 





152



         if (my $f2= find_ref(%$dialect, $write_dialect)) { 




6482




28





 





 





 





 





27



             $functor= $f2; 




6483




 





 





 





 





 





 



         } 




6484




 





 





 





 





 





 



     } 




6485




 





 





 





 





 





 



   




6486




 





 





 





 





 





 



     # print it: 




6487




106





 





 





 





 





126



     my $name= $functor->{value}; 




6488




 





 





 





 





 





 



   




6489




 





 





 





 





 





 



     # prefix and suffix are not handled here, because they behave 




6490




 





 





 





 





 





 



     # differently: they assume exactly one argument are applied 




6491




 





 





 





 





 





 



     # point-wise.  They cannot be switched (ok, we might switch 




6492




 





 





 





 





 





 



     # between prefix and suffix, but that's not supported yet). 




6493




 





 





 





 





 





 



     my $s= switch ($functor->{type}, 




6494




 





 





 





 





 





 



         'infix()' => sub { 




6495




 





 





 





 





 





 



             (scalar(@arg) ? 




6496




 





 





 





 





 





 



                join(" $name ", @arg) 




6497




 





 





 





 





 





 



             : defined($functor->{result0}) ? 




6498




 





 





 





 





 





 



                get_quote_val->($functor->{result0}) 




6499




52




  
 50
  




 




  
52
  




 





187



             :  die "Error: Functor $functor->{value} used with 0 args, but requires at least one." 




 




 




  
100
  




 





 





 





 



   




6500




 





 





 





 





 





 



             ); 




6501




 





 





 





 





 





 



         }, 




6502




 





 





 





 





 





 



         'funcall' => sub { 




6503




21





 





 




  
21
  




 





19



             $parens= 0; 




6504




21





 





 





 





 





49



             "$name(".join(", ", @arg).")"; 




6505




 





 





 





 





 





 



         }, 




6506




 





 





 





 





 





 



         'prefix' => sub { 




6507




26




  
100
  




 




  
26
  




 





43



             die "Error: Exactly one argument expected for operator $functor->{value},\n". 




6508




 





 





 





 





 





 



                 "\tfound (".join(",", @arg).")" 




6509




 





 





 





 





 





 



                 unless scalar(@arg) == 1; 




6510




25





 





 





 





 





52



             "$name $arg[0]" 




6511




 





 





 





 





 





 



         }, 




6512




 





 





 





 





 





 



         'suffix' => sub { 




6513




7




  
 50
  




 




  
7
  




 





15



             die "Error: exactly one argument expected, found @arg" unless scalar(@arg) == 1; 




6514




7





 





 





 





 





12



             "$arg[0] $name" 




6515




 





 





 





 





 





 



         }, 




6516




106





 





 





 





 





616



     ); 




6517




105




  
100
  




 





 





 





830



     return $parens ? "($s)" : $s; 




6518




 





 





 





 





 





 



 } 




6519




 





 





 





 





 





 



   




6520




 





 





 





 





 





 



 sub _prefix($$@) 




6521




 





 





 





 





 





 



 { 




6522




67





 





 




  
67
  




 





141



     my ($name, $parens)= splice @_,0,2; 




6523




67





 




  
100
  




 





 





226



     return _functor($functor_prefix{$name} || { value => $name, type => 'funcall' } , $parens, @_); 




6524




 





 





 





 





 





 



 } 




6525




 





 





 





 





 





 



   




6526




 





 





 





 





 





 



 sub _suffix($$@) 




6527




 





 





 





 





 





 



 { 




6528




39





 





 




  
39
  




 





343



     my ($name, $parens)= splice @_,0,2; 




6529




39





 





 





 





 





78



     return _functor($functor_suffix{$name}, $parens, @_); 




6530




 





 





 





 





 





 



 } 




6531




 





 





 





 





 





 



   




6532




 





 





 





 





 





 



 sub _max1_if_scalar(@) 




6533




 





 





 





 





 





 



 { 




6534




 





 





 





 





 





 



     # void context: 




6535




219




  
100
  




 




  
219
  




 





322



     unless (defined wantarray) { 




6536




1




  
 50
  




 





 





 





3



         return if scalar(@_) == 0; # allow void context with no params (e.g. after Do) 




6537




1





 





 





 





 





134



         croak 'Error: NYI: void context is currently not supported for SQL blocks.'; 




6538




 





 





 





 





 





 



     } 




6539




 





 





 





 





 





 



   




6540




 





 





 





 





 





 



     # list context: 




6541




218




  
100
  




 





 





 





320



     return @_ if wantarray; 




6542




 





 





 





 





 





 



   




6543




 





 





 





 





 





 



     # scalar context: 




6544




191




  
100
  




 





 





 





366



     croak 'Error: Multiple results cannot be assigned to scalar' 




6545




 





 





 





 





 





 



         if scalar(@_) > 1; 




6546




190





 





 





 





 





359



     return $_[0]; 




6547




 





 





 





 





 





 



 } 




6548




 





 





 





 





 





 



   




6549




 





 





 





 





 





 



 sub min1(@) 




6550




 





 





 





 





 





 



 { 




6551



  
0
  



  
  0
  




 




  
0
  



  
0
  




0



     croak 'Error: Expected at least one element, but found an empty list' 




6552




 





 





 





 





 





 



         if scalar(@_) == 0; 




6553



  
0
  




 





 





 





 





0



     return @_; 




6554




 





 





 





 





 





 



 } 




6555




 





 





 





 





 





 



   




6556




 





 





 





 





 





 



 sub min1default($@) 




6557




 





 





 





 





 





 



 { 




6558



  
0
  



  
  0
  




 




  
0
  



  
0
  




0



     return @_ if scalar(@_) == 1; 




6559



  
0
  




 





 





 





 





0



     shift; 




6560



  
0
  




 





 





 





 





0



     return @_; 




6561




 





 





 





 





 





 



 } 




6562




 





 





 





 





 





 



   




6563




 





 





 





 





 





 



 sub joinlist($$$$$@) 




6564




 





 





 





 





 





 



 { 




6565




213




  
100
  




 




  
213
  



  
0
  




337



     if (scalar(@_) == 5) { 




6566




1




  
 50
  




 





 





 





5



         return $_[1] if defined $_[1]; 




6567



  
0
  




 





 





 





 





0



         my ($module, $file, $line)= caller; 




6568



  
0
  




 





 





 





 





0



         croak "$file:$_[0]: Error: Expected at least one element, but found an empty list"; 




6569




 





 





 





 





 





 



     } 




6570




212





 





 





 





 





594



     return $_[2].join ($_[3], @_[5..$#_]).$_[4]; 




6571




 





 





 





 





 





 



 } 




6572




 





 





 





 





 





 



   




6573




 





 





 





 





 





 



 sub assign($) # check that the result is an assignment, i.e.:`a` =  




6574




 





 





 





 





 





 



 { 




6575




14





 





 




  
14
  



  
0
  




12



     my ($x)= @_; 




6576




14




  
 50
  




 





 





 





17



     if (ref($x)) { 




6577




14





 





 





 





 





17



         return $x->assign(); 




6578




 





 





 





 





 





 



     } 




6579




 





 





 





 





 





 



     else { 




6580



  
0
  




 





 





 





 





0



         croak "Assignment expected, but found non-reference."; 




6581




 





 





 





 





 





 



     } 




6582




 





 





 





 





 





 



 } 




6583




 





 





 





 





 





 



   




6584




 





 





 





 





 





 



 sub set2values(@) 




6585




 





 





 





 





 





 



 { 




6586




7




  
 50
  




 




  
7
  



  
0
  




14



     croak "At least one value expected" if scalar(@_) == 0; 




6587




 





 





 





 





 





 



     return 




6588




 





 





 





 





 





 



         ' ('. 




6589




14





 





 





 





 





15



         join(',', map { assign($_)->arg1() } @_). 




6590




 





 





 





 





 





 



         ') VALUES ('. 




6591




7





 





 





 





 





10



         join(',', map { $_->arg2() } @_). 




 




14





 





 





 





 





17



   




6592




 





 





 





 





 





 



         ')'; 




6593




 





 





 





 





 





 



 } 




6594




 





 





 





 





 





 



   




6595




 





 





 





 





 





 



 sub exprlist($) 




6596




 





 





 





 





 





 



 { 




6597




7





 





 




  
7
  



  
0
  




13



     my ($x)= @_; 




6598




7




  
 50
  




 





 





 





16



     croak "Array reference expected for expression list" 




6599




 





 





 





 





 





 



        unless ref($x) eq 'ARRAY'; 




6600




7




  
 50
  




 





 





 





12



     croak "At least one element expected in expression list" 




6601




 





 





 





 





 





 



        unless scalar(@$x) >= 1; 




6602




7





 





 





 





 





9



     return '('.join(', ', map { expr($_) } @$x).')'; 




 




14





 





 





 





 





15



   




6603




 





 





 





 





 





 



 } 




6604




 





 





 





 





 





 



   




6605




 





 





 





 





 





 



 #################### 




6606




 





 





 





 





 





 



 # Type 




6607




 





 





 





 





 





 



   




6608




 





 





 





 





 





 



 sub type($) 




6609




 





 





 





 





 





 



 { 




6610




7





 





 




  
7
  



  
0
  




1395



     my ($x)= @_; 




6611




7




  
 50
  




 





 





 





14



     if (ref($x)) { 




6612




7





 





 





 





 





14



         return $x->type(); 




6613




 





 





 





 





 





 



     } 




6614




 





 





 





 





 





 



     else { 




6615



  
0
  




 





 





 





 





0



         croak "Type expected, but found non-reference (user types are not supported yet)."; 




6616




 





 





 





 





 





 



     } 




6617




 





 





 





 





 





 



 } 




6618




 





 





 





 





 





 



   




6619




 





 





 





 





 





 



 # These have $self at the end because it's easier to generate code like that. 




6620




 





 





 





 





 





 



 sub type_base($$) 




6621




 





 





 





 





 





 



 { 




6622




11





 





 




  
11
  



  
0
  




39



     my $self= pop @_; 




6623




11





 





 





 





 





16



     my ($base)= @_; 




6624




11




  
 50
  




 





 





 





20



     croak "Unrecognised base type '$base'" unless 




6625




 





 





 





 





 





 



         my $spec= find_ref(%type_spec, $base); 




6626




11




  
 50
  




 





 





 





23



     die unless $self; 




6627




11





 





 





 





 





24



     return $self->set_base($base, $spec); 




6628




 





 





 





 





 





 



 } 




6629




 





 





 





 





 





 



   




6630




 





 





 





 





 





 



 sub type_basewlist($@) 




6631




 





 





 





 





 





 



 { 




6632



  
0
  




 





 




  
0
  



  
0
  




0



     my $self= pop @_; 




6633



  
0
  




 





 





 





 





0



     my ($base, @value)= @_; 




6634



  
0
  



  
  0
  




 





 





 





0



     croak "Unrecognised base type '$base'" unless 




6635




 





 





 





 





 





 



         my $spec= find_ref(%type_spec, $base); 




6636



  
0
  



  
  0
  




 





 





 





0



     die unless $self; 




6637



  
0
  




 





 





 





 





0



     $self->set_base($base, $spec); 




6638



  
0
  




 





 





 





 





0



     $self->set_property('value_list', \@value); 




6639



  
0
  




 





 





 





 





0



     return $self; 




6640




 





 





 





 





 





 



 } 




6641




 





 





 





 





 





 



   




6642




 





 





 





 





 





 



 sub type_length($$;$) 




6643




 





 





 





 





 





 



 { 




6644




11





 





 




  
11
  



  
0
  




12



     my $self= pop @_; 




6645




11





 





 





 





 





9



     my ($prec1, $prec2)= @_; 




6646




11





 





 





 





 





16



     $self->set_property('prec1', $prec1); 




6647




11




  
 50
  




 





 





 





16



     $self->set_property('prec2', $prec2) if defined $prec2; 




6648




11





 





 





 





 





32



     return $self; 




6649




 





 





 





 





 





 



 } 




6650




 





 





 





 





 





 



   




6651




 





 





 





 





 





 



 sub type_largelength($$$;$) 




6652




 





 





 





 





 





 



 { 




6653



  
0
  




 





 




  
0
  



  
0
  




0



     my $self= pop @_; 




6654



  
0
  




 





 





 





 





0



     my ($coeff, $mul, $unit)= @_; 




6655



  
0
  




 





 





 





 





0



     $self->set_property('prec1',      $coeff); 




6656



  
0
  



  
  0
  




 





 





 





0



     $self->set_property('prec_mul',   $mul)  if defined $mul; 




6657



  
0
  



  
  0
  




 





 





 





0



     $self->set_property('prec_unit',  $unit) if defined $unit; 




6658



  
0
  




 





 





 





 





0



     return $self; 




6659




 





 





 





 





 





 



 } 




6660




 





 





 





 





 





 



   




6661




 





 





 





 





 





 



 sub type_property($$$) 




6662




 





 





 





 





 





 



 { 




6663




2





 





 




  
2
  



  
0
  




4



     my $self= pop @_; 




6664




2





 





 





 





 





3



     my ($key,$value)= @_; 




6665




2





 





 





 





 





4



     $self->set_property($key,$value); 




6666




2





 





 





 





 





4



     return $self; 




6667




 





 





 





 





 





 



 } 




6668




 





 





 





 





 





 



   




6669




 





 





 





 





 





 



 #################### 




6670




 





 





 





 





 





 



 # ColumnSpec 




6671




 





 





 





 





 





 



   




6672




 





 





 





 





 





 



 sub colspec($) 




6673




 





 





 





 





 





 



 { 




6674




2





 





 




  
2
  



  
0
  




280



     my ($x)= @_; 




6675




2




  
 50
  




 





 





 





6



     if (ref($x)) { 




6676




2





 





 





 





 





6



         return $x->colspec(); 




6677




 





 





 





 





 





 



     } 




6678




 





 





 





 





 





 



     else { 




6679



  
0
  




 





 





 





 





0



         croak "ColumnSpec expected, but found non-reference (user types are not supported yet)."; 




6680




 





 





 





 





 





 



     } 




6681




 





 





 





 





 





 



 } 




6682




 





 





 





 





 





 



   




6683




 





 





 





 





 





 



 sub colspec_property($$$$) 




6684




 





 





 





 





 





 



 { 




6685




4





 





 




  
4
  



  
0
  




10



     my $self= pop @_; 




6686




4





 





 





 





 





6



     my ($name, $key, $value)= @_; 




6687




4





 





 





 





 





6



     $self->{name}{$key}=   $name; 




6688




4





 





 





 





 





5



     $self->{option}{$key}= $value; 




6689




4





 





 





 





 





15



     return $self; 




6690




 





 





 





 





 





 



 } 




6691




 





 





 





 





 





 



   




6692




 





 





 





 





 





 



 sub colspec_type_base($$) 




6693




 





 





 





 





 





 



 { 




6694



  
0
  




 





 




  
0
  



  
0
  




0



     my $self= pop @_; 




6695



  
0
  




 





 





 





 





0



     my ($base)= @_; 




6696



  
0
  




 





 





 





 





0



     type_base($base, $self->{datatype}); 




6697



  
0
  




 





 





 





 





0



     return $self; 




6698




 





 





 





 





 





 



 } 




6699




 





 





 





 





 





 



   




6700




 





 





 





 





 





 



 sub colspec_type_property($$$) 




6701




 





 





 





 





 





 



 { 




6702



  
0
  




 





 




  
0
  



  
0
  




0



     my $self= pop @_; 




6703



  
0
  




 





 





 





 





0



     my ($key, $value)= @_; 




6704



  
0
  




 





 





 





 





0



     type_property($key, $value, $self->{datatype}); 




6705



  
0
  




 





 





 





 





0



     return $self; 




6706




 





 





 





 





 





 



 } 




6707




 





 





 





 





 





 



   




6708




 





 





 





 





 





 



 sub colspec_type_basewlist($@) 




6709




 





 





 





 





 





 



 { 




6710



  
0
  




 





 




  
0
  



  
0
  




0



     my $self= pop @_; 




6711



  
0
  




 





 





 





 





0



     my ($base, @value)= @_; 




6712



  
0
  




 





 





 





 





0



     type_basewlist($base, @value, $self->{datatype}); 




6713



  
0
  




 





 





 





 





0



     return $self; 




6714




 





 





 





 





 





 



 } 




6715




 





 





 





 





 





 



   




6716




 





 





 





 





 





 



 sub colspec_type_length($$;$) 




6717




 





 





 





 





 





 



 { 




6718



  
0
  




 





 




  
0
  



  
0
  




0



     my $self= pop @_; 




6719



  
0
  




 





 





 





 





0



     my ($prec1, $prec2)= @_; 




6720



  
0
  




 





 





 





 





0



     type_length($prec1, $prec2, $self->{datatype}); 




6721



  
0
  




 





 





 





 





0



     return $self; 




6722




 





 





 





 





 





 



 } 




6723




 





 





 





 





 





 



   




6724




 





 





 





 





 





 



 sub colspec_type_largelength($$$;$) 




6725




 





 





 





 





 





 



 { 




6726



  
0
  




 





 




  
0
  



  
0
  




0



     my $self= pop @_; 




6727



  
0
  




 





 





 





 





0



     my ($coeff, $mul, $unit)= @_; 




6728



  
0
  




 





 





 





 





0



     type_largelength($coeff, $mul, $unit, $self->{datatype}); 




6729



  
0
  




 





 





 





 





0



     return $self; 




6730




 





 





 





 





 





 



 } 




6731




 





 





 





 





 





 



   




6732




 





 





 





 





 





 



 #################### 




6733




 





 





 





 





 





 



 # identifier interpolation, column and table: 




6734




 





 





 





 





 





 



   




6735




 





 





 





 





 





 



 sub tabname($) 




6736




 





 





 





 





 





 



 { 




6737




1





 





 




  
1
  



  
0
  




2



     my ($x)= @_; 




6738




1




  
 50
  




 





 





 





5



     if (ref($x)) { 




 




 




  
 50
  




 





 





 





 



   




6739



  
0
  




 





 





 





 





0



         return $x->tabname; 




6740




 





 





 





 





 





 



     } 




6741




 





 





 





 





 





 



     elsif (defined $x) { 




6742




1





 





 





 





 





2



         return SQL::Yapp::TableName->obj(get_quote_id->($xlat_table->($x))); 




6743




 





 





 





 





 





 



     } 




6744




 





 





 





 





 





 



     else { 




6745



  
0
  




 





 





 





 





0



         croak "Error: Cannot use undef/NULL as a table name"; 




6746




 





 





 





 





 





 



     } 




6747




 





 





 





 





 





 



 } 




6748




 





 





 





 





 





 



   




6749




 





 





 





 





 





 



 # Schema-qualified names: 




6750




 





 





 





 





 





 



 sub schemaname1($$$) 




6751




 





 





 





 





 





 



 { 




6752




122





 





 




  
122
  



  
0
  




96



     my ($class,$xlat,$x)= @_; 




6753




122




  
 50
  




 





 





 





151



     if (defined $x) { 




6754




122





 





 





 





 





160



         return $class->obj(get_quote_id->($xlat->($x))); 




6755




 





 





 





 





 





 



     } 




6756




 





 





 





 





 





 



     else { 




6757



  
0
  




 





 





 





 





0



         croak "Error: Cannot use undef/NULL as a table name"; 




6758




 





 





 





 





 





 



     } 




6759




 





 





 





 





 





 



 } 




6760




 





 





 





 





 





 



   




6761




 





 





 





 





 





 



 sub schemaname2($$$$) 




6762




 





 





 





 





 





 



 { 




6763




2





 





 




  
2
  



  
0
  




4



     my ($class,$xlat,$x,$y)= @_; 




6764




 





 





 





 





 





 



   




6765




2




  
100
  




 





 





 





6



     if (ref($x)) { croak_no_ref($x); } 




 




1





 





 





 





 





3



   




6766




1




  
 50
  




 





 





 





3



     if (ref($y)) { croak_no_ref($y); } 




 



  
0
  




 





 





 





 





0



   




6767




1




  
 50
  




 





 





 





3



     croak "Error: Cannot use undef/NULL as an identifier" 




6768




 





 





 





 





 





 



         unless defined $y; 




6769




 





 





 





 





 





 



   




6770




1




  
 50
  




 





 





 





5



     return $class->obj( 




6771




 





 





 





 





 





 



                get_quote_id->( 




6772




 





 





 





 





 





 



                    undef, 




6773




 





 





 





 





 





 



                    (defined $x ? $xlat_schema->($x) : undef), 




6774




 





 





 





 





 





 



                    $xlat->($y))); 




6775




 





 





 





 





 





 



 } 




6776




 





 





 





 





 





 



   




6777




 





 





 





 





 





 



 sub schemaname3($$$$$) 




6778




 





 





 





 





 





 



 { 




6779




3





 





 




  
3
  



  
0
  




4



     my ($class,$xlat,$x,$y,$z)= @_; 




6780




3




  
 50
  




 





 





 





8



     if (ref($x)) { croak_no_ref($x); } 




 



  
0
  




 





 





 





 





0



   




6781




3




  
 50
  




 





 





 





4



     if (ref($y)) { croak_no_ref($y); } 




 



  
0
  




 





 





 





 





0



   




6782




3




  
 50
  




 





 





 





5



     if (ref($z)) { croak_no_ref($z); } 




 



  
0
  




 





 





 





 





0



   




6783




3




  
 50
  




 





 





 





5



     croak "Error: Cannot use undef/NULL as an identifier" 




6784




 





 





 





 





 





 



         unless defined $z; 




6785




 





 





 





 





 





 



   




6786




3




  
 50
  




 





 





 





8



     return $class->obj( 




 




 




  
 50
  




 





 





 





 



   




6787




 





 





 





 





 





 



                get_quote_id->( 




6788




 





 





 





 





 





 



                    (defined $x ? $xlat_catalog->($x) : undef), 




6789




 





 





 





 





 





 



                    (defined $y ? $xlat_schema->($y)  : undef), 




6790




 





 





 





 





 





 



                    $xlat->($z))); 




6791




 





 





 





 





 





 



 } 




6792




 





 





 





 





 





 



   




6793




 





 





 





 





 





 



   




6794




 





 





 





 





 





 



 # Table: 




6795




 





 





 





 





 





 



 sub table1($) 




6796




 





 





 





 





 





 



 { 




6797




124





 





 




  
124
  



  
0
  




3632



     my ($x)= @_; 




6798




124




  
100
  




 





 





 





263



     return ref($x) ? $x->table1 : schemaname1('SQL::Yapp::Table', $xlat_table, $x); 




6799




 





 





 





 





 





 



 } 




6800




 





 





 





 





 





 



   




6801




 





 





 





 





 





 



 sub table2($$) 




6802




 





 





 





 





 





 



 { 




6803




2





 





 




  
2
  



  
0
  




533



     my ($x,$y)= @_; 




6804




2





 





 





 





 





6



     return schemaname2('SQL::Yapp::Table', $xlat_table, $x, $y); 




6805




 





 





 





 





 





 



 } 




6806




 





 





 





 





 





 



   




6807




 





 





 





 





 





 



 sub table3($$$) 




6808




 





 





 





 





 





 



 { 




6809




3





 





 




  
3
  



  
0
  




284



     my ($x,$y,$z)= @_; 




6810




3





 





 





 





 





6



     return schemaname3('SQL::Yapp::Table', $xlat_table, $x, $y, $z); 




6811




 





 





 





 





 





 



 } 




6812




 





 





 





 





 





 



   




6813




 





 





 





 





 





 



   




6814




 





 





 





 





 





 



 # Index: 




6815




 





 





 





 





 





 



 sub index1($) 




6816




 





 





 





 





 





 



 { 




6817



  
0
  




 





 




  
0
  



  
0
  




0



     my ($x)= @_; 




6818



  
0
  



  
  0
  




 





 





 





0



     return ref($x) ? $x->index1 : schemaname1('SQL::Yapp::Index', $xlat_index, $x); 




6819




 





 





 





 





 





 



 } 




6820




 





 





 





 





 





 



   




6821




 





 





 





 





 





 



 sub index2($$) 




6822




 





 





 





 





 





 



 { 




6823



  
0
  




 





 




  
0
  



  
0
  




0



     my ($x,$y)= @_; 




6824



  
0
  




 





 





 





 





0



     return schemaname2('SQL::Yapp::Index', $xlat_index, $x, $y); 




6825




 





 





 





 





 





 



 } 




6826




 





 





 





 





 





 



   




6827




 





 





 





 





 





 



 sub index3($$$) 




6828




 





 





 





 





 





 



 { 




6829



  
0
  




 





 




  
0
  



  
0
  




0



     my ($x,$y,$z)= @_; 




6830



  
0
  




 





 





 





 





0



     return schemaname3('SQL::Yapp::Index', $xlat_index, $x, $y, $z); 




6831




 





 





 





 





 





 



 } 




6832




 





 





 





 





 





 



   




6833




 





 





 





 





 





 



   




6834




 





 





 





 





 





 



 # CharSet: 




6835




 





 





 





 





 





 



 sub charset1($) 




6836




 





 





 





 





 





 



 { 




6837




2





 





 




  
2
  



  
0
  




5



     my ($x)= @_; 




6838




2




  
 50
  




 





 





 





79



     return ref($x) ? $x->charset1 : schemaname1('SQL::Yapp::CharSet', $xlat_charset, $x); 




6839




 





 





 





 





 





 



 } 




6840




 





 





 





 





 





 



   




6841




 





 





 





 





 





 



 sub charset2($$) 




6842




 





 





 





 





 





 



 { 




6843



  
0
  




 





 




  
0
  



  
0
  




0



     my ($x,$y)= @_; 




6844



  
0
  




 





 





 





 





0



     return schemaname2('SQL::Yapp::CharSet', $xlat_charset, $x, $y); 




6845




 





 





 





 





 





 



 } 




6846




 





 





 





 





 





 



   




6847




 





 





 





 





 





 



 sub charset3($$$) 




6848




 





 





 





 





 





 



 { 




6849



  
0
  




 





 




  
0
  



  
0
  




0



     my ($x,$y,$z)= @_; 




6850



  
0
  




 





 





 





 





0



     return schemaname3('SQL::Yapp::CharSet', $xlat_charset, $x, $y, $z); 




6851




 





 





 





 





 





 



 } 




6852




 





 





 





 





 





 



   




6853




 





 





 





 





 





 



   




6854




 





 





 





 





 





 



 # Collate: 




6855




 





 





 





 





 





 



 sub collate1($) 




6856




 





 





 





 





 





 



 { 




6857



  
0
  




 





 




  
0
  



  
0
  




0



     my ($x)= @_; 




6858



  
0
  



  
  0
  




 





 





 





0



     return ref($x) ? $x->collate1 : schemaname1('SQL::Yapp::Collate', $xlat_collate, $x); 




6859




 





 





 





 





 





 



 } 




6860




 





 





 





 





 





 



   




6861




 





 





 





 





 





 



 sub collate2($$) 




6862




 





 





 





 





 





 



 { 




6863



  
0
  




 





 




  
0
  



  
0
  




0



     my ($x,$y)= @_; 




6864



  
0
  




 





 





 





 





0



     return schemaname2('SQL::Yapp::Collate', $xlat_collate, $x, $y); 




6865




 





 





 





 





 





 



 } 




6866




 





 





 





 





 





 



   




6867




 





 





 





 





 





 



 sub collate3($$$) 




6868




 





 





 





 





 





 



 { 




6869



  
0
  




 





 




  
0
  



  
0
  




0



     my ($x,$y,$z)= @_; 




6870



  
0
  




 





 





 





 





0



     return schemaname3('SQL::Yapp::Collate', $xlat_collate, $x, $y, $z); 




6871




 





 





 





 





 





 



 } 




6872




 





 





 





 





 





 



   




6873




 





 





 





 





 





 



   




6874




 





 





 





 





 





 



 # Constraint: 




6875




 





 





 





 





 





 



 sub constraint1($) 




6876




 





 





 





 





 





 



 { 




6877



  
0
  




 





 




  
0
  



  
0
  




0



     my ($x)= @_; 




6878



  
0
  



  
  0
  




 





 





 





0



     return ref($x) ? $x->constraint1 : schemaname1('SQL::Yapp::Constraint', $xlat_constraint, $x); 




6879




 





 





 





 





 





 



 } 




6880




 





 





 





 





 





 



   




6881




 





 





 





 





 





 



 sub constraint2($$) 




6882




 





 





 





 





 





 



 { 




6883



  
0
  




 





 




  
0
  



  
0
  




0



     my ($x,$y)= @_; 




6884



  
0
  




 





 





 





 





0



     return schemaname2('SQL::Yapp::Constraint', $xlat_constraint, $x, $y); 




6885




 





 





 





 





 





 



 } 




6886




 





 





 





 





 





 



   




6887




 





 





 





 





 





 



 sub constraint3($$$) 




6888




 





 





 





 





 





 



 { 




6889



  
0
  




 





 




  
0
  



  
0
  




0



     my ($x,$y,$z)= @_; 




6890



  
0
  




 





 





 





 





0



     return schemaname3('SQL::Yapp::Constraint', $xlat_constraint, $x, $y, $z); 




6891




 





 





 





 





 





 



 } 




6892




 





 





 





 





 





 



   




6893




 





 





 





 





 





 



   




6894




 





 





 





 





 





 



 # Transliteration: 




6895




 





 





 





 





 





 



 sub transliteration1($) 




6896




 





 





 





 





 





 



 { 




6897



  
0
  




 





 




  
0
  



  
0
  




0



     my ($x)= @_; 




6898



  
0
  



  
  0
  




 





 





 





0



     return ref($x) ? $x->transliteration1 : schemaname1('SQL::Yapp::Transliteration', $xlat_transliteration, $x); 




6899




 





 





 





 





 





 



 } 




6900




 





 





 





 





 





 



   




6901




 





 





 





 





 





 



 sub transliteration2($$) 




6902




 





 





 





 





 





 



 { 




6903



  
0
  




 





 




  
0
  



  
0
  




0



     my ($x,$y)= @_; 




6904



  
0
  




 





 





 





 





0



     return schemaname2('SQL::Yapp::Transliteration', $xlat_transliteration, $x, $y); 




6905




 





 





 





 





 





 



 } 




6906




 





 





 





 





 





 



   




6907




 





 





 





 





 





 



 sub transliteration3($$$) 




6908




 





 





 





 





 





 



 { 




6909



  
0
  




 





 




  
0
  



  
0
  




0



     my ($x,$y,$z)= @_; 




6910



  
0
  




 





 





 





 





0



     return schemaname3('SQL::Yapp::Transliteration', $xlat_transliteration, $x, $y, $z); 




6911




 





 





 





 





 





 



 } 




6912




 





 





 





 





 





 



   




6913




 





 





 





 





 





 



   




6914




 





 





 





 





 





 



 # Transcoding: 




6915




 





 





 





 





 





 



 sub transcoding1($) 




6916




 





 





 





 





 





 



 { 




6917



  
0
  




 





 




  
0
  



  
0
  




0



     my ($x)= @_; 




6918



  
0
  



  
  0
  




 





 





 





0



     return ref($x) ? $x->transcoding1 : schemaname1('SQL::Yapp::Transcoding', $xlat_transcoding, $x); 




6919




 





 





 





 





 





 



 } 




6920




 





 





 





 





 





 



   




6921




 





 





 





 





 





 



 sub transcoding2($$) 




6922




 





 





 





 





 





 



 { 




6923



  
0
  




 





 




  
0
  



  
0
  




0



     my ($x,$y)= @_; 




6924



  
0
  




 





 





 





 





0



     return schemaname2('SQL::Yapp::Transcoding', $xlat_transcoding, $x, $y); 




6925




 





 





 





 





 





 



 } 




6926




 





 





 





 





 





 



   




6927




 





 





 





 





 





 



 sub transcoding3($$$) 




6928




 





 





 





 





 





 



 { 




6929



  
0
  




 





 




  
0
  



  
0
  




0



     my ($x,$y,$z)= @_; 




6930



  
0
  




 





 





 





 





0



     return schemaname3('SQL::Yapp::Transcoding', $xlat_transcoding, $x, $y, $z); 




6931




 





 





 





 





 





 



 } 




6932




 





 





 





 





 





 



   




6933




 





 





 





 





 





 



   




6934




 





 





 





 





 





 



 # Engine: 




6935




 





 





 





 





 





 



 sub engine1($) 




6936




 





 





 





 





 





 



 { 




6937




1





 





 




  
1
  



  
0
  




281



     my ($x)= @_; 




6938




1




  
 50
  




 





 





 





6



     return ref($x) ? $x->engine1 : schemaname1('SQL::Yapp::Engine', $xlat_engine, $x); 




6939




 





 





 





 





 





 



 } 




6940




 





 





 





 





 





 



   




6941




 





 





 





 





 





 



 sub engine2($$) 




6942




 





 





 





 





 





 



 { 




6943



  
0
  




 





 




  
0
  



  
0
  




0



     my ($x,$y)= @_; 




6944



  
0
  




 





 





 





 





0



     return schemaname2('SQL::Yapp::Engine', $xlat_engine, $x, $y); 




6945




 





 





 





 





 





 



 } 




6946




 





 





 





 





 





 



   




6947




 





 





 





 





 





 



 sub engine3($$$) 




6948




 





 





 





 





 





 



 { 




6949



  
0
  




 





 




  
0
  



  
0
  




0



     my ($x,$y,$z)= @_; 




6950



  
0
  




 





 





 





 





0



     return schemaname3('SQL::Yapp::Engine', $xlat_engine, $x, $y, $z); 




6951




 





 





 





 





 





 



 } 




6952




 





 





 





 





 





 



   




6953




 





 





 





 





 





 



   




6954




 





 





 





 





 





 



 # Columns: 




6955




 





 





 





 





 





 



 sub colname($) 




6956




 





 





 





 





 





 



 { 




6957




10





 





 




  
10
  



  
0
  




15



     my ($x)= @_; 




6958




10




  
 50
  




 





 





 





20



     if (ref($x)) { 




 




 




  
 50
  




 





 





 





 



   




6959



  
0
  




 





 





 





 





0



         return $x->colname; 




6960




 





 





 





 





 





 



     } 




6961




 





 





 





 





 





 



     elsif (defined $x) { 




6962




10





 





 





 





 





18



         return SQL::Yapp::ColumnName->obj(get_quote_id->($xlat_column->($x))); 




6963




 





 





 





 





 





 



     } 




6964




 





 





 





 





 





 



     else { 




6965



  
0
  




 





 





 





 





0



         croak "Error: Cannot use undef/NULL as a column name"; 




6966




 





 





 





 





 





 



     } 




6967




 





 





 





 





 





 



 } 




6968




 





 





 





 





 





 



   




6969




 





 





 





 





 





 



 sub column1($) 




6970




 





 





 





 





 





 



 { 




6971




209





 





 




  
209
  



  
0
  




19365



     my ($x)= @_; 




6972




209




  
100
  




 





 





 





373



     if (ref($x)) { 




 




 




  
 50
  




 





 





 





 



   




6973




4





 





 





 





 





8



         return $x->column1; 




6974




 





 





 





 





 





 



     } 




6975




 





 





 





 





 





 



     elsif (defined $x) { 




6976




205





 





 





 





 





295



         return SQL::Yapp::Column->obj(get_quote_id->($xlat_column->($x))); 




6977




 





 





 





 





 





 



     } 




6978




 





 





 





 





 





 



     else { 




6979



  
0
  




 





 





 





 





0



         croak "Error: Cannot use undef/NULL as an identifier"; 




6980




 





 





 





 





 





 



     } 




6981




 





 





 





 





 





 



 } 




6982




 





 





 





 





 





 



   




6983




 





 





 





 





 





 



 sub column1_single($) #internal 




6984




 





 





 





 





 





 



 { 




6985




25





 





 




  
25
  



  
0
  




23



     my ($x)= @_; 




6986




25




  
100
  




 





 





 





40



     if (ref($x)) { 




 




 




  
 50
  




 





 





 





 



   




6987




1





 





 





 





 





7



         return $x->column1_single; 




6988




 





 





 





 





 





 



     } 




6989




 





 





 





 





 





 



     elsif (defined $x) { 




6990




24





 





 





 





 





39



         return get_quote_id->($xlat_column->($x)); 




6991




 





 





 





 





 





 



     } 




6992




 





 





 





 





 





 



     else { 




6993



  
0
  




 





 





 





 





0



         croak "Error: Cannot use undef/NULL as an identifier"; 




6994




 





 





 





 





 





 



     } 




6995




 





 





 





 





 





 



 } 




6996




 





 





 





 





 





 



   




6997




 





 





 





 





 





 



 sub column2($$) 




6998




 





 





 





 





 





 



 { 




6999




25





 





 




  
25
  



  
0
  




1783



     my ($x,$y)= @_; 




7000




25





 





 





 





 





31



     return SQL::Yapp::Column->obj(table1($x).'.'.column1_single($y)); 




7001




 





 





 





 





 





 



 } 




7002




 





 





 





 





 





 



   




7003




 





 





 





 





 





 



 sub column3($$$) 




7004




 





 





 





 





 





 



 { 




7005



  
0
  




 





 




  
0
  



  
0
  




0



     my ($x,$y,$z)= @_; 




7006



  
0
  




 





 





 





 





0



     return SQL::Yapp::Column->obj(table2($x,$y).'.'.column1_single($z)); 




7007




 





 





 





 





 





 



 } 




7008




 





 





 





 





 





 



   




7009




 





 





 





 





 





 



 sub column4($$$$) 




7010




 





 





 





 





 





 



 { 




7011



  
0
  




 





 




  
0
  



  
0
  




0



     my ($w,$x,$y,$z)= @_; 




7012



  
0
  




 





 





 





 





0



     return SQL::Yapp::Column->obj(table3($w,$x,$y).'.'.column1_single($z)); 




7013




 





 





 





 





 





 



 } 




7014




 





 





 





 





 





 



   




7015




 





 





 





 





 





 



 # Generated with mkidentn.pl: 




7016



  
0
  




 





 




  
0
  



  
0
  




0



 sub table1_n($)         { map { table1        ($_   )                       } @{ $_[0] }  } 




 



  
0
  




 





 





 





 





0



   




 



  
0
  




 





 





 





 





0



   




7017



  
0
  




 





 




  
0
  



  
0
  




0



 sub table2_1n($$)       { map { table2        ($_[0], $_   )                } @{ $_[1] }  } 




 



  
0
  




 





 





 





 





0



   




 



  
0
  




 





 





 





 





0



   




7018



  
0
  




 





 




  
0
  



  
0
  




0



 sub table2_n1($$)       { map { table2        ($_   , $_[1])                } @{ $_[0] }  } 




 



  
0
  




 





 





 





 





0



   




 



  
0
  




 





 





 





 





0



   




7019



  
0
  




 





 




  
0
  



  
0
  




0



 sub table2_nn($$)       { map { table2_1n     ($_   , $_[1])                } @{ $_[0] }  } 




 



  
0
  




 





 





 





 





0



   




 



  
0
  




 





 





 





 





0



   




7020



  
0
  




 





 




  
0
  



  
0
  




0



 sub table3_11n($$$)     { map { table3        ($_[0], $_[1], $_   )         } @{ $_[2] }  } 




 



  
0
  




 





 





 





 





0



   




 



  
0
  




 





 





 





 





0



   




7021



  
0
  




 





 




  
0
  



  
0
  




0



 sub table3_1n1($$$)     { map { table3        ($_[0], $_   , $_[2])         } @{ $_[1] }  } 




 



  
0
  




 





 





 





 





0



   




 



  
0
  




 





 





 





 





0



   




7022



  
0
  




 





 




  
0
  



  
0
  




0



 sub table3_1nn($$$)     { map { table3_11n    ($_[0], $_   , $_[2])         } @{ $_[1] }  } 




 



  
0
  




 





 





 





 





0



   




 



  
0
  




 





 





 





 





0



   




7023



  
0
  




 





 




  
0
  



  
0
  




0



 sub table3_n11($$$)     { map { table3        ($_   , $_[1], $_[2])         } @{ $_[0] }  } 




 



  
0
  




 





 





 





 





0



   




 



  
0
  




 





 





 





 





0



   




7024



  
0
  




 





 




  
0
  



  
0
  




0



 sub table3_n1n($$$)     { map { table3_11n    ($_   , $_[1], $_[2])         } @{ $_[0] }  } 




 



  
0
  




 





 





 





 





0



   




 



  
0
  




 





 





 





 





0



   




7025



  
0
  




 





 




  
0
  



  
0
  




0



 sub table3_nn1($$$)     { map { table3_1n1    ($_   , $_[1], $_[2])         } @{ $_[0] }  } 




 



  
0
  




 





 





 





 





0



   




 



  
0
  




 





 





 





 





0



   




7026



  
0
  




 





 




  
0
  



  
0
  




0



 sub table3_nnn($$$)     { map { table3_1nn    ($_   , $_[1], $_[2])         } @{ $_[0] }  } 




 



  
0
  




 





 





 





 





0



   




 



  
0
  




 





 





 





 





0



   




7027




 





 





 





 





 





 



   




7028



  
0
  




 





 




  
0
  



  
0
  




0



 sub column1_n($)        { map { column1       ($_   )                       } @{ $_[0] }  } 




 



  
0
  




 





 





 





 





0



   




 



  
0
  




 





 





 





 





0



   




7029




4





 





 




  
4
  



  
0
  




2



 sub column2_1n($$)      { map { column2       ($_[0], $_   )                } @{ $_[1] }  } 




 




8





 





 





 





 





10



   




 




4





 





 





 





 





7



   




7030



  
0
  




 





 




  
0
  



  
0
  




0



 sub column2_n1($$)      { map { column2       ($_   , $_[1])                } @{ $_[0] }  } 




 



  
0
  




 





 





 





 





0



   




 



  
0
  




 





 





 





 





0



   




7031




2





 





 




  
2
  



  
0
  




597



 sub column2_nn($$)      { map { column2_1n    ($_   , $_[1])                } @{ $_[0] }  } 




 




4





 





 





 





 





11



   




 




2





 





 





 





 





6



   




7032



  
0
  




 





 




  
0
  



  
0
  




0



 sub column3_11n($$$)    { map { column3       ($_[0], $_[1], $_   )         } @{ $_[2] }  } 




 



  
0
  




 





 





 





 





0



   




 



  
0
  




 





 





 





 





0



   




7033



  
0
  




 





 




  
0
  



  
0
  




0



 sub column3_1n1($$$)    { map { column3       ($_[0], $_   , $_[2])         } @{ $_[1] }  } 




 



  
0
  




 





 





 





 





0



   




 



  
0
  




 





 





 





 





0



   




7034



  
0
  




 





 




  
0
  



  
0
  




0



 sub column3_1nn($$$)    { map { column3_11n   ($_[0], $_   , $_[2])         } @{ $_[1] }  } 




 



  
0
  




 





 





 





 





0



   




 



  
0
  




 





 





 





 





0



   




7035



  
0
  




 





 




  
0
  



  
0
  




0



 sub column3_n11($$$)    { map { column3       ($_   , $_[1], $_[2])         } @{ $_[0] }  } 




 



  
0
  




 





 





 





 





0



   




 



  
0
  




 





 





 





 





0



   




7036



  
0
  




 





 




  
0
  



  
0
  




0



 sub column3_n1n($$$)    { map { column3_11n   ($_   , $_[1], $_[2])         } @{ $_[0] }  } 




 



  
0
  




 





 





 





 





0



   




 



  
0
  




 





 





 





 





0



   




7037



  
0
  




 





 




  
0
  



  
0
  




0



 sub column3_nn1($$$)    { map { column3_1n1   ($_   , $_[1], $_[2])         } @{ $_[0] }  } 




 



  
0
  




 





 





 





 





0



   




 



  
0
  




 





 





 





 





0



   




7038



  
0
  




 





 




  
0
  



  
0
  




0



 sub column3_nnn($$$)    { map { column3_1nn   ($_   , $_[1], $_[2])         } @{ $_[0] }  } 




 



  
0
  




 





 





 





 





0



   




 



  
0
  




 





 





 





 





0



   




7039



  
0
  




 





 




  
0
  



  
0
  




0



 sub column4_111n($$$$)  { map { column4       ($_[0], $_[1], $_[2], $_   )  } @{ $_[3] }  } 




 



  
0
  




 





 





 





 





0



   




 



  
0
  




 





 





 





 





0



   




7040



  
0
  




 





 




  
0
  



  
0
  




0



 sub column4_11n1($$$$)  { map { column4       ($_[0], $_[1], $_   , $_[3])  } @{ $_[2] }  } 




 



  
0
  




 





 





 





 





0



   




 



  
0
  




 





 





 





 





0



   




7041



  
0
  




 





 




  
0
  



  
0
  




0



 sub column4_11nn($$$$)  { map { column4_111n  ($_[0], $_[1], $_   , $_[3])  } @{ $_[2] }  } 




 



  
0
  




 





 





 





 





0



   




 



  
0
  




 





 





 





 





0



   




7042



  
0
  




 





 




  
0
  



  
0
  




0



 sub column4_1n11($$$$)  { map { column4       ($_[0], $_   , $_[2], $_[3])  } @{ $_[1] }  } 




 



  
0
  




 





 





 





 





0



   




 



  
0
  




 





 





 





 





0



   




7043



  
0
  




 





 




  
0
  



  
0
  




0



 sub column4_1n1n($$$$)  { map { column4_111n  ($_[0], $_   , $_[2], $_[3])  } @{ $_[1] }  } 




 



  
0
  




 





 





 





 





0



   




 



  
0
  




 





 





 





 





0



   




7044



  
0
  




 





 




  
0
  



  
0
  




0



 sub column4_1nn1($$$$)  { map { column4_11n1  ($_[0], $_   , $_[2], $_[3])  } @{ $_[1] }  } 




 



  
0
  




 





 





 





 





0



   




 



  
0
  




 





 





 





 





0



   




7045



  
0
  




 





 




  
0
  



  
0
  




0



 sub column4_1nnn($$$$)  { map { column4_11nn  ($_[0], $_   , $_[2], $_[3])  } @{ $_[1] }  } 




 



  
0
  




 





 





 





 





0



   




 



  
0
  




 





 





 





 





0



   




7046



  
0
  




 





 




  
0
  



  
0
  




0



 sub column4_n111($$$$)  { map { column4       ($_   , $_[1], $_[2], $_[3])  } @{ $_[0] }  } 




 



  
0
  




 





 





 





 





0



   




 



  
0
  




 





 





 





 





0



   




7047



  
0
  




 





 




  
0
  



  
0
  




0



 sub column4_n11n($$$$)  { map { column4_111n  ($_   , $_[1], $_[2], $_[3])  } @{ $_[0] }  } 




 



  
0
  




 





 





 





 





0



   




 



  
0
  




 





 





 





 





0



   




7048



  
0
  




 





 




  
0
  



  
0
  




0



 sub column4_n1n1($$$$)  { map { column4_11n1  ($_   , $_[1], $_[2], $_[3])  } @{ $_[0] }  } 




 



  
0
  




 





 





 





 





0



   




 



  
0
  




 





 





 





 





0



   




7049



  
0
  




 





 




  
0
  



  
0
  




0



 sub column4_n1nn($$$$)  { map { column4_11nn  ($_   , $_[1], $_[2], $_[3])  } @{ $_[0] }  } 




 



  
0
  




 





 





 





 





0



   




 



  
0
  




 





 





 





 





0



   




7050



  
0
  




 





 




  
0
  



  
0
  




0



 sub column4_nn11($$$$)  { map { column4_1n11  ($_   , $_[1], $_[2], $_[3])  } @{ $_[0] }  } 




 



  
0
  




 





 





 





 





0



   




 



  
0
  




 





 





 





 





0



   




7051



  
0
  




 





 




  
0
  



  
0
  




0



 sub column4_nn1n($$$$)  { map { column4_1n1n  ($_   , $_[1], $_[2], $_[3])  } @{ $_[0] }  } 




 



  
0
  




 





 





 





 





0



   




 



  
0
  




 





 





 





 





0



   




7052



  
0
  




 





 




  
0
  



  
0
  




0



 sub column4_nnn1($$$$)  { map { column4_1nn1  ($_   , $_[1], $_[2], $_[3])  } @{ $_[0] }  } 




 



  
0
  




 





 





 





 





0



   




 



  
0
  




 





 





 





 





0



   




7053



  
0
  




 





 




  
0
  



  
0
  




0



 sub column4_nnnn($$$$)  { map { column4_1nnn  ($_   , $_[1], $_[2], $_[3])  } @{ $_[0] }  } 




 



  
0
  




 





 





 





 





0



   




 



  
0
  




 





 





 





 





0



   




7054




 





 





 





 





 





 



   




7055




 





 





 





 





 





 



 #################### 




7056




 





 





 





 





 





 



 # stmt interpolation: 




7057




 





 





 





 





 





 



   




7058




 





 





 





 





 





 



 sub stmt($) 




7059




 





 





 





 





 





 



 { 




7060




3





 





 




  
3
  



  
0
  




15



     my ($x)= @_; 




7061




3




  
 50
  




 





 





 





3



     if (ref($x)) { 




7062




3





 





 





 





 





11



         return $x->stmt; 




7063




 





 





 





 





 





 



     } 




7064




 





 





 





 





 





 



     else { 




7065



  
0
  




 





 





 





 





0



         croak "Error: Expected 'Stmt' object, but found: ".my_dumper($x); 




7066




 





 





 





 





 





 



     } 




7067




 





 





 





 





 





 



 } 




7068




 





 





 





 





 





 



   




7069




 





 





 





 





 





 



 sub subquery($) 




7070




 





 





 





 





 





 



 { 




7071




1





 





 




  
1
  



  
0
  




2



     my ($x1)= @_; 




7072




1





 





 





 





 





4



     my $x= SQL::Yapp::Stmt->obj($x1); 




7073




1





 





 





 





 





5



     return $x->subquery; 




7074




 





 





 





 





 





 



 } 




7075




 





 





 





 





 





 



   




7076




 





 





 





 





 





 



 #################### 




7077




 





 





 





 





 





 



 # expr interpolation: 




7078




 





 





 





 





 





 



   




7079




 





 





 





 





 





 



 sub exprparen($) 




7080




 





 





 





 





 





 



 { 




7081




70





 





 




  
70
  



  
0
  




1308



     my ($x)= @_; 




7082




70




  
100
  




 





 





 





81



     if (ref($x)) { 




7083




5




  
 50
  




 





 





 





13



         die Dumper($x) if ref($x) eq 'HASH'; 




7084




5




  
 50
  




 





 





 





10



         die Dumper($x) if ref($x) eq 'ARRAY'; 




7085




5




  
 50
  




 





 





 





12



         die Dumper($x) if ref($x) eq 'CODE'; 




7086




5




  
 50
  




 





 





 





9



         die Dumper($x) if ref($x) eq 'SCALAR'; 




7087




5





 





 





 





 





15



         return $x->exprparen; 




7088




 





 





 





 





 





 



     } 




7089




 





 





 





 





 





 



     else { 




7090




65





 





 





 





 





76



         return SQL::Yapp::Expr->obj(get_quote_val->($x)); # raw perl scalar: quote as value, no parens 




7091




 





 





 





 





 





 



     } 




7092




 





 





 





 





 





 



 } 




7093




 





 





 





 





 





 



   




7094




 





 





 





 





 





 



 sub expr($) 




7095




 





 





 





 





 





 



 { 




7096




153





 





 




  
153
  



  
0
  




5550



     my ($x)= @_; 




7097




153




  
100
  




 





 





 





194



     if (ref($x)) { 




7098




21




  
 50
  




 





 





 





58



         confess 'Error: Trying to invoke $x->expr() on unblessed reference $x ". 




7099




 





 





 





 





 





 



                 "(maybe missing nested sqlExpr{...} inside a block, or ". 




7100




 





 





 





 





 





 



                 "additional () around {} interpolation?)' 




7101




 





 





 





 





 





 



             unless blessed($x); 




7102




21





 





 





 





 





44



         return $x->expr; 




7103




 





 





 





 





 





 



     } 




7104




 





 





 





 





 





 



     else { 




7105




132





 





 





 





 





165



         return SQL::Yapp::Expr->obj(get_quote_val->($x)); # raw perl scalar: quote as value 




7106




 





 





 





 





 





 



     } 




7107




 





 





 





 





 





 



 } 




7108




 





 





 





 





 





 



   




7109




 





 





 





 





 





 



 sub expr_or_check($) 




7110




 





 





 





 





 





 



 { 




7111




5





 





 




  
5
  



  
0
  




5



     my ($x)= @_; 




7112




5




  
100
  




 





 





 





11



     if (ref($x)) { 




7113




3





 





 





 





 





7



         return $x->expr_or_check; 




7114




 





 





 





 





 





 



     } 




7115




 





 





 





 





 





 



     else { 




7116




2





 





 





 





 





3



         return SQL::Yapp::Expr->obj(get_quote_val->($x)); # raw perl scalar: quote as value 




7117




 





 





 





 





 





 



     } 




7118




 





 





 





 





 





 



 } 




7119




 





 





 





 





 





 



   




7120




 





 





 





 





 





 



 sub exprparen_hash(\%) 




7121




 





 





 





 





 





 



 { 




7122




3





 





 




  
3
  



  
0
  




4



     my ($x)= @_; 




7123




 





 





 





 





 





 



     return map { 




7124




3





 





 





 





 





14



         my $n= $_; 




 




6





 





 





 





 





7



   




7125




6





 





 





 





 





9



         my $e= $x->{$n}; 




7126




6




  
100
  



  
 66
  




 





 





40



         (blessed($e) && $e->isa('SQL::Yapp::Check') ? 




7127




 





 





 





 





 





 



             '('.get_quote_id->($n).' '.$e->check.')' 




7128




 





 





 





 





 





 



         :   '('.get_quote_id->($n).' = '.exprparen($e).')' 




7129




 





 





 





 





 





 



         ) 




7130




 





 





 





 





 





 



     } 




7131




 





 





 





 





 





 



     sort keys %$x; 




7132




 





 





 





 





 





 



 } 




7133




 





 





 





 





 





 



   




7134




 





 





 





 





 





 



 sub expr_hash(\%) 




7135




 





 





 





 





 





 



 { 




7136




4





 





 




  
4
  



  
0
  




8



     my ($x)= @_; 




7137




 





 





 





 





 





 



     return map { 




7138




4





 





 





 





 





11



         my $n= $_; 




 




7





 





 





 





 





9



   




7139




7





 





 





 





 





8



         my $e= $x->{$n}; 




7140




7




  
 50
  



  
 33
  




 





 





22



         (blessed($e) && $e->isa('SQL::Yapp::Check') ? 




7141




 





 





 





 





 





 



             '('.get_quote_id->($n).' '.$e->check.')' 




7142




 





 





 





 





 





 



         :   SQL::Yapp::Infix->obj('=', get_quote_id->($n), exprparen($e)) 




7143




 





 





 





 





 





 



         ) 




7144




 





 





 





 





 





 



     } 




7145




 





 





 





 





 





 



     sort keys %$x; 




7146




 





 





 





 





 





 



 } 




7147




 





 





 





 





 





 



   




7148




 





 





 





 





 





 



 #################### 




7149




 





 





 





 





 





 



 # order interpolation: 




7150




 





 





 





 





 





 



   




7151




 





 





 





 





 





 



 sub asc($) 




7152




 





 





 





 





 





 



 { 




7153




9





 





 




  
9
  



  
0
  




293



     my ($x)= @_; 




7154




9




  
100
  




 





 





 





17



     if (ref($x)) { 




 




 




  
 50
  




 





 





 





 



   




7155




4





 





 





 





 





8



         return $x->asc; 




7156




 





 





 





 





 





 



     } 




7157




 





 





 





 





 





 



     elsif (defined $x) { 




7158




5





 





 





 





 





8



         return column1($x); 




7159




 





 





 





 





 





 



     } 




7160




 





 





 





 





 





 



     else { 




7161



  
0
  




 





 





 





 





0



         return NULL; 




7162




 





 





 





 





 





 



     } 




7163




 





 





 





 





 





 



 } 




7164




 





 





 





 





 





 



   




7165




 





 





 





 





 





 



 sub desc($) 




7166




 





 





 





 





 





 



 { 




7167




10





 





 




  
10
  



  
0
  




20



     my ($x)= @_; 




7168




10




  
100
  




 





 





 





17



     if (ref($x)) { 




 




 




  
 50
  




 





 





 





 



   




7169




6





 





 





 





 





11



         return $x->desc; 




7170




 





 





 





 





 





 



     } 




7171




 





 





 





 





 





 



     elsif (defined $x) { 




7172




4





 





 





 





 





5



         return SQL::Yapp::Desc->obj(column1($x)); 




7173




 





 





 





 





 





 



     } 




7174




 





 





 





 





 





 



     else { 




7175



  
0
  




 





 





 





 





0



         return NULL; 




7176




 





 





 





 





 





 



     } 




7177




 





 





 





 





 





 



 } 




7178




 





 





 





 





 





 



   




7179




 





 





 





 





 





 



 #################### 




7180




 





 





 





 





 





 



 # table option: 




7181




 





 





 





 





 





 



   




7182




 





 





 





 





 





 



 sub tableopt($) 




7183




 





 





 





 





 





 



 { 




7184




2





 





 




  
2
  



  
0
  




6



     my ($x)= @_; 




7185




2




  
 50
  




 





 





 





4



     if (ref($x)) { 




7186




2





 





 





 





 





4



         return $x->tableopt; 




7187




 





 





 





 





 





 



     } 




7188




 





 





 





 





 





 



     else { 




7189



  
0
  




 





 





 





 





0



         croak "Error: Expected 'TableOption' object, but found: ".my_dumper($x); 




7190




 





 





 





 





 





 



     } 




7191




 





 





 





 





 





 



 } 




7192




 





 





 





 





 





 



   




7193




 





 





 





 





 





 



 #################### 




7194




 





 





 





 





 





 



 # join interpolation: 




7195




 





 





 





 





 





 



   




7196




 





 





 





 





 





 



 sub joinclause($) 




7197




 





 





 





 





 





 



 { 




7198




4





 





 




  
4
  



  
0
  




7



     my ($x)= @_; 




7199




4




  
 50
  




 





 





 





8



     if (ref($x)) { 




7200




4





 





 





 





 





9



         return $x->joinclause; 




7201




 





 





 





 





 





 



     } 




7202




 





 





 





 





 





 



     else { 




7203



  
0
  




 





 





 





 





0



         croak "Error: Expected 'Join' object, but found: ".my_dumper($x); 




7204




 





 





 





 





 





 



     } 




7205




 





 





 





 





 





 



 } 




7206




 





 





 





 





 





 



   




7207




 





 





 





 





 





 



 #################### 




7208




 





 





 





 





 





 



 # limit interpolation: 




7209




 





 





 





 





 





 



   




7210




 





 





 





 





 





 



 sub limit_number($) 




7211




 





 





 





 





 





 



 { 




7212




14





 





 




  
14
  



  
0
  




30



     my ($x)= @_; 




7213




14




  
 50
  




 





 





 





38



     if (ref($x)) { 




 




 




  
 50
  




 





 





 





 



   




7214



  
0
  




 





 





 





 





0



         return $x->limit_number; 




7215




 





 





 





 





 





 



     } 




7216




 





 





 





 





 





 



     elsif (looks_like_number $x) { 




7217




14





 





 





 





 





34



         return $x; 




7218




 





 





 





 





 





 



     } 




7219




 





 





 





 





 





 



     else { 




7220



  
0
  




 





 





 





 





0



         croak "Error: Expected number or ?, but found: ".my_dumper($x); 




7221




 





 





 





 





 





 



     } 




7222




 





 





 





 





 





 



 } 




7223




 





 





 





 





 





 



   




7224




 





 





 





 





 





 



 sub limit($$) 




7225




 





 





 





 





 





 



 { 




7226




2





 





 




  
2
  



  
0
  




4



     my ($cnt, $offset)= @_; 




7227




 





 





 





 





 





 



   




7228




 





 





 





 





 





 



     # FIXME: if dialect is 'std' (or maybe 'std2008'), produce OFFSET/FETCH 




7229




 





 





 





 





 





 



     #        clause (SQL-2008). 




7230




2




  
100
  




 





 





 





5



     if (defined $cnt) { 




7231




1




  
 50
  




 





 





 





3



         if (defined $offset) { 




7232




1





 





 





 





 





2



             return " LIMIT ".limit_number($cnt)." OFFSET ".limit_number($offset); 




7233




 





 





 





 





 





 



         } 




7234




 





 





 





 





 





 



         else { 




7235



  
0
  




 





 





 





 





0



             return " LIMIT ".limit_number($cnt); 




7236




 





 





 





 





 





 



         } 




7237




 





 





 





 





 





 



     } 




7238




 





 





 





 





 





 



     else { 




7239




1




  
 50
  




 





 





 





4



         if (defined $offset) { 




7240




1




  
 50
  




 





 





 





3



             if ($write_dialect eq 'postgresql') { 




7241



  
0
  




 





 





 





 





0



                 return " LIMIT ALL OFFSET ".limit_number($offset); 




7242




 





 





 





 





 





 



             } 




7243




 





 





 





 





 





 



             else { 




7244




1





 





 





 





 





1



                 return " LIMIT ${\LARGE_LIMIT_CNT} OFFSET ".limit_number($offset); 




 




1





 





 





 





 





5



   




7245




 





 





 





 





 





 



             } 




7246




 





 





 





 





 





 



         } 




7247




 





 





 





 





 





 



         else { 




7248



  
0
  




 





 





 





 





0



             return ''; 




7249




 





 





 





 





 





 



         } 




7250




 





 





 





 





 





 



     } 




7251




 





 





 





 





 





 



 } 




7252




 





 





 





 





 





 



   




7253




 





 





 





 





 





 



 #################### 




7254




 





 





 





 





 





 



 # case: 




7255




 





 





 





 





 





 



   




7256




 





 





 





 





 





 



 sub whenthen($$) 




7257




 





 





 





 





 





 



 { 




7258




6





 





 




  
6
  



  
0
  




7



     my ($expr, $then)= @_; 




7259




6





 





 





 





 





46



     return 'WHEN '.$expr.' THEN '.$then; 




7260




 





 





 





 





 





 



 } 




7261




 





 





 





 





 





 



   




7262




 





 





 





 





 





 



 sub caseswitch($$@) 




7263




 





 





 





 





 





 



 { 




7264




 





 





 





 





 





 



    #my ($switchval, $default, @whenthen) 




7265




8




  
100
  




 




  
8
  



  
0
  




14



    if (scalar(@_) == 2) { # @whenthen is empty => always use default 




7266




2





 





 





 





 





6



        return $_[1];      # return default 




7267




 





 





 





 





 





 



    } 




7268




 





 





 





 





 





 



    return 




7269




6





 





 





 





 





42



       join(' ', 




7270




 





 





 





 





 





 



           'CASE', 




7271




 





 





 





 





 





 



           $_[0], 




7272




 





 





 





 





 





 



           @_[2..$#_],     # @whenthen 




7273




 





 





 





 





 





 



           'ELSE',         # always generate default, it's easier. 




7274




 





 





 





 





 





 



           $_[1], 




7275




 





 





 





 





 





 



           'END' 




7276




 





 





 





 





 





 



      ); 




7277




 





 





 





 





 





 



 } 




7278




 





 





 





 





 





 



   




7279




 





 





 





 





 





 



 sub casecond($@) 




7280




 





 





 





 





 





 



 { 




7281




 





 





 





 





 





 



    #my ($default, @whenthen) 




7282



  
0
  



  
  0
  




 




  
0
  



  
0
  




 



    if (scalar(@_) == 1) { # @whenthen is empty => always use default 




7283



  
0
  




 





 





 





 





 



        return $_[0];      # return default 




7284




 





 





 





 





 





 



    } 




7285




 





 





 





 





 





 



    return 




7286




0





 





 





 





 





 



       join(' ', 




7287




 





 





 





 





 





 



           'CASE', 




7288




 





 





 





 





 





 



           @_[1..$#_],     # @whenthen 




7289




 





 





 





 





 





 



           'ELSE',         # always generate default, it's easier. 




7290




 





 





 





 





 





 



           $_[0], 




7291




 





 





 





 





 





 



           'END' 




7292




 





 





 





 





 





 



      ); 




7293




 





 





 





 





 





 



 } 




7294




 





 





 





 





 





 



   




7295




 





 





 





 





 





 



 1; 




7296




 





 





 





 





 





 



   




7297




 





 





 





 





 





 



 ###################################################################### 




7298




 





 





 





 





 





 



 ###################################################################### 




7299




 





 





 





 





 





 



 ###################################################################### 




7300




 





 





 





 





 





 



   




7301




 





 





 





 





 





 



 __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 allows 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 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__