Beefy Boxes and Bandwidth Generously Provided by pair Networks
Problems? Is your data what you think it is?
 
PerlMonks  

Parsing 2D Graphs

by ikegami (Pope)
on Sep 02, 2004 at 02:02 UTC ( #387772=sourcecode: print w/ replies, xml ) Need Help??

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

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

Comment on Parsing 2D Graphs
Download Code

Back to Code Catacombs

Log In?
Username:
Password:

What's my password?
Create A New User
Node Status?
node history
Node Type: sourcecode [id://387772]
help
Chatterbox?
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others having an uproarious good time at the Monastery: (14)
As of 2014-07-24 16:21 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    My favorite superfluous repetitious redundant duplicative phrase is:









    Results (162 votes), past polls