http://www.perlmonks.org?node_id=387772
Category:
Author/Contact Info ikegami -at- adaelis.com
Description:

Parses text ressembling the sample below (as in the actual graph). Unlike the version at 387769, this one doesn't use Parse::RecDescent, since P::RD provided little value for this kind of text. This program is intended as a proof of concept demonstrating how graphs can be parsed. This program came about from 384588. Read the comments for a few details.

>>-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.*--------------------------'

[download]
 

#
# 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',
                      '*'
                    ]
                  ]
                ]
              ]
            ]
          ];

Back to Code Catacombs