#! /usr/bin/perl
#
#
# k2l Daniel Brockman 090309 Macro substitutions into SQL code.
# subsql Daniel Brockman 090122 Macro substitutions into SQL code.
#
# (pron. KAY-TOO-ELL)
#
# Usage: k2l.pl file [ file [ ... ] ] 
#
# Left bracket and right bracket surround keyword which is a variable
# that substitutes arbitrary text.
#
# If supplied, k2l reads values from the early lines of file
# associates them with key names and substitutes the values for occurrences 
# of the keys later in the file.
#
# k2l writes translated text on stdout.
#
# If the first nonblank char on a line is "[", and if a word follows, and a "=" 
# follows the word, then it represents an occurrence of a token.
# If the subsequent nonblank character is an alpha, then the token is the 
# key name of a key-value pair.
# If the subsequent nonblank character is "-", then the token is a command.
# The key name is terminated by one or more whitespaces and "=".
# The "=" is followed by arbitrary text which k2l will substitute 
# into subsequently read lines of the input file.
# The end of the arbitrary text, and the key-value pair definition is marked 
# by "]".
#
# k2l enables quick translation of David Li's automation code for ad hoc
# usages.
#
# We acknowledge this is only a recent use of this kind of concept. Our 
# intention is to keep k2l very simple. For a fully featured work of the 
# same genre, consider the Unix make command and makefiles.
#
# In keeping with the simple approach, 
# 1. No commands are implemented at this time.
# 2. It's impossible to include "]" in the value of a key-value pair.
# 3. An assignment may not exist on the same line as code.
# 4. Key names must begin with a letter. They may consist of letters, 
# numbers and "_".
# 5. The "[" and "]" of a substitution must occur on the same line.
# 6. An assignment may span lines provided the "[" and "=" occupy the same line.
# 7. All characters are ignored if they follow the "]" of an assignment.
# 8. Substitutions may be nested, with inner brackets interpreted first.
#      example: The ultimate value of these substitutions is "3":
#               [ALPHA = 3 ]
#               [Beta = AL  ]
#               [Delta = pha]
#               [ [ beta ][delta] ]
# 9. All keys are interpreted in upper case, so your usage is case-insensitive,
# like SQL is case-insensitive.
# 10. A substitution may occur in an assignment.
# 11. k2l interprets substitutions from left to right on the line.
# 12. An assignment of a key must precede its use in a substitution.
#
#
# Example:
# If we have this input...
#   [RUN_DATE=10807]
#   CREATE TABLE AW_SROK.TB_LLC_Acct_lvl1_[RUN_DATE] AS
# Then we will have this output...
#   CREATE TABLE AW_SROK.TB_LLC_Acct_lvl1_10807 AS
#
# Lore:
# k2l evolved from a predecessor named subsql, which didn't permit
# nesting of substitutions.
# The name k2l comes from a pattern of initial usage in which 
# files containing assignments and substitutions were suffixed "sqk"
# and converted to "sql" by subsql, the predecessor of k2l.
# David Li's automation code uses "[" and "]" for substitutions 
# and inspired subsql, the predecessor of k2l.
#
# Buglist:
# 1. Fixed. 090312. Cant properly interpret end of assignment if 
# interrogation appears on line. See ~Wkk2l/CYZ.sqk .
#
# Enhancement list:
# 1. 090612. Allow at most 2 consecutive blank output lines.
#


#--

# define and recursively replace all occurrences of tokens in line

use strict vars ;
use strict subs ;

  my %val ;
#  $val{ALPHA}    = "one" ;
#  $val{BETA}     = "two" ;
#  $val{GAMMA}    = "three" ;
#  $val{ONETHREE} = "four" ;

  my $nsn = 0 ;          # = 1 if assignment has begun and is incomplete
  my $endasn = 0 ;       # =1 if this line ends assignment
  my $key ;              # key of key value pair read from input
  my $value ="" ;        # value of key value pair read from input
  my ( $ii, $jj, $kk ) ; # aux
  my ($sc1, $slug );     # aux
  my $n=0 ;              # loop counter
  my $lineflag=100 ;     # count of consecutive blank lines # 090612

while (my $line = <>) {                      # read line from file
  $line =~ s/\r\n$// ;                  # compatibility w dos
  $line =~ s/\r$// ;                    # compatibility w dos
  $line =~ s/\n$// ;                    # compatibility w dos
  chomp($line);

 $n++ ;                         # count lines

  # first we substitute whatever we can
  #
  my $bline="" ;                             # line before
  my $frag="" ;
  my $rear="" ;
  while ( $bline ne $line) {  # loop the line

      $bline = $line ;                    # save last
      &dbrac(\$line,\$frag,\$rear,\%val,0) ;     # find and sub

  } # end loop the line


  if ( $nsn==0 ) {          # if no assignment in progress
    
    if ( ($line =~ m/^\s*\[\s*(\w*)\s*\=(.*)/) ) {   # this line begins assign?
      $key = $1 ;
      $key =~ tr/a-z/A-Z/ ; # upcase all keys
      $line = $2   ;        # whatever follows = on the line.
      $nsn=1       ;        # assignment in progress  <---!!

    } else {                # no assignment in progress
      # replace the special newline symbol
      # Note: I'm not too happy with this but today I need an expedient.
      $line =~ s/\|\|\|\|\|NEWLINE\|\|\|\|\|/\n/g ;  # 
      # we print if it's not an assignment
      # we limit to 2 consecutive blank lines # 090612
      if ($line =~ m/^\s*$/ ) {  # 090612
        $lineflag++ # 090612
      } else { # 090612
        $lineflag = 0 ; # 090612
      } # 090612
      if ($lineflag <= 2) { # 090612
        print "$line\n" ;
      } # 090612
    }
  }

  # if we have begun an assignment, then we pick up the value
  if ( $nsn==1 ) {          # if assignment in progress

    $endasn = 0 ;                # =1 if this line ends assignment
    if ($line =~ m/(.*)\]/ ) {      # this line ends assignment?
      $slug = $1 ;               # pick up all before bracket

      # now we analyze line more carefully
      $sc1 = $line ; 
      # [ \t] = tabs and spaces
      while ( $sc1 =~ m/\[[ \t]*\w*[ \t]*\]/ ) {   # while substitutions remain

        $sc1 =~ s/\[[ \t]*\w*[ \t]*\]//g ;  # remove all substitutions
      }    # end while substitutions remain
      if ( $sc1 =~ m/\]/ ) {        # still a right bracket?

        $line = $slug ;                 # discard bracket and beyond
        $endasn = 1   ;                 # this line ends assignment
      }                             # end still a right bracket
    }

    if ( ! ($value =~ m/^\s*$/) ) { # not merely white space?
      $value = $value."\|\|\|\|\|NEWLINE\|\|\|\|\|".$line ;  # accumulate value
    } else {
      $value = $line ;              # simple assignment
    }


    if ( $endasn==1 ) {           # this line ends assignment?
      $value =~ s/^[ \t]*// ;    # trim ldg/trlg white space except \n
      $value =~ s/[ \t]*$// ;    # trim ldg/trlg white space except \n
      $val{$key}=$value ;           # overwrite existing value at $key
      $nsn=0 ;                      # assignment completed
      $value = "" ;                 # reinitalize value
      $endasn = 0 ;                 # cleanup
    }

  } # end if assignment in progress

}                      # end read line from file

#-----------------------------------------
sub dbrac() {          # substitute value for keyname in brackets

  # Usage: 
  # $bm = "";
  # $br = ""
  # &dbrac(\$line,\$bm,\$br,\%val,0) ;
  # 
  #
  # The resulting $line includes the substitutions.
  #
  # dbrac() makes one pass at $$line, performing substitutions from left to r.
  # In principle, a prior substitution could produce a new parameter for 
  # substitution, for example:
  # [A = one]
  # [B = two  ]
  # [oneandtwo = three ]
  # [[A]and[B]]
  # One invocation of dbrac() will return [oneandtwo].
  # To carry through further substitutions, do something like:
  # $oldline=""; $m=""; $r="" ;
  # while ($oldline ne $line) {
  #   $oldline=$line ;
  #   &dbrac(\$line,$m,$r,\%val,0) ;
  # } # end while

  # [ \t] = tabs and spaces

  my ( 
    $rlf,               # ref to left part of chomped line
    $rfrag,             # ref to fragment containing bracket
    $rrt,               # ref to right part of chomped line
    $rval,              # ref to hash of keyvalue pairs
    $lvl,               # indicates the level of recursion
  ) = @_ ;

  $lvl++ ;              # we've sunk to a new level (useful for debugging)

    if ( $$rlf =~ m/(.*)(\[[ \t]*\w*[ \t]*\])(.*)/ ) {
      my $slf=$1 ;           # left subfragment
      my $sfg=$2 ; # fragment subfragment
      my $srt=$3 ;           # right subfragment
      &dbrac(\$slf,\$sfg,\$srt,$rval,$lvl) ;
      $$rlf = $slf.$sfg.$srt ;   # reassemble
    } # if rlf

    if ($$rfrag =~ m/\[[ \t]*(\w*)[ \t]*\]/ ) {
      my $key = $$rfrag ;        # let's sub this key
      $key =~ s/\[[ \t]*(\w*)[ \t]*\]/$1/  ;    # strip brackets
      $key =~ tr/a-z/A-Z/ ;   # upcase
      if ($$rval{$key}) {       # we have a key-value pair like this?
        $$rfrag = $$rval{$key} ;   # substitute
      }
    }  # if rfrag
    #}

  # the interpretation of the regex is such that we never
  # have unresolved keys on the right, but always in the 
  # left or the middle.

} # sub dbrac

#---------------------------------------