#
# Proof of concept for a parser for the diagrams found at:
# http://publib.boulder.ibm.com/infocenter/db2v8luw/index.jsp?topic=/c
+om.ibm.db2.udb.doc/admin/r0006726.htm
#
# Implementation Notes
# ====================
# - Parser::RecDescent wasn't really providing anything,
# so I decided to rewrite the program to not use
# Parser::RecDescent.
# - Printing out the result as a grammar is left as an
# excersise for the reader. It should be extremely simple.
# - "parameter-block" and "large bullets" (*) that denote
# unordered sequences are not supported. Those are
# relatively simple or similar to implement, and therefore
# they are not needed in this proof of concept program.
# - "--text.*--" (a replaceable immediately followed by
# literals) is handled differently than "--text--.*--"
# in case the user wishes to forbid whitespace between
# the replaceable and the literals in the former.
# - Most rules don't clone $self, since they only modify
# it on a successful match.
#
# Bugs
# ====
# - Needs trace statements for debugging.
# - This is not a validator. The input is assumed to be
# valid. Adding validation would be simple, but it would
# be time consuming to code, and it would hinder code
# readability.
# - No meaningful error reporting.
# - Didn't look into whether <commit> could be used to
# improve efficiency in this grammar.
# - Something tells me the regexp for sql_literal is
# expensive because of the backtracking necessary to
# locate a dash. The LHS of the | should probably have
# a lookahead.
# - Definitions for "sql_literal" and "sql_replaceable"
# are guesswork and may require tweaking.
#
# ----------------------------------------
use strict;
use warnings;
use Algorithm::Loops ();
use Data::Dumper ();
# ----------------------------------------
package ikegami::Parser;
# ---
sub IDX_DATA () { 0 }
sub IDX_STATE () { 1 }
sub NEXT_IDX () { 2 }
sub NEXT_DT_IDX () { 0 }
sub NEXT_ST_IDX () { 0 }
# ---
sub new {
my ($class) = @_;
return (
bless([
[], # IDX_DATA
[], # IDX_STATE
], $class)
);
}
sub clone {
my ($self) = @_;
return (
bless([
$self->[IDX_DATA], # IDX_DATA
[], # IDX_STATE
], ref($self))
);
}
sub repeat($$;$$) {
my ($self, $rule, $min, $max) = @_;
{
my $self = $self->clone();
my @items;
my $item;
my $reps = 0;
while (defined($item = $self->$rule()))
{
push(@items, $item);
++$reps;
(!$max) or ($reps < $max) or last;
}
(!defined($min)) or ($reps >= $min) or last;
$_[0] = $self;
return \@items;
}
return;
}
sub rule() {
my $subname = (caller(1))[3];
$subname =~ s/^.*:://;
return $subname;
}
# ----------------------------------------
package ikegami::Db2SqlSyntax::Parser;
# ---
use vars qw(
@ISA
);
BEGIN
{
@ISA = 'ikegami::Parser';
}
sub IDX_DATA () { &ikegami::Parser::IDX_DATA }
sub IDX_STATE () { &ikegami::Parser::IDX_STATE }
sub DT_IDX_TEXT () { &ikegami::Parser::NEXT_DT_IDX + 0 }
sub DT_IDX_TXET () { &ikegami::Parser::NEXT_DT_IDX + 1 }
sub NEXT_DT_IDX () { &ikegami::Parser::NEXT_DT_IDX + 2 }
sub ST_IDX_SKIPF () { &ikegami::Parser::NEXT_ST_IDX + 0 }
sub ST_IDX_Y () { &ikegami::Parser::NEXT_ST_IDX + 1 }
sub ST_IDX_X () { &ikegami::Parser::NEXT_ST_IDX + 2 }
sub ST_IDX_D () { &ikegami::Parser::NEXT_ST_IDX + 3 }
sub ST_IDX_STACK () { &ikegami::Parser::NEXT_ST_IDX + 4 }
sub NEXT_ST_IDX () { &ikegami::Parser::NEXT_ST_IDX + 5 }
sub STACK_IDX_ID () { 0 }
sub STACK_NEXT_IDX () { 1 }
sub CHOICE_IDX_Y () { STACK_NEXT_IDX+0 }
sub CHOICE_IDX_X () { STACK_NEXT_IDX+1 }
sub CHOICE_IDX_D () { STACK_NEXT_IDX+2 }
sub LOOP_IDX_END_Y () { STACK_NEXT_IDX+0 }
sub LOOP_IDX_END_X () { STACK_NEXT_IDX+1 }
sub DIR_N () { 0 }
sub DIR_E () { 1 }
sub DIR_S () { 2 }
sub DIR_W () { 3 }
sub DIR_C () { 4 }
use vars qw(
@DIR_X
@DIR_Y
@DIR_DASH
);
BEGIN
{
# N E S W .
@DIR_X = ( 0, +1, 0, -1, 0 );
@DIR_Y = ( -1, 0, +1, 0, 0 );
@DIR_DASH = qw( | - | - );
}
# ---
sub new {
my $class = $_[0];
#my $text = $_[1];
my $self = $class->ikegami::Parser::new();
my @text = $_[1] =~ /([^\n]*)\n/gs;
my $text = \@text;
my $txet = transpose_AoS($text);
my $dt = $self->[IDX_DATA ];
my $st = $self->[IDX_STATE];
$dt->[DT_IDX_TEXT ] = $text;
$dt->[DT_IDX_TXET ] = $txet;
$st->[ST_IDX_SKIPF] = 'SKIP_NOTHING';
$st->[ST_IDX_Y ] = 0;
$st->[ST_IDX_X ] = undef;
$st->[ST_IDX_D ] = undef;
$st->[ST_IDX_STACK] = [];
$self->DO_MOVE_TO_START();
return $self;
}
sub clone {
my ($src) = @_;
my $dst = $src->ikegami::Parser::clone();
my $src_st = $src->[IDX_STATE];
my $dst_st = $dst->[IDX_STATE];
$dst_st->[ST_IDX_SKIPF] = $src_st->[ST_IDX_SKIPF];
$dst_st->[ST_IDX_Y ] = $src_st->[ST_IDX_Y ];
$dst_st->[ST_IDX_X ] = $src_st->[ST_IDX_X ];
$dst_st->[ST_IDX_D ] = $src_st->[ST_IDX_D ];
$dst_st->[ST_IDX_STACK] = $src_st->[ST_IDX_STACK];
# Stack not cloned deeply. Must be done explicitely by caller.
#$dst_st->[ST_IDX_STACK] = [ @{$src_st->[ST_IDX_STACK]} ];
return $dst;
}
sub text { $_[0]->[IDX_DATA ]->[DT_IDX_TEXT ] }
sub txet { $_[0]->[IDX_DATA ]->[DT_IDX_TXET ] }
sub skipf { $_[0]->[IDX_STATE]->[ST_IDX_SKIPF] }
sub y { $_[0]->[IDX_STATE]->[ST_IDX_Y ] }
sub x { $_[0]->[IDX_STATE]->[ST_IDX_X ] }
sub d { $_[0]->[IDX_STATE]->[ST_IDX_D ] }
sub stack { $_[0]->[IDX_STATE]->[ST_IDX_STACK] }
sub set_skipf { $_[0]->[IDX_STATE]->[ST_IDX_SKIPF] = $_[1]; $_[0] }
sub set_y { $_[0]->[IDX_STATE]->[ST_IDX_Y ] = $_[1]; $_[0] }
sub set_x { $_[0]->[IDX_STATE]->[ST_IDX_X ] = $_[1]; $_[0] }
sub set_d { $_[0]->[IDX_STATE]->[ST_IDX_D ] = $_[1]; $_[0] }
sub set_stack { $_[0]->[IDX_STATE]->[ST_IDX_STACK] = $_[1]; $_[0] }
# [ [
# 'aeh',
# 'abcd', 'bfi',
# 'efg', ==> 'cgj',
# 'hijkl', 'd k',
# ' l',
# ] ]
sub transpose_AoS {
return [ Algorithm::Loops::MapCarU { join('', map { defined($_) ? $
+_ : ' ' } @_) } map { [ /(.)/gs ] } @{$_[0]} ];
}
sub get_char_at {
my ($text, $y, $x, $d) = @_;
$d = DIR_C unless (defined($d));
$y += $DIR_Y[$d] - 1; # Make zero-based.
$x += $DIR_X[$d] - 1; # Make zero-based.
return undef unless ($y >= 0);
return undef unless ($y < @$text);
my $line = $text->[$y];
return undef if ($x < 0 || $x >= length($line));
return substr($line, $x, 1);
}
sub is_loop_return {
my ($text, $y, $x) = @_;
my $ch;
$ch = get_char_at($text, $y + $DIR_Y[DIR_N]*0, $x + $DIR_X[DIR_N]*0
+);
return undef unless (defined($ch) && $ch eq '-');
$ch = get_char_at($text, $y + $DIR_Y[DIR_N]*1, $x + $DIR_X[DIR_N]*1
+);
return undef unless (defined($ch) && $ch eq 'V');
$ch = get_char_at($text, $y + $DIR_Y[DIR_N]*2, $x + $DIR_X[DIR_N]*2
+);
return undef unless (defined($ch) && ($ch eq '.' || $ch eq '|'));
return 1;
}
sub is_dash {
my ($text, $y, $x, $d) = @_;
my $ch = get_char_at($text, $y, $x);
return undef unless (defined($ch));
return undef unless ($ch eq $DIR_DASH[$d]);
return !(is_loop_return($text, $y, $x));
}
sub skip {
my ($self) = @_;
my $skipf = $self->skipf();
$self->$skipf();
}
# ---
sub DO_MOVE_TO_START {
my ($self) = @_;
my $text = $self->text();
my $y = $self->y();
my $num_lines = scalar(@$text);
my $x = 0; # 0-based.
--$y; # Make 0-based.
while (++$y < $num_lines)
{
last if (substr($text->[$y], $x) =~ /^>/s);
}
++$y; # Make 1-based.
++$x; # Make 1-based.
$self->set_y($y)->set_x($x)->set_d(DIR_E);
return 1;
}
# Skips whitespace like a MATCH.
sub DO_SET_DIR {
my ($self, $new_d) = @_;
$self->skip();
my $old_d = $self->d();
$self->set_d($new_d);
return $old_d;
}
sub DO_SET_SKIP {
my ($self, $new_skipf) = @_;
my $old_skipf = $self->skipf();
$self->set_skipf($new_skipf);
return $old_skipf;
}
sub SKIP_NOTHING {}
sub SKIP_LINE {
my ($self) = @_;
my $text = $self->text();
my $y = $self->y();
my $x = $self->x();
my $d = $self->d();
my $moved;
while (is_dash($text, $y, $x, $d))
{
$y += $DIR_Y[$d];
$x += $DIR_X[$d];
$moved = 1;
}
$self->set_y($y)->set_x($x) if ($moved);
}
# Replacement for //.
sub MATCH {
my ($self, $regexp) = @_;
$self->skip();
my $text = $self->text();
my $txet = $self->txet();
my $y = $self->y();
my $x = $self->x();
my $d = $self->d();
--$y; # Make 0-based.
--$x; # Make 0-based.
my $line;
my $setter;
my $pos;
my $match;
my $sign;
if ($DIR_X[$d]) {
$line = $text->[$y];
return undef unless (defined($line));
$setter = 'set_x';
$pos = $x;
} else {
$line = $txet->[$x];
return undef unless (defined($line));
$setter = 'set_y';
$pos = $y;
}
if ($DIR_X[$d] >= 0 && $DIR_Y[$d] >= 0) {
$line = ($pos < length($line) ? substr($line, $pos) : '');
($match) = $line =~ /^($regexp)/s;
$sign = +1;
} else {
$line = substr($line, 0, $pos+1);
($match) = $line =~ /($regexp)$/s;
$sign = -1;
}
return undef unless (defined($match));
$pos += length($match) * $sign;
++$pos; # Make 1-based.
$self->$setter($pos);
return $match;
}
sub MATCH_LOOP_RET {
my ($self) = @_;
$self->skip();
my $text = $self->text();
my $y = $self->y();
my $x = $self->x();
return undef unless (is_loop_return($text, $y, $x));
$y += $DIR_Y[DIR_E];
$x += $DIR_X[DIR_E];
$self->set_y($y)->set_x($x);
return 1;
}
sub MATCH_EOF {
my ($self) = @_;
my $text = $self->text();
my $y = $self->y();
--$y; # Make 0-based.
return ($y >= scalar(@$text) ? 1 : undef);
}
# Skips whitespace like a MATCH.
sub DO_CHOICE_START {
my ($self) = @_;
$self->skip();
my $y = $self->y();
my $x = $self->x();
my $d = $self->d();
my $stack = $self->stack();
$stack = [ @$stack ];
push(@$stack,
[
'choice', # STACK_IDX_ID
$y, # CHOICE_IDX_Y
$x, # CHOICE_IDX_X
$d, # CHOICE_IDX_D
],
);
$self->set_stack($stack);
return 1;
}
sub DO_GO_CHOICE_START {
my ($self) = @_;
my $stack = $self->stack();
my $record = $stack->[$#$stack];
my ($y, $x, $d) = @$record[CHOICE_IDX_Y, CHOICE_IDX_X, CHOICE_IDX_D
+];
$self->set_y($y)->set_x($x)->set_d($d);
return 1;
}
sub DO_CHOICE_END {
my ($self) = @_;
my $stack = $self->stack();
$stack = [ @$stack ];
pop(@$stack);
$self->set_stack($stack);
return 1;
}
# Skips whitespace like a MATCH.
sub DO_LOOP_START {
my ($self) = @_;
$self->skip();
my $y = $self->y();
my $x = $self->x();
my $d = $self->d();
my $stack = $self->stack();
$stack = [ @$stack ];
push(@$stack,
[
'loop', # STACK_IDX_ID
undef, # LOOP_IDX_END_Y
undef, # LOOP_IDX_END_X
],
);
$self->set_stack($stack);
return 1;
}
# Skips whitespace like a MATCH.
sub DO_LOOP_BACK {
my ($self) = @_;
$self->skip();
my $y = $self->y();
my $x = $self->x();
my $stack = $self->stack();
$stack = [ @$stack ];
my $record = $stack->[$#$stack];
@$record[LOOP_IDX_END_Y, LOOP_IDX_END_X] = ($y, $x);
$self->set_stack($stack);
return 1;
}
sub DO_GO_LOOP_BACK {
my ($self) = @_;
my $stack = $self->stack();
my $record = $stack->[$#$stack];
my ($y, $x) = @$record[LOOP_IDX_END_Y, LOOP_IDX_END_X];
$self->set_y($y)->set_x($x)->set_d(DIR_E);
return 1;
}
sub DO_LOOP_END {
my ($self) = @_;
my $stack = $self->stack();
$stack = [ @$stack ];
pop(@$stack);
$self->set_stack($stack);
return 1;
}
# --- Basics
sub parse
{
{
my $self = $_[0]->clone();
my @items;
my $i;
defined($items[++$i] = $self->repeat('stmt', 0) ) or
+ last;
defined($items[++$i] = $self->MATCH_EOF() ) or
+ last;
$_[0] = $self;
return $items[1];
}
return undef;
}
sub stmt
{
{
my $self = $_[0]->clone();
my @items;
my $i;
defined($items[++$i] = $self->DO_SET_SKIP('SKIP_NOTHING') ) or
+ last;
defined($items[++$i] = $self->MATCH('>>') ) or
+ last;
defined($items[++$i] = $self->DO_SET_SKIP('SKIP_LINE') ) or
+ last;
defined($items[++$i] = $self->repeat('expr', 0) ) or
+ last;
defined($items[++$i] = $self->repeat('stmt_extention', 0) ) or
+ last;
defined($items[++$i] = $self->MATCH('><') ) or
+ last;
defined($items[++$i] = $self->DO_MOVE_TO_START() ) or
+ last;
$_[0] = $self;
return [ @{$items[4]}, map { @{$_} } @{$items[5]} ];
}
return undef;
}
sub stmt_extention
{
{
my $self = $_[0]->clone();
my @items;
my $i;
defined($items[++$i] = $self->MATCH('>(?!<)') ) or
+ last;
defined($items[++$i] = $self->DO_MOVE_TO_START() ) or
+ last;
defined($items[++$i] = $self->MATCH('>(?!>)') ) or
+ last;
defined($items[++$i] = $self->repeat('expr', 0) ) or
+ last;
$_[0] = $self;
return $items[4];
}
return undef;
}
sub expr
{
{
my $self = $_[0]->clone();
my @items;
my $i;
defined($items[++$i] = $self->sql_text() ) or
+ last;
$_[0] = $self;
return $items[1];
}
{
my $self = $_[0]->clone();
my @items;
my $i;
defined($items[++$i] = $self->choice() ) or
+ last;
$_[0] = $self;
return $items[1];
}
{
my $self = $_[0]->clone();
my @items;
my $i;
defined($items[++$i] = $self->loop() ) or
+ last;
$_[0] = $self;
return $items[1];
}
return undef;
}
# --- Literals
sub sql_text
{
{
my $self = $_[0]->clone();
my @items;
my $i;
$items[0] = $self->rule();
defined($items[++$i] = $self->sql_component() ) or
+ last;
defined($items[++$i] = $self->DO_SET_SKIP('SKIP_NOTHING') ) or
+ last;
defined($items[++$i] = $self->repeat('sql_component', 0) ) or
+ last;
defined($items[++$i] = $self->DO_SET_SKIP($items[2]) ) or
+ last;
$_[0] = $self;
return [ $items[0], $items[1], @{$items[3]} ];
}
return undef;
}
sub sql_component
{
{
my $self = $_[0]->clone();
my @items;
my $i;
defined($items[++$i] = $self->sql_literal() ) or
+ last;
$_[0] = $self;
return $items[1];
}
{
my $self = $_[0]->clone();
my @items;
my $i;
defined($items[++$i] = $self->sql_replaceable() ) or
+ last;
$_[0] = $self;
return $items[1];
}
return undef;
}
sub sql_literal
{
{
my $self = $_[0]->clone();
my @items;
my $i;
$items[0] = $self->rule();
defined($items[++$i] = $self->MATCH(
qr/(?:[+<>'.])*[^a-z-+<>'.\s](?:[^a-z-+<>]|[A-Z]-[A-Z])*/
)) or last;
$_[0] = $self;
return \@items;
}
return undef;
}
sub sql_replaceable
{
{
my $self = $_[0]->clone();
my @items;
my $i;
$items[0] = $self->rule();
defined($items[++$i] = $self->MATCH(
qr/[a-z](?:[a-z]|-[a-z])*/
)) or last;
$_[0] = $self;
return \@items;
}
return undef;
}
# --- Choices
sub choice
{
{
my $self = $_[0]->clone();
my @items;
my $i;
$items[0] = $self->rule();
defined($items[++$i] = $self->DO_CHOICE_START() ) or
+ last;
defined($items[++$i] = $self->choice_branches() ) or
+ last;
defined($items[++$i] = $self->DO_GO_CHOICE_START() ) or
+ last;
defined($items[++$i] = $self->DO_SET_DIR(DIR_E) ) or
+ last;
defined($items[++$i] = $self->MATCH('\\+') ) or
+ last;
defined($items[++$i] = $self->repeat('expr', 0) ) or
+ last;
defined($items[++$i] = $self->MATCH('\\+') ) or
+ last;
defined($items[++$i] = $self->DO_CHOICE_END() ) or
+ last;
$_[0] = $self;
return [ $items[0], @{$items[2]}, $items[6] ];
}
return undef;
}
sub choice_branches
{
{
my $self = $_[0]->clone();
my @items;
my $i;
defined($items[++$i] = $self->north_branches() ) or
+ last;
defined($items[++$i] = $self->repeat('south_branches', 0, 1)) or
+ last;
$_[0] = $self;
return [ $items[1], @{$items[2]} ];
}
{
my $self = $_[0]->clone();
my @items;
my $i;
defined($items[++$i] = $self->south_branches() ) or
+ last;
$_[0] = $self;
return [ $items[1] ];
}
return undef;
}
sub north_branches
{
{
my $self = $_[0]->clone();
my @items;
my $i;
defined($items[++$i] = $self->DO_GO_CHOICE_START() ) or
+ last;
defined($items[++$i] = $self->DO_SET_DIR(DIR_N) ) or
+ last;
defined($items[++$i] = $self->MATCH('\\+') ) or
+ last;
defined($items[++$i] = $self->north_branch() ) or
+ last;
$_[0] = $self;
return $items[4];
}
return undef;
}
sub south_branches
{
{
my $self = $_[0]->clone();
my @items;
my $i;
defined($items[++$i] = $self->DO_GO_CHOICE_START() ) or
+ last;
defined($items[++$i] = $self->DO_SET_DIR(DIR_S) ) or
+ last;
defined($items[++$i] = $self->MATCH('\\+') ) or
+ last;
defined($items[++$i] = $self->south_branch() ) or
+ last;
$_[0] = $self;
return $items[4];
}
return undef;
}
sub north_branch
{
{
my $self = $_[0]->clone();
my @items;
my $i;
defined($items[++$i] = $self->DO_CHOICE_START() ) or
+ last;
defined($items[++$i] = $self->DO_SET_DIR(DIR_N) ) or
+ last;
defined($items[++$i] = $self->MATCH('\\+') ) or
+ last;
defined($items[++$i] = $self->north_branch() ) or
+ last;
defined($items[++$i] = $self->DO_GO_CHOICE_START() ) or
+ last;
defined($items[++$i] = $self->DO_SET_DIR(DIR_E) ) or
+ last;
defined($items[++$i] = $self->MATCH('\\+') ) or
+ last;
defined($items[++$i] = $self->repeat('expr', 0) ) or
+ last;
defined($items[++$i] = $self->MATCH('\\+') ) or
+ last;
defined($items[++$i] = $self->DO_CHOICE_END() ) or
+ last;
$_[0] = $self;
return [ @{$items[4]}, $items[8] ];
}
{
my $self = $_[0]->clone();
my @items;
my $i;
defined($items[++$i] = $self->DO_SET_DIR(DIR_E) ) or
+ last;
defined($items[++$i] = $self->MATCH('\\.') ) or
+ last;
defined($items[++$i] = $self->repeat('expr', 0) ) or
+ last;
defined($items[++$i] = $self->MATCH('\\.') ) or
+ last;
$_[0] = $self;
return $items[3];
}
return undef;
}
sub south_branch
{
{
my $self = $_[0]->clone();
my @items;
my $i;
defined($items[++$i] = $self->DO_CHOICE_START() ) or
+ last;
defined($items[++$i] = $self->DO_SET_DIR(DIR_S) ) or
+ last;
defined($items[++$i] = $self->MATCH('\\+') ) or
+ last;
defined($items[++$i] = $self->south_branch() ) or
+ last;
defined($items[++$i] = $self->DO_GO_CHOICE_START() ) or
+ last;
defined($items[++$i] = $self->DO_SET_DIR(DIR_E) ) or
+ last;
defined($items[++$i] = $self->MATCH('\\+') ) or
+ last;
defined($items[++$i] = $self->repeat('expr', 0) ) or
+ last;
defined($items[++$i] = $self->MATCH('\\+') ) or
+ last;
defined($items[++$i] = $self->DO_CHOICE_END() ) or
+ last;
$_[0] = $self;
return [ @{$items[4]}, $items[8] ];
}
{
my $self = $_[0]->clone();
my @items;
my $i;
defined($items[++$i] = $self->DO_SET_DIR(DIR_E) ) or
+ last;
defined($items[++$i] = $self->MATCH("'") ) or
+ last;
defined($items[++$i] = $self->repeat('expr', 0) ) or
+ last;
defined($items[++$i] = $self->MATCH("'") ) or
+ last;
$_[0] = $self;
return $items[3];
}
return undef;
}
# --- Loops
sub loop
{
{
my $self = $_[0]->clone();
my @items;
my $i;
$items[0] = $self->rule();
defined($items[++$i] = $self->DO_LOOP_START() ) or
+ last;
defined($items[++$i] = $self->MATCH_LOOP_RET() ) or
+ last;
defined($items[++$i] = $self->repeat('expr', 0) ) or
+ last;
defined($items[++$i] = $self->DO_LOOP_BACK() ) or
+ last;
defined($items[++$i] = $self->DO_SET_DIR(DIR_N) ) or
+ last;
defined($items[++$i] = $self->MATCH('\\+') ) or
+ last;
defined($items[++$i] = $self->DO_SET_DIR(DIR_W) ) or
+ last;
defined($items[++$i] = $self->MATCH('\\.') ) or
+ last;
defined($items[++$i] = $self->loop_seperator() ) or
+ last;
defined($items[++$i] = $self->DO_SET_DIR(DIR_S) ) or
+ last;
defined($items[++$i] = $self->MATCH('\\.') ) or
+ last;
defined($items[++$i] = $self->MATCH('V') ) or
+ last;
defined($items[++$i] = $self->DO_GO_LOOP_BACK() ) or
+ last;
defined($items[++$i] = $self->MATCH('\\+') ) or
+ last;
defined($items[++$i] = $self->DO_LOOP_END() ) or
+ last;
$_[0] = $self;
return [ $items[0], $items[3], $items[9] ];
}
return undef;
}
sub loop_seperator
{
{
my $self = $_[0]->clone();
my @items;
my $i;
defined($items[++$i] = $self->MATCH(',') ) or
+ last;
$_[0] = $self;
return $items[1];
}
{
my $self = $_[0]->clone();
my @items;
my $i;
$_[0] = $self;
return '';
}
return undef;
}
# ----------------------------------------
package main;
# ---
{
my $text = <<'__EOI__';
>>-ACTIVATE--+-DATABASE-+--database-alias----------------------->
'-DB-------'
>--+-------------------------------------+---------------------><
'-USER--username--+-----------------+-'
'-USING--password-'
>>-select-clause--from-clause--+--------------+----------------->
'-where-clause-'
>--+-----------------+--+---------------+----------------------><
'-group-by-clause-' '-having-clause-'
.-ALL------.
>>-SELECT--+----------+----------------------------------------->
'-DISTINCT-'
>--+-*-----------------------------------------------+---------><
| .-,-------------------------------------------. |
| V | |
'---+-expression--+-------------------------+-+-+-'
| | .-AS-. | |
| '-+----+--new-column-name-' |
'-exposed-name.*--------------------------'
__EOI__
my $result = ikegami::Db2SqlSyntax::Parser->new($text)->parse();
die("Bad text.\n") unless (defined($result));
print(Data::Dumper->Dump([ $result ],[qw( $result )]));
}
# ----------------------------------------
__END__
Must Parse
==========
>>-ACTIVATE--+-DATABASE-+--database-alias----------------------->
'-DB-------'
>--+-------------------------------------+---------------------><
'-USER--username--+-----------------+-'
'-USING--password-'
>>-select-clause--from-clause--+--------------+----------------->
'-where-clause-'
>--+-----------------+--+---------------+----------------------><
'-group-by-clause-' '-having-clause-'
.-ALL------.
>>-SELECT--+----------+----------------------------------------->
'-DISTINCT-'
>--+-*-----------------------------------------------+---------><
| .-,-------------------------------------------. |
| V | |
'---+-expression--+-------------------------+-+-+-'
| | .-AS-. | |
| '-+----+--new-column-name-' |
'-exposed-name.*--------------------------'
__END__
Must Parse (Simpler)
====================
>>-------------------------------------------------------------->
>--------------------------------------------------------------><
>>-ACTIVATE----------------database-alias----------------------><
>>-ACTIVATE--+-DATABASE-+--database-alias----------------------><
'-DB-------'
.-ALL------.
>>-SELECT--+----------+----------------------------------------><
'-DISTINCT-'
>>-+-*-----------------------------------------------+--word2--><
| .-,-----------------------------------. |
| V | |
'-----expression------------------------+--word1--'
__END__
Output
======
$result = [
[
[
'sql_text',
[
'sql_literal',
'ACTIVATE'
]
],
[
'choice',
[
[
'sql_text',
[
'sql_literal',
'DB'
]
]
],
[
[
'sql_text',
[
'sql_literal',
'DATABASE'
]
]
]
],
[
'sql_text',
[
'sql_replaceable',
'database-alias'
]
],
[
'choice',
[
[
'sql_text',
[
'sql_literal',
'USER'
]
],
[
'sql_text',
[
'sql_replaceable',
'username'
]
],
[
'choice',
[
[
'sql_text',
[
'sql_literal',
'USING'
]
],
[
'sql_text',
[
'sql_replaceable',
'password'
]
]
],
[]
]
],
[]
]
],
[
[
'sql_text',
[
'sql_replaceable',
'select-clause'
]
],
[
'sql_text',
[
'sql_replaceable',
'from-clause'
]
],
[
'choice',
[
[
'sql_text',
[
'sql_replaceable',
'where-clause'
]
]
],
[]
],
[
'choice',
[
[
'sql_text',
[
'sql_replaceable',
'group-by-clause'
]
]
],
[]
],
[
'choice',
[
[
'sql_text',
[
'sql_replaceable',
'having-clause'
]
]
],
[]
]
],
[
[
'sql_text',
[
'sql_literal',
'SELECT'
]
],
[
'choice',
[
[
'sql_text',
[
'sql_literal',
'ALL'
]
]
],
[
[
'sql_text',
[
'sql_literal',
'DISTINCT'
]
]
],
[]
],
[
'choice',
[
[
'loop',
[
[
'choice',
[
[
'sql_text',
[
'sql_replaceable',
'exposed-name'
],
[
'sql_literal',
'.*'
]
]
],
[
[
'sql_text',
[
'sql_replaceable',
'expression'
]
],
[
'choice',
[
[
'choice',
[
[
'sql_text',
[
'sql_literal',
'AS'
]
]
],
[]
],
[
'sql_text',
[
'sql_replaceable',
'new-column-name'
]
]
],
[]
]
]
]
],
','
]
],
[
[
'sql_text',
[
'sql_literal',
'*'
]
]
]
]
]
];
-
Are you posting in the right place? Check out Where do I post X? to know for sure.
-
Posts may use any of the Perl Monks Approved HTML tags. Currently these include the following:
<code> <a> <b> <big>
<blockquote> <br /> <dd>
<dl> <dt> <em> <font>
<h1> <h2> <h3> <h4>
<h5> <h6> <hr /> <i>
<li> <nbsp> <ol> <p>
<small> <strike> <strong>
<sub> <sup> <table>
<td> <th> <tr> <tt>
<u> <ul>
-
Snippets of code should be wrapped in
<code> tags not
<pre> tags. In fact, <pre>
tags should generally be avoided. If they must
be used, extreme care should be
taken to ensure that their contents do not
have long lines (<70 chars), in order to prevent
horizontal scrolling (and possible janitor
intervention).
-
Want more info? How to link
or How to display code and escape characters
are good places to start.