# <20240519.1613.03>

# A collection of routines to handle strings.  We mean to
# properly handling space, $, {} and [] in strings where these are not
# supposed to be operators.

# Several of these routines use ::spSTRING.  This is a string that is
# used to replace spaces in strings so that the resulting string is
# space free. The default value is ">sp<" and is set if ::spSTRING is
# either undefined or {}. The actual value may be any reasonable
# string with no blanks.  To work properly it must not occur in any
# of the strings to be processed.
# 
# Note that a tcl list is really a bunch of strings separated by white
# space. Tcl puts braces ({}) around list elements with blanks in them.
# If lists are passed to these routines they will be processed as if
# they were strings. We stay away from the list commands as they tend
# to introduce random ({})s and also tend to treat any white space
# between list elements as element separators. These white space
# characters would all be transformed to single spaces if we used
# list operators to process the strings.
#
# The 'sl' functions are take offs on list operators which always produce
# what we call 'string lists'.  A string list is a tcl list that does
# not use braces.  'sl's can not be nested because the '"' operator is
# not paired as are {}, [], etc.  So a string list is a tcl list but not
# all tcl lists are string lists. A 'flat' tcl list can easily be converted
# to a sting list (slList {*}$tcllist).
#
if {![info exists ::spSTRING] || $::spSTRING == {}} {
  set ::spSTRING ">sp<"
}


# This routine changes '{...}' sequences to '"..."' sequences
# Caution: Does not do nice things to nested braces
proc braceToQuot {string} {
  return [regsub -all {(({)(.*)(})){1,1}?} $string {"\3"}]
}

# FixFormatString will join list elements very much like 'join str $::spSTRING'
# it differs only in that it will retain multiple spaces and other white space

proc FixFormatString {str} {
  # we do two things:
  # 1 for each element in the string 'str' replace the blanks with 'spSTRING'
  # turn the result into a simple string with no {}s
   # we do this with regsub to preserve any $ \ or [ in the string
  set nstr {}
  foreach st $str {
    slAppend nstr [regsub -all { } $st $::spSTRING] 
  }
  return [regsub -all {\{|\}} $nstr {}]
}

# ReSpaceString is not quite like 'split' in that it splits strings on
# ::spSTRING (i.e. a string of arbitrary length) and preserves the result
# with '"'s where needed and it returns a string (which of course can be
# taken as a list)

proc ReSpaceString { prefix str {noq {}}} {
  # This does the inverse of the above, taking a string apart and
  # entry at a time to remove the 'space' replacement chars.
  # prefix is usually set to 'exec' but you can use anything, even ""
  # if 'noq' is not {} quotes will not be added...  Otherwise, quotes
  # will be added if any spaces are found and quotes are not already
  # present. If spaces appear in the string they are taken as the
  # end of one quoted string and the start of the next.

  # define a string of one quote in a way that my editor does not get confused
  set qt [expr {$noq == {} ? [string index {""} 0] : {}}]
  set ncmd "$prefix "
  set str [string trim $str]
  while {[regexp {(^[^, ]+)((([ ,]+)(.*))|$)} $str m first mid sec sp next]} {
    frputs #2 first  mid se  sp next ncmd

    if { [regsub -all "$::spSTRING" $first { } first] && \
	     [string index $first 0] != $qt } {
      append ncmd "${qt}${first}${qt}"
    } else {
      append ncmd "$first"
    }
    append ncmd [string range $sp 0 end]
    # puts "next >$next< >$sp< ncmd >$ncmd<"
    set str $next
  }
  if {[string index $ncmd 0] == " "} {
    return [string range $ncmd 1 end]
  }
  return $ncmd
}

# The following routine converts strings containing \ protected spaces
# into quoted strings. It takes a string with "\ " sequences and returns
# an equivalent string where the string containing "... ..."
# The optional parameter "sp" is used to replace the space during the
# conversion.  If the sequence chosen interferes, supply your own.
# The code depends on that string not appearing in the string to be processed.

proc bslashSpcToQuot {string} {
  # use double quotes to round up the spaces...
  # We have to be VERY careful not to use list structure things here
  # as they introduce {}'s and miss handle []'
  # we want to convert 'x\ y' to '"x y"'

  # replace all "\ " with the sp string
  #set string [regsub -all {\\} [regsub -all {\\ } $string $::spSTRING] {\\}]
  set string [regsub -all {\\ } $string $::spSTRING]
  #puts "$string"
  return [ReSpaceString {} $string]
}
# Here is a routine to format files for frECF (using the %m conversion) into
# shell format strings. Written for files it should also work for any 'bad'
# string.
#
# The basic idea is that we will always quote the given string.  If the string
# contains '"'s we will quote with ', else with "
# Given that it is all properly quoted, we then remove any backslashs that
# are protecting spaces. 

proc shellFormat {string {msw 0}} {
  set string [regsub -all {\\ } $string { }]
  # Remove ' " and {} full string quots
  set firstlast [string index $string 0][string index $string end]
  if {$firstlast in {'' {""} {{}} } } {
    set string [string range $string 1 end-1]
  }
  frputs firstlast string
  # protect " and ' within the string
  set string [regsub -all \" $string {\"}] 
  set string [regsub -all \' $string {\'}] 
  set qt \"
  if {[string first $qt $string] != -1} {
    set qt '
    set string [regsub -all $qt $string "\\$qt"]
  }
  return [append qt $string $qt]  
}

# This function fixes file names (and other parms) for exec calls 
# 'result' is assumed to be a file name (but may be something else).
#
# There are two modes, "MS windows" (MSW) and NOT "MSW"
# The mode is determine here (not passed in)
#
# There are 4 options:
#  option  min abbreviation
# -level    -l
# -chars    -c
# -+chars   -+
# -space    -s
# +cmd      +c (only used in MSW version to do final escape)
# -Force    -F if 1 & MSW forces MSW quoteing, ignored if not MSW
# -platform -p if (MSW, forces MSW action, UNIX, forces UNIX action)
#              default (nil == {}) action based on actual platform
#
# -level -1 does percent/URL encoding 
# -level 0  only does the native  
# -level 1  only does the native and "\" thing
# -level 2  and above (to 4) do additional '\'s to allow deeper calls
#           If MSW this is ignored.       

# '-chars' provides an alternate set of characters to '\'ed or percent/URL encode.
#          default -chars is "{}[] "$" (the backslash is always '\'ed.)
#          default percent/URL -chars are: "! "#\$%&'()*+,:;<=>?@[]^`{|}"
#          For MSW this default is nil.
#          This option eliminates any preceding '-chars' or '-+chars' options
#          in the argument list.

# '-+chars' provides extra characters to add to '-chars'
#          (characters {"}[  & ] need to be protected in
#          in -chars and -+chars i.e. -chars {\[\]\"}. This option must
#          follow any '-chars' as that option will override this if it
#          appears after this option. Multiple '-+chars' may be specified.
#                    
# '-space' if true or a character sequence, will be used to
#          replace blanks. If true, with ::spSPACE else with the#          provided sequence. (Default is false) 
#
#  -space != 0  replace spaces with ::spSpace or provide sequence
#  -space == 0  -chars contain { } replace with "\ "
#  -space == 0 && {} ni -chars     treated like normal character
#
# If { } in -chars or -space != 0  we also remove leading and
#                                  trailing unprotected {}s or
#                                  if no leading and trailing {}
#                                  then leading and trailing
#                                  quotes ("). Thus:
#                                  {"foo"}  => "foo"
#                                  "{foo}"  => {foo}
# For MSW the following is done if:
# a. -Force   is true (1) OR
# b. 'result' is nil {=={}} OR
# c. 'result' contains at least one of {" " \t \n \v \" \ }
# d. 'result' is quoted (either or both of "" or {})
# e. -l is not 0 (i.e. not URL/percent encoding)
#
# In these cases:
# the whole of 'result' is quoted (result -> "result"). In addition
# if there are final "\"(s) they are doubled (to protect the '"' we add)
# and backslashes preceeding a {"} are doubled and the {"} is backslashed
# and an odd number of backslashes preceeding a " " (blank) is reduced by 1.

#
# If "cmd" is true (regardless of cases a-e above) the meta characters:
# (, ), %, !, ^, ", <, >, &, and |
# are preceeded with "^" (which causes cmd to just pass the characters.
# Note that this means you can not use cmd to pick up env variables,
# use $env(...) instead.
#

# FixFileNameO is the same routine with an older interface. It differs
#              in that ch & sp are std. parameters..
#              in this call sp may only be true or false where
#              true means the same as -space true
#              defaults are -chars {}, -level 1, -space 1

# proc FixFileNameO {result {level 1} {ch {}} {sp {}}} {
#   return [FixFileName $result [list \
# 				   -l $level\
# 				   -c $ch\
# 				   -s [expr {$sp != {} ? 0 : 1}]]]
# }
# subst [regsub -all {#| } {#1.j pg} {%[binary encode hex "\0"]}]

# 1. ':' , '/' , '?' , '#' , '[' , ']' , '@' , '!'
# 1.  :/?#[]@!

# 2. { , } , | , \ , ^ , ~ , [ , ] , and `
# 2. {,}|\^~[]`

# reserved:
#     ampersand ("&")
#     dollar ("$")
#     plus sign ("+")
#     comma (",")
#     forward slash ("/")
#     colon (":")
#     semi-colon (";")
#     equals ("=")
#     question mark ("?")
#     'At' symbol ("@")
#     pound ("#").

# 3. &$+,/:;=?@#
# The characters generally considered unsafe are:

#     space (" ")
#     less than and greater than ("<>")
#     open and close brackets ("[]")
#     open and close braces ("{}")
#     pipe ("|")
#     backslash ("\")
#     caret ("^")
#     percent ("%")

#  3+ < >[]{}|\^%

# 4. pct-encoded "!" / "$" / "&" / "'" / "(" / ")" / "*" / "+" / "," / ";" / "="
# ":" / "@"
# 4. !$&'(/)/*+,;=:@

# 5.    &$+,:;=?@#<>[]{}    /([^\x00-\x7F]|[&$\+,:;=\?@#\s<>\[\]\{\}|\\\^%])+/

#                      { } ! " # $ % & ' ( ) * + , : ; < = > ? @ [ \ ] ^ ` { | } ~
# 1.  !#:?[]@
# 2. ,\[]^`{|}~
# 3.  !"#$%&'()*+,:;<=>?@[\]^`{|}
# 4. !$&'()*+,:;=@
# 5. &#$+:;,<=>?@[]{}   

proc FixFileName {result args} {
  # set up defaults
  frputs result args
  set defaultChars {\{\}\[\]\" $}
  set -level 1
  set -chars {}
  set perChars {! \"#\$%&'()*+,:;<=>?@\[\]^`\{|\}\\}
  set -space 0
  set -+chars {}
  set +cmd    0
  set -Force  0
  set -platform {}
  set possible {-level -chars +cmd -space -+chars -Force -platform}
  set touched {}
  
  foreach {opt value} [concat {*}$args] {
    set tar [lsearch -glob -all -inline $possible "$opt*"]
    if {$tar == -1 || [llength $tar] != 1} {
      error "FixFileName: option ($opt) must be one of $possible"
    }
    lappend touched $tar
    set $tar $value
    append -chars ${-+chars}
    set -+chars {}
  }
  if {"-chars" ni $touched} {
    set -chars [expr {${-level} >= 0 ? $defaultChars : $perChars}]
  }
  set MSW [expr {($::tcl_platform(platform) == "windows" || ${-platform} == "MSW") && \
		     ${-platform} != "UNIX"}]
  # set prostrsp [lindex {{&} {\\&} {\\\\&} {\\\\\\\\&} {\\\\\\\\\\\\\\\\&} \
      # 			    {\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\&} }\
      # 		    ${-level}]
  set doit 0
  if {${-level} >= 0} {
    set prostrsp [lindex {{&} {\\&}\
			      {\\\\\\&}\
			      {\\\\\\\\\\\\\\&}\
			      {\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\&}\
			    } ${-level}]
    set doit [expr {$MSW && (${-Force} ||\
				 $result == {} || \
				 [regexp {\{|\t| |\n|\v|\"|\$|\[|\\} $result])}]
  }
  frputs prostrsp doit
  # -space may be true false or some set of chars.
  # we are careful with the logic so we get this right...
  # In particular ! false does not imply true.
  
  if {$doit || [string match "* *" ${-chars}] || ! [string is false ${-space}]} {
    # We are getting rid of spaces, so knock off any full string quotes...
    if {[regsub {^\{(.*[^\\])\}$} $result {\1} result] == 0} {
      regsub {^\"(.*[^\\])\"$} $result {\1} result
    }
  }
  if {$MSW} {
    if {$doit} {
      set result \"[regsub -all {([\\]+)} $result {\1\1}]\"
      set result [regsub -all {(\[\|[\]|\$])} $result {\\\1}]
      # set result \"[regsub {([\\]+)$} $result {\1\1}]\"
    }
    if {${+cmd}} {
      set result [regsub -all {(\(|\)|%|!|\^|\"|<|>|\&\|)} $result {^\1}]
    }
    frputs result -level
  } elseif {${-level} >= 0} {
    if {! [string is false ${-space}]} {
      set spRep [expr {[string is true ${-space}] ? $::spSTRING : ${-space}}]
      regsub -all { } $result  $spRep result
    }

    append -chars {\\\\}
    if { ${-level} != 0 } {
      regsub -all "(\[${-chars}])" $result $prostrsp result
    }
  } else {
    # URL/percent encoding
    frputs -chars
    set t [regsub -all "(\[${-chars}])" $result {%[binary encode hex "\0"]}]
    frputs result t -chars
    set t [regsub -all {\"\"\"} $t {{"}}] ; set x {"}
    set t [regsub -all {\\} $t {\\\\}]
    frputs t 
    set result [subst $t]    
    }
  frputs result
  return $result
}


###########################################################
# These routines are here to deal with the conversions of strings
# into  parameters for the command line. For example we may get
# a command line from, well, where ever, that needs to be passed
# to an external program which does not understand braces as
# quotes. Tcl, on the other hand, uses braces to protect 'special'
# characters when it builds lists.
namespace eval slLspace { }
# The following "string list" functions are defined here:
# slAppend
# slList
# slConcat
# slLsort
# slLreplace
# slLreverse
# slLrepeat
# slLset
# tclListToSl
#
# A note in passing, the slList function does a much better job of
# building scripts to be executed later. 

# With the exception of slAppend and slList these routines use the
# standard list code and then fix the result. If there are several
# operations to be done, it might be more efficience to use the standard
# routines and complete with the conversion to a "string list".  This is
# simply [slList {*}$tcllist] (see tclListToSl)

# slAppend is the string list append command.  It will take any number of
# arguments and append them to "to" which should be a varname.
# This function puts spaces between each element and, if an element
# has spaces in it, protects the element with a pair of quotes or, if
# there are embeded quotes braces are used.
# to append two strings see slConcat
# slAppend returns the ending value of 'to' as well as setting it.

proc slAppend {to args} {
  upvar $to too
  foreach thi $args {
    if {[string match {* *} $thi]} {
      if {[string match {*\"*} $thi]} {
	append too " \{$thi\}"
      } else {
	append too " \"$thi\""
      }
    } else {
      append too " $thi"
    }
  }
  if {[string index $too 0] == " "} {
    set too [string range $too 1 end]
  }
  return $too
}

# while 'slAppend' does a string sort of 'lappend', 'slList' does
# a string sort of 'list'.
proc slList {args} {
  set local {}
  #foreach arg $args {
    slAppend local {*}$args
  #}
  return $local
}


# proc tclListToSl {list} {return [slList {*}$list]}

# concat...
#
# proc slConcat {args} {
#   foreach ar $args {
#     slAppend local {*}$ar
#   }
#   return $local
# }

# proc slLreplace {args} {
#   return [slList {*}[lreplace {*}$args]]
# }

# proc slLreverse {args} {
#   return [slList {*}[lreverse {*}$args]]
# }

# proc slLrepeat {args} {
#   return [slList {*}[lrepeat {*}$args]]
# }

# proc slLsort {args} {
#   return [slList {*}[lsort {*}$args]]
# }


# # This one is a bit messy.  Need to handle the list several times
# proc slLset {var args} {
#   upvar $var lvar
#   return [set lvar [slList {*}[lset lvar {*}$args]]]
# }

#
# counts the occurance of "what" in "string"
#
proc stringCount {what string} {
  set result 0
  set start  0
  set len [string length $what]
  if {$len == 0} {return -1}
  
  while {[set loc [string first $what $string $start]] != -1} {
    incr result
    set start [expr {$loc + $len}]
  }
  return $result
}
# The 'slLassign' routine uses 'slCore' to break up a string using the
# provided protect and quote characters.

# 'options' defines the protect
# and quote characters. It is a list of sublists where each sublist is:
# a) a single character which defines a single character qoute (such as
#    backslash). It may also be the key word 'std' (see below).
# b) a list of two characters defining an open and close quote pair.
# c) a null ({}) in which case the standard (std) tcl quote chars are
#    used. This is the same as 'option' = {\\ {\" \"} {\{ \}}}.
# As many a) and/or b) entries as desired can be used.
# 'std' in the 'option' list adds the standard backslash, quote and
# braces to the list.
#
# args is a list of variables to be filled in from the 'string' much
# like the 'lassign' command. If the string does not have enough
# chunks to define all the variables the remaing variable are filled with
# empty strings ("").
#
# 'slLassign' returns the remaining string which may have a leading space.


proc slLassign {string options args} {
  foreach var $args {
    lassign [slCore $string $options] st en
    upvar $var mvar

    set mvar [string range $string $st $en]
    set string [string range $string $en+2 end]
  }
  return $string
}

# The 'slLlist' command builds a standard tcl list from the presented
# 'string'. 'options' are the same as above.
# The return value is a tcl list.

proc slLlist {string {options {}}} {
  set list {}
  while {1} {
    lassign [slCore $string $options] st en
    if {$st > $en} {return $list}
    lappend list [string range $string $st $en]
    set string [string range $string $en+2 end]
  }
}


# The slCore routine finds the first white space (wp) delimited bit
# of string 'string'. 'args' should be a list of lists.
# Each sub list should consist of one or two entries. If two entries it
# defines an additional start/end quote pair. If sub list is one
# character it defines a single character quote which protects the
# next character. E.g. the tcl quote standard would be:
# {{\\} {\{ \}} {\" \"}}
# The start and end quotes may be 1 or 2 characters each. They need
# not both be the same size, e.g. {// //} or {/ //}
# Quotes may be nested as in '"...{...}.."' where '""' and '{}' are
# defined as quote chars. If 'args' is not provided the standard is used.
# If 'std' appears in the args list the standard is used along with
# any preceding or following additions. 
#
# 'slCore' returns a list of 2 indexes into 'string. These defind
# the found sub string as in: string range $string 'index 1' 'index 2'.
# The remaining string is:    string range $string 'index 2+2' 'end'.
# The sub string will have no leading or trailing wp while the remaing
# may have either or both.

proc slCore {string {options {}}} {
  global ::slLspace::lastOptions
  global ::slLspace::singlePros
  global ::slLspace::quots
  global ::slLspace::opens
  # Here is a little speed up. We only set up the data arrays if
  # 'args' differs from the last call.
  if {![info exists lastOptions] || $options != $lastOptions} {
    # We have three elements to build,
    # array of end quotes
    # list of start quotes
    # list of protection chars
    set singlePros {}
    catch {unset -nocomplain quots}
    set ar [concat $options\
                     [expr {$options == {} || "std" in $options ?\
                                [list \\ {\" \"} {\{ \}}] : {}}]]
    foreach arg $ar {
      lassign $arg e1 e2

      if {$e2 == ""} {
        if {$e1 == "std"} {continue}
        lappend singlePros $e1
      } else {
        frputs e1 e2 arg ar args
        set quots($e1) $e2
      }
    }
    set opens [array names quots]
    set lastOptions $options
      
  }
  # skip over leading spaces...
  set idx -1
  set len [string length $string]
  set target " "
  while {[string index $string [incr idx]] == " "} {}
  set r1 $idx
  set stk {}
  
  while {$idx < $len} {
    set ch [string index $string $idx]
    incr idx
    set nx2Ch ${ch}[string index $string $idx]
    frputs target nx2Ch
    if {$ch == $target || $nx2Ch == $target} {
      if {$ch == " "} {
        frputs 1 r1 idx
        return [list $r1 [incr idx -2]]
      }
      # pop next target off the stack
      if {$nx2Ch == $target} {
        incr idx
      }
      set stk [lassign $stk target]
      continue
    }
    if {$ch in $singlePros} {
      incr idx
      continue
    }
    if {$nx2Ch in $opens} {
      set stk [linsert $stk 0 $target]
      set target $quots($nx2Ch)
      incr idx
      continue
    }
    if {$ch in $opens} {
      # Push old target, set up new one
      set stk [linsert $stk 0 $target]
      set target $quots($ch)
    }
  }
  # end of string. If target is not 'space' we have
  # a malformed string...
  if {$target == " "} {
    frputs 2 r1 idx
    return [list $r1 [incr idx -1]]
  }
  return -code error\
      "Quote character(S) `$target [lrange $stk 0 end-1]` not found."
}

# starting at 'arg' in string, return the index of the first
# character that is not 'what'. Arg may be an expression that
# results in an integer.

proc stringNextNot {what string {arg 0}} {
  set arg [expr $arg]
  while {[string index $string $arg] == $what} {incr arg}
  return $arg
}

# Here is little ditty which takes an arbitrary string and breaks off
# the first "white space' (ws) delimited chunk. It ignors protected ws.
# ws can be protected in three ways:
# " ",  { }, and {\ }
# and these inturn can be protected by {\}.
# Once we are in a protected string we will not allow the other
# type to take over. Thus quotes can protect braces and braces
# can protect quotes.
#
# The parameters: <string> is the string to get a chunck of.
#                 <start>  is the var name of the character position to start at.
# The return is a character index such that [string range <string> start rtn]
# is the requested chuck.
# <start> may be adjusted to move past white space

# options: stoponclose 1  returns when quote count is 0 (first char must be " or openbrace)
#          protectchar <char>   <char> will protect a close or open quote
#          openQ <open-char> closeQ <close-char> changes the brace to what ever
#                                                (maybe ' and ')

# If the return == <start> the string from <start> to end is ws or empty

proc stringGetToken {string start args} {
  upvar $start begin
  array set opAry [list stoponclose 0 protectchar "\\" openQ "\{" closeQ "\}"]
   
  
  array set opAry $args
  set len [string length $string]
  while {[string is space -strict [string index $string $begin]]} {incr begin}
  if {$begin >= $len} {
    # frputs "1  " begin len string
    return [expr {$begin -1}]
  }
  set openBrace  $opAry(openQ)
  set closeBrace $opAry(closeQ)
  set idx $begin
  set brace 0
  set inquote 0
  while {$idx < $len} {
    set ch [string index $string $idx]
    # frputs "2  " idx ch len
    incr idx
    if {$ch  in {"\\" $opAry(protectchar)}} {
      incr idx
      continue
    }
    if {$ch == "\"" && $brace == 0} {
      # either first and unprotected quote or
      # protected by brace or
      # final quote
      if {$inquote} {
	set inquote 0
      } else {
	incr inquote
      }
    } elseif {$ch == $openBrace && !$inquote} {
      incr brace
    } elseif {$ch == $closeBrace && !$inquote && $brace > 0} {
       incr brace -1
    } elseif {[string is space -strict $ch]} {
      if {!$inquote && $brace == 0} {
	return [incr idx -2]
      }
    }
    if {!$inquote && $brace == 0 && $opAry(stoponclose)} {
      break
    }
  }
  return [incr idx -1]
      
}
