File Coverage

blib/lib/TSQL/SplitStatement.pm

Criterion	Covered	Total	%
statement	176	236	74.5
branch	11	30	36.6
condition	2	6	33.3
subroutine	15	15	100.0
pod	3	3	100.0
total	207	290	71.3

package TSQL::SplitStatement;

use 5.010;
use strict;
use warnings;

use English ;

use List::Util      qw(first max maxstr min minstr reduce shuffle sum);
use List::MoreUtils qw(indexes all any);
#use Data::Dumper;
#use Data::Dump 'pp';
use autodie qw(:all);
use Clone;
use base qw(Clone) ;

use TSQL::Common::Regexp;

## TODO :- 1 stop this warning Variable "$NestedBracketsRE" will not stay shared at (re_eval 215) line 2.

=head1 NAME

TSQL::SplitStatement - Implements similar functionality to SQL::SplitStatement, but for TSQL.

=head1 VERSION

Version 0.15

=cut

our $VERSION = '0.15';



# -- **********************************************************

sub new {
    local $_             = undef ;
    my $invocant         = shift ;
    my $class            = ref($invocant) || $invocant ;
    my $self             = bless {}, $class ;

    return $self ;
}


sub splitSQL {

local $_             = undef ;

my $invocant         = shift ;
my $class            = ref($invocant) || $invocant ;

my $input            = shift ;



my $CommentIndex            = -1 ;

my $QIndex                  = -1 ;
my $SIndex                  = -1 ;
my $UnionIndex              = -1 ;
my $SubqueryIndex           = -1 ;
my $BracketsIndex           = -1 ;
my $CaseEndIndex            = -1 ;
my $InsertsIndex            = -1 ;
my $UpdatesIndex            = -1 ;

my $GrantOptionsIndex       = -1 ;
my $GrantsIndex             = -1 ;
my $DenysIndex              = -1 ;
my $RevokesIndex            = -1 ;

my $CursorSelectsIndex      = -1 ;
my $CursorForUpdatesIndex   = -1 ;

my $TerminatorIndex         = -1 ;


my $CommentRepl           = '____COMMENT_';

my $QRepl                 = '____QUOTEDID_';
my $SRepl                 = '____STRING_';
my $UnionRepl             = '____UNION_';
my $SubqueryRepl          = '____SUBQUERY_';
my $BracketsRepl          = '____BRACKETS_';
my $CaseEndRepl           = '____CASE_END_';
my $InsertsRepl           = '____INSERTS_SELECT_';
my $UpdatesRepl           = '____UPDATES_SET_';

my $GrantOptionsRepl      = '____GRANT_OPTION_';
my $GrantsRepl            = '____GRANT_SET_';
my $DenysRepl             = '____DENY_SET_';
my $RevokesRepl           = '____REVOKE_SET_';

my $CursorSelectsRepl     = '____CURSOR_FOR_SELECT_';
my $CursorForUpdatesRepl  = '____CURSOR_FOR_UPDATES_';


my $TerminatorRepl        = '____SEPARATOR_TOKEN_';


my @Comment_positions     = ();
my @Comment_replaces      = ();

my @Q_replaces            = ();
my @S_replaces            = ();
my @Union_replaces        = ();
my @Subquery_replaces     = ();
my @Brackets_replaces     = ();
my @CaseEnd_replaces      = ();
my @Inserts_replaces      = ();
my @Updates_replaces      = ();

my @GrantOptions_replaces = ();
my @Grants_replaces       = ();
my @Denys_replaces        = ();
my @Revokes_replaces      = ();

my @CursorSelects_replaces      = ();
my @CursorForUpdates_replaces   = ();
my @Terminator_replaces         = ();



#my $qr_Id = qr{[#_\w$@][#$:_.\w]*}x ;
my $qr_Id = TSQL::Common::Regexp->qr_id();

my $s = $input ;

# replace comments only .............

## Beware this is a valid name [abc[]]def]

$s =~ s!(? [N]?'(?:(?:[^']) | (?:''))*' )
           |
         (?"(?:(?:[^"])     | (?:""))*" )
           |
         (?\[  .*? \]  )
           |
         (?(?:(?:--.*?$)
           |
         (?:/[*].*?[*]/)\s*)+
        )
 ! if (defined($+{string})) {"$+{string}"} elsif (defined($+{doublequoted})) {"$+{doublequoted}"} elsif (defined($+{bracketquoted})) {"$+{bracketquoted}"}   elsif (defined($+{comment})) {${CommentIndex}++; $Comment_replaces[${CommentIndex}] = $+{comment} ; " ${CommentRepl}${CommentIndex} "} else {'z'}
 !xigems ;

#print $s ;
#exit;
# '


$CommentIndex         = -1 ;
$QIndex               = -1 ;
$SIndex               = -1 ;

# replace everything else ..............
#'
# hack around broken ? ^PREMATCH handling in 5.17
# and fixed $` handling
if ( $PERL_VERSION >= v5.17.0 ) {
    $s =~ s!(?(?p) [N]?'(?:(?:[^']) | (?:''))*' )
               |
             (?"(?:(?:[^"])     | (?:""))*" )
               |
             (?\[  .*? \]  )
               |
             (? \s____COMMENT_(?:\d)+\s
             )
     ! if (defined($+{string})) {${SIndex}++; $S_replaces[${SIndex}] = $+{string} ; " ${SRepl}${SIndex} "} elsif (defined($+{doublequoted})) {${QIndex}++; $Q_replaces[${QIndex}] = $+{doublequoted}; " ${QRepl}${QIndex} "} elsif (defined($+{bracketquoted})) {${QIndex}++; $Q_replaces[${QIndex}] = $+{bracketquoted}; " ${QRepl}${QIndex} "}  elsif (defined($+{comment})) {$CommentIndex++; $Comment_positions[$CommentIndex]=length($`); ' ';} else {'z'}
     !xigems ;
}
else {
    $s =~ s!(?(?p) [N]?'(?:(?:[^']) | (?:''))*' )
               |
             (?"(?:(?:[^"])     | (?:""))*" )
               |
             (?\[  .*? \]  )
               |
             (? \s____COMMENT_(?:\d)+\s
             )
     ! if (defined($+{string})) {${SIndex}++; $S_replaces[${SIndex}] = $+{string} ; " ${SRepl}${SIndex} "} elsif (defined($+{doublequoted})) {${QIndex}++; $Q_replaces[${QIndex}] = $+{doublequoted}; " ${QRepl}${QIndex} "} elsif (defined($+{bracketquoted})) {${QIndex}++; $Q_replaces[${QIndex}] = $+{bracketquoted}; " ${QRepl}${QIndex} "}  elsif (defined($+{comment})) {$CommentIndex++; $Comment_positions[$CommentIndex]=length(${^PREMATCH}); ' ';} else {'z'}
     !xigems ;
}

# ! if (defined($1)) {${SIndex}++; $S_replaces[${SIndex}] = $1 ; " ${SRepl}${SIndex} "} elsif (defined($2)) {${QIndex}++; $Q_replaces[${QIndex}] = $2; " ${QRepl}${QIndex} "} elsif (defined($3)) {${QIndex}++; $Q_replaces[${QIndex}] = $3; " ${QRepl}${QIndex} "}  elsif (defined($4)) {$CommentIndex++; $Comment_positions[$CommentIndex]=length(${^PREMATCH}); ' ';} else {'z'}
# '

#$s =~ s!([N]?'(?:(?:[^'])|(?:''))*')
# ! if (defined($1)) {'a'} else {'z'}
# !xgei ;

#pp @Comment_replaces ;

#print $s ;
#exit;


$s =~ s!(\b(?:union|intersect|minus)(?:\s+all)?\s+select\b)
 ! ${UnionIndex}++; $Union_replaces[${UnionIndex}] = $1 ; " ${UnionRepl}${UnionIndex} ";
 !xigems ;

#warn Dumper @Union_replaces ;

no warnings ;
my $NestedBracketsRE = qr{
                            (                       # start of capture buffer 1
                                \(                  # match an opening bracket
                                    (?:
                                        [^()]++     # one or more non brackets, non back+tracking
                                      |
                                        (?1)        # found ( or ), so recurse to capture buffer 1
                                    )*
                                \)                  # match a closing bracket
                             )                      # end of capture buffer 1
                         }ixms;
my $OuterSubQueryRE = qr{
                            (?:                     # start of capture buffer 1
                                \(                  # match an opening bracket
                                \s*select\b         # match select
                                    (?:
                                        [^()]++     # one or more non brackets, non back+tracking
                                      |
                                        (??{$NestedBracketsRE})        # found ( or ), so recurse to $NestedBracketsRE
                                    )*
                                \)                  # match a closing bracket
                             )                      # end of capture buffer 1
                        }ixms;

use warnings ;

$s =~ s!(${OuterSubQueryRE})
 ! ${SubqueryIndex}++; $Subquery_replaces[${SubqueryIndex}] = $1 ; " ${SubqueryRepl}${SubqueryIndex} ";
 !xigems ;

$s =~ s!(${NestedBracketsRE})
 ! ${BracketsIndex}++; $Brackets_replaces[${BracketsIndex}] = $1 ; " ${BracketsRepl}${BracketsIndex} ";
 !xigems ;

my $CaseEndRE = qr{
                     (                      # start of capture buffer 1
                        (?: \b case \b)     # match an opening case
                            (?:
                                .*? (?= \b (?:case|end) \b )     # minimal match up to case or end
                              |
                                (?1)        # found case or end, so recurse to capture buffer 1
                            )*
                        (?: \b end \b)      # match a closing end
                     )                      # end of capture buffer 1
                  }ixms;

$s =~ s!(${CaseEndRE})
 ! ${CaseEndIndex}++; $CaseEnd_replaces[${CaseEndIndex}] = $1 ; " ${CaseEndRepl}${CaseEndIndex} ";
 !xigems ;

$s =~ s!\b
           ( DECLARE\s+ (?:${qr_Id}) (?:\s+ (?: (?:(?:INSENSITIVE|SCROLL) \s+ CURSOR)
                                       |
                                       (?:CURSOR \s+ (?: (?:LOCAL|GLOBAL) \s+)? )
                                         (?:\w+)
                                       )
                                )
           )
        \s+(for\s+select)
        \b
 ! ${CursorSelectsIndex}++; $CursorSelects_replaces[${CursorSelectsIndex}] = $2 ; "${1} ${CursorSelectsRepl}${CursorSelectsIndex} ";
 !xigems ;

$s =~ s!\b(FOR\s+UPDATE(?:\s+OF\b)?)
 ! ${CursorForUpdatesIndex}++; $CursorForUpdates_replaces[${CursorForUpdatesIndex}] = $1 ; " ${CursorForUpdatesRepl}${CursorForUpdatesIndex} ";
 !xigems ;

$s =~ s!  \b( insert (?:\s+into)? \s+ \S+ \s* (?: with \s* ____BRACKETS_\d+ )? \s* (?: ____BRACKETS_\d+ )? \s* )
          (
            (?:select)
               |
            (?:values)
               |
            (?:exec(?:ute)?)
          )
 ! ${InsertsIndex}++; $Inserts_replaces[${InsertsIndex}] = $2 ; "${1} ${InsertsRepl}${InsertsIndex} ";
 !xigems ;

$s =~ s!(\bupdate\b.*?)\b(set)\b
 ! ${UpdatesIndex}++; $Updates_replaces[${UpdatesIndex}] = $2 ; "${1} ${UpdatesRepl}${UpdatesIndex} ";
 !xigems ;

# do grant option first as it contains the word grant then ..............
$s =~ s!\b((?:(?:WITH\s+GRANT\s+OPTION)|(?:GRANT\s+OPTION\s+FOR)))\b
 ! ${GrantOptionsIndex}++; $GrantOptions_replaces[${GrantOptionsIndex}] = $2 ; "${1} ${GrantOptionsRepl}${GrantOptionsIndex} ";
 !xigems ;
# do revoke next as it contains the word grant
$s =~ s!(\brevoke\b)( .*? \b (?:to|from) \b)
 ! ${RevokesIndex}++; $Revokes_replaces[${RevokesIndex}] = $2 ; "${1} ${RevokesRepl}${RevokesIndex} ";
 !xigems ;

$s =~ s!(\bdeny\b)( .*? \b on \b)
 ! ${DenysIndex}++; $Denys_replaces[${DenysIndex}] = $2 ; "${1} ${DenysRepl}${DenysIndex} ";
 !xigems ;

$s =~ s!(\bgrant\b)( .*? \b to \b)
 ! ${GrantsIndex}++; $Grants_replaces[${GrantsIndex}] = $2 ; "${1} ${GrantsRepl}${GrantsIndex} ";
 !xigems ;

#print $s ;

#print "!!\n";

#warn Dumper @S_replaces ;
#warn Dumper @Q_replaces ;
#warn Dumper @Subquery_replaces ;
#warn Dumper @Brackets_replaces ;
#warn Dumper @Inserts_replaces ;
#warn Dumper @Updates_replaces ;
#warn Dumper @CursorForUpdates_replaces ;
#warn Dumper @CursorSelects_replaces ;
#warn Dumper @GrantOptions_replaces ;
#warn Dumper @Revokes_replaces ;
#warn Dumper @Denys_replaces ;
#warn Dumper @Grants_replaces ;

#my ($TokeniserPos,$TokeniserNext) = TSQL::SplitStatement->tokeniser() ;
# cache this variable for efficiency
state $TokeniserPos ;
if ( ! defined $TokeniserPos ) { $TokeniserPos = TSQL::SplitStatement->tokeniser() ; }

my @TokenPositions = () ;
#$s =~ s!( ${Tokeniser} )
# ! ${TerminatorIndex}++; $Terminator_replaces[${TerminatorIndex}] = $2 ; "${1} ${TerminatorRepl}${TerminatorIndex} \n";
# !xigems ;

#need to  find places, in sweep 1 and replace backwards in sweep2
#$s =~ s! ( ${Tokeniser} )
# ! " ____SEPARATOR_TOKEN\n $1 "
# !xigems ;

# hack around broken ? ^PREMATCH handling in 5.17
# and fixed $` handling
if ( $PERL_VERSION >= v5.17.0 ) {
    while ( $s =~ m{${TokeniserPos}}xigms ) {
        push @TokenPositions, length($`) ;
    }
    foreach my $tokPos ( reverse @TokenPositions ) {
        substr($s, $tokPos, 0) = " ____SEPARATOR_TOKEN\n " ;
    }
}
else {
    while ( $s =~ m{${TokeniserPos}}xigms ) {
        push @TokenPositions, length(${^PREMATCH}) ;
    }
    foreach my $tokPos ( reverse @TokenPositions ) {
        substr($s, $tokPos, 0) = " ____SEPARATOR_TOKEN\n " ;
    }
}

#print $s ;


$s =~ s!\s____GRANT_SET_([\d]+)\s!$Grants_replaces[$1]!gx ;
$s =~ s!\s____DENY_SET_([\d]+)\s!$Denys_replaces[$1]!gx ;
$s =~ s!\s____REVOKE_SET_([\d]+)\s!$Revokes_replaces[$1]!gx ;
$s =~ s!\s____GRANT_OPTION_([\d]+)\s!$GrantOptions_replaces[$1]!gx ;

$s =~ s!\s____UPDATES_SET_([\d]+)\s!$Updates_replaces[$1]!gx ;
$s =~ s!\s____INSERTS_SELECT_([\d]+)\s!$Inserts_replaces[$1]!gx ;

$s =~ s!\s____CURSOR_FOR_UPDATES_([\d]+)\s!$CursorForUpdates_replaces[$1]!gx ;
$s =~ s!\s____CURSOR_FOR_SELECT_([\d]+)\s!$CursorSelects_replaces[$1]!gx ;

$s =~ s!\s____CASE_END_([\d]+)\s!$CaseEnd_replaces[$1]!gx ;

$s =~ s!\s____BRACKETS_([\d]+)\s!$Brackets_replaces[$1]!gx ;
$s =~ s!\s____SUBQUERY_([\d]+)\s!$Subquery_replaces[$1]!gx ;
$s =~ s!\s____UNION_([\d]+)\s!$Union_replaces[$1]!gx ;
$s =~ s!\s____STRING_([\d]+)\s!$S_replaces[$1]!gx ;
$s =~ s!\s____QUOTEDID_([\d]+)\s!$Q_replaces[$1]!gx ;


#print $s;

#my $idx = 0 ;
#for my $comment_pos ( @Comment_positions ) {
#    substr($s, $comment_pos, 1," ____COMMENT_${idx} ")  ;
#    $idx++;
#}
#
#$s =~ s!\s____COMMENT_([\d]+)\s!$Comment_replaces[$1]!gx ;

#print $s;

my @parsedInput = grep { $_ !~ /\A\s*\z/msx } split /\s*____SEPARATOR_TOKEN\s*/x,$s;

#pp @parsedInput ;
#
#my @tryblocks   = () ;
#my @blocks      = () ;
#my @ifs         = () ;
#my @whiles      = () ;
#
#
#my @begintryblocks          = indexes {/\Abegin\s+try\z/ims}    @parsedInput ;
#my @endtryblocks            = indexes {/\Aend\s+try\z/ims}      @parsedInput ;
#
#my @beginblocks             = indexes {/\Abegin\z/ims}    @parsedInput ;
#my @endblocks               = indexes {/\Aend\z/ims}      @parsedInput ;
#my @begincatchblocks        = indexes {/\Abegin\s+catch\z/ims}  @parsedInput ;
#my @endcatchblocks          = indexes {/\Aend\s+catch\z/ims}    @parsedInput ;
#my @ifstatements            = indexes {/\Aif\b/ims}  @parsedInput ;
#my @elsestatements          = indexes {/\Aelse\z/ims}  @parsedInput ;
#my @whilestatements         = indexes {/\Awhile\b/ims}    @parsedInput ;
#
#pp 'begin', @beginblocks ;
#pp 'end', @endblocks ;
#pp 'begin try', @begintryblocks ;
#pp 'end try', @endtryblocks ;
#pp 'begin catch', @begincatchblocks ;
#pp 'end catch', @endcatchblocks ;
#
#pp 'ifstatements',@ifstatements ;
#pp 'elsestatements',@elsestatements ;
#pp 'whilestatements',@whilestatements ;

my @cp_parsedInput = @parsedInput;

#my $blockCount = scalar @beginblocks ;
#my @bl = () ;
#while ( $blockCount > 0 ) {
#     foreach my $i (@beginblocks) {
#     }
#}
#my $done = 0 ;
##while (! $done ) {
#    my @blocks  = grep { my $b = $_; #my $e = first { my $e = $_ ; $e > $b and none { my $b2 = $_; $b2 > $b and $b2 < $e
#                                    #                                      } @beginblocks
#                                    #      } @endblocks
#                      ; [$b] ; #,$e]
#                      } @beginblocks ;
#    $done = 1;
##}
#
#pp @blocks;

return @parsedInput ;
}


sub tokeniser {
#
#my $qr_Id = q{(?:[#_\w$@][#$:_.\w]*)} ;
my $qr_Id = TSQL::Common::Regexp->qr_id();
#my $qr_label = q{(?:[#_\w$@][#$:_.\w]*[:])};
my $qr_label = TSQL::Common::Regexp->qr_label();

## add a backup create/drop/alter generic statement
## to cater for create xml index ???

my @Phrases =
(       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [qq{(?:\\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?

,       [q{(?:\b(?

,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?

,       [q{(?:\b(?
,       [q{(?:\b(?
,       [qq{(?:\\b(?
                                                                      , q{DECLARE_CURSOR}                         ]

,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [qq{(?:\\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [qq{(?:\\b(?
,       [q{(?:\b(?
                                ,                                     , q{SET_TRANSACTION_ISOLATION_LEVEL}        ]
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?
,       [q{(?:\b(?

#,       [qq{(?:\\b(?
#                                                                      , q{WITH} ]

,       [qq{(?:\\b(?
                                                                      , q{WITH} ]

,       [q{(?:\b(?
                                                                      , q{WITH_XMLNAMESPACES} ]
,       [q{(?:\b(?
                                                                      , q{OPEN__KEY} ]
,       [q{(?:\b(?
                                                                      , q{OPEN_SYMMETRIC_KEY} ]
,       [q{(?:\b(?
,       [q{\z}                                                        , q{} ]
)   ;

my %TERM_RE     = () ;
%TERM_RE        = map { my $key = $_->[0];
                        my $val = $_->[0] ;
                        $key =~ s{^[^A-Z]*}{}x;
                        ($key => $val);
                      } @Phrases ;

#my $TERM_RE     = join '|', map { qr{$TERM_RE{$_}}xmsi} reverse sort keys %TERM_RE ;
my $TERM_RE     = qr{${qr_label}}xmsi . '|' . join '|', map { qr{$TERM_RE{$_}}xmsi} reverse sort keys %TERM_RE ;



#patch these in first - nasty hack on top of a hack
#with .......... infect everything, is there any other DDL it can find its way into ?
#also need to patch trigger creation so as not let the main parser incorrectly parse things before the AS

$TERM_RE = qr{(?: \b(?:ALTER|CREATE)\b \s+ \bVIEW\b  \s+ \b(?:${qr_Id})\b (?:\s*____BRACKETS_\\d+)? (?: \s*  \bAS\b \s+(?: \bSELECT\b | (?: \bWITH\b .*? \bSELECT\b )))) }xmsi . "|" .
           qr{(?: \b(?:ALTER|CREATE)\b \s+ \bTRIGGER\b (?:.*?) \bAS\b ) }xmsi . "|" .
           qr{(?: \b(?:ALTER|CREATE)\b \s+ \bPROC(?:EDURE)?\b (?:.*?) \bAS\b ) }xmsi . "|" .
          "${TERM_RE}" ;



my $LBL_TERM_RE         = qr{ (?: (?: ${TERM_RE} ) .*?) (?= (?: (?: \b ${qr_label} \s+ )? (?: ${TERM_RE} ) ) ) }xmsi;

my $LBL_TERM_RE_OTHER   = qr{ \G (?: (?: \b ${qr_label} \s+ )? (?: ${TERM_RE} ) ) }xmsi;

#warn $LBL_TERM_RE  ;

   #return ($LBL_TERM_RE,$LBL_TERM_RE_OTHER) ;
   return $LBL_TERM_RE ;

}

1;

__DATA__