# General parse/string module.
# Rick Smereka, Copyright (C) 2005-2006.

# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.

# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.

# You should have received a copy of the GNU General Public License
# along with this program; if not, get a copy via the Internet at
# http://gnu.org/copyleft/gpl.html or write to the Free Software
# Foundation, Inc., 59 Temple Place, Suite 330, Boston,
# MA 02111-1307 USA

# You can contact the author via email at rsmereka@future-lab.com

# Initial tcl version. Mar/2005, Rick Smereka

# Fixed bug in procedure 'command_words' that caused a break
# when a command word started with a hyphen. Added '--' to
# 'switch'. Mar/2006, Rick Smereka

proc trim {instr} {
   # Trim a string by removing all spaces from the beginning
   # and the end plus remove all extra spaces between words.
   # The 'trim'ed string is returned.
   set nwords [words $instr]
   set outstr ""
   set wrd ""

   if {$nwords <= 0} {
      return $outstr  
   }

   # obtain each word and concatenate into output string
   for {set i 1} {$i <= $nwords} {incr i} {
      set ret [word $instr wrd $i]

      if {!$ret} {
         set outstr ""
         return $outstr
      }

      append outstr $wrd

      if {$i < $nwords} {
         append outstr " "
      }
   }

   return $outstr
}

proc word {instr outstr which} {
   # Extract the 'which' space delimited word from 'instr'.
   # Result word is placed into 'outstr' upon success.
   # Returns 1 upon success, 0 otherwise.

   upvar $outstr lk
   set nwords [llength $instr]
   set lk ""

   if {$which <= 0 || $which > $nwords} {
      return 0
   }

   set lk [lindex $instr [expr $which - 1]]
   return 1
}

proc ll_word {instr outstr which delim} {
   # Extract the 'which' word of 'instr' and return it in
   # 'outstr'. Each word is delimited by 'delim'.
   # Returns 1 upon success, 0 otherwise.
   upvar $outstr lk
   set lk ""
   
   # split input into space delimited words
   set sinstr [split $instr $delim]
   set nwords [llength $sinstr]

   if {$which <= 0 || $which > $nwords} {
      return 0
   }
      
   set lk [lindex $sinstr [expr $which - 1]]
   return 1
}

proc wordlen {instr which} {
   # Get the length of space delimited word 'which' in
   # 'instr'. Returns the length upon success,
   # -1 otherwise.
   return [ll_wordlen $instr $which " "]
}

proc ll_wordlen {instr which delim} {
   # Get the length of 'delim' delimited word 'which'
   # in 'instr'. Returns the length upon success,
   # -1 otherwise.
   if {![string length $instr]} {
      return -1
   }
   
   set wrd ""
   set ret [ll_word $instr wrd $which $delim]

   if {!$ret} {
      return -1
   }

   
   return [string length $wrd]
}

proc indxword {instr which} {
   # Return the index of space delimited word 'which'
   # within 'instr'. Returns the index (base 0) upon
   # success, -1 otherwise.
   return [ll_indxword $instr $which " "]
}

proc ll_indxword {instr which delim} {
   # Return the index (base 0) of word 'which' within 'instr'
   # delimited by 'delim'. Returns the index upon success,
   # -1 otherwise.


   if {![string length $instr]} {
      return -1
   }

   if {[string length $delim] != 1} {
      return -1
   }

   if {$delim == " "} {
      set tmp [trim $instr]
   } else {
      set tmp $instr
   }

   if {$which <= 0 || $which > [ll_words $tmp $delim]} {
      return -1
   }

   set len [string length $tmp]

   if {!$len} {
      return -1
   }

   set i 0
   set nwords 1

   while {$i <= $len} {
      set indx $i

      if {$nwords == $which} {
         return $indx
      }

      set ch [string range $tmp $i $i]

      while {$ch != $delim & $i <= $len} {
         incr i
         set ch [string range $tmp $i $i]
      }

      incr nwords
      incr i
   }

   return -1
}

proc words {instr} {
   # Count the number of space delimited words in 'instr'.
   # Returns the number of words.

   return [llength $instr]
}

proc ll_words {instr delim} {
   # Count the number of 'delim' delimited words in
   # 'instr'. Returns the number of words.

   # split input into space delimited words
   set sinstr [split $instr $delim]
   return [llength $sinstr]
}

proc command_words {p_string} {
   # Count the number of 'command' words in a string. A
   # command word can be either a space delimited word or
   # an entire paragraph delimited by matching quotes.
   # Returns the number of command words found upon
   # success, zero otherwise.
   set t_string $p_string
   set len [string length $t_string]

   if {!$len} {
      return 0
   }

   set nwords 0
   set pos 0
   set done1 0

   # tcl has no do-while loop so I fake it with a while loop
   # loop through all the characters looking for delimiters
   while {!$done1} {
      set ch [string index $t_string $pos]

      switch -- $ch {
         " " {
            # a space is an unconditional word
            incr nwords
            incr pos
         }

         "'" -
         "\"" {
            if {$pos > 0} {
               set prev_pos [expr $pos - 1]
               set prev_ch [string index $t_string $prev_pos]

               if {$prev_ch != " " && $prev_ch != "\"" && $prev_ch != "'"} {
                  incr nwords
               }
            }

            set delim $ch
            
            set found 0
            set done2 0
            incr pos

            # find matching quote
            while {!$done2} {
               set ch [string index $t_string $pos]

               if {$delim == $ch} {
                  set next_pos [expr $pos + 1]
                  set ch [string index $t_string $next_pos]

                  if {$ch == " "} {
                     set pos [expr $pos + 2]
                  } else {
                     incr pos
                  }
 
                  # add another word as long as the quote is
                  # not the last character
                  if {$pos < $len} {
                     incr nwords
                  }

                  set found 1
               } else {
                  incr pos
               }

               if {$found || $pos > $len} {
                  set done2 1
               }
            }
         }

         default {
            incr pos
         }
      }

      if {$pos > $len} {
         set done1 1
      }
   }

   incr nwords
   return $nwords
}

proc command_word {instr outstr which} {
   # Parse a string and extract the 'which' command word of
   # 'instr'. Output word will be placed into the string
   # 'outstr' upon success. Returns 1 upon success,
   # 0 otherwise.
   upvar $outstr lk
   set lk ""
   
   if {$which <= 0 || $which > [command_words $instr]} {
      return 0
   }

   set pos [command_indxword $instr $which]
   set epos [expr [command_wordlen $instr $which] + $pos - 1]
   set str [string range $instr $pos $epos]
   set lk $str
   return 1
}

proc command_indxword {instr which} {
   # Return the index of word 'which' within 'instr'
   # command delimited. Returns the index (base 0)
   # upon success, -1 otherwise.
   set len [string length $instr]

   if {!$len} {
      return -1
   }

   if {$which <=0 || $which > [command_words $instr]} {
      return -1
   }

   set nword 1
   set pos 0
   set done1 0
   set done 0

   while {!$done1} {
      # handle first word requested
      if {$nword == $which} {
         set ch [string index $instr $pos]

         if {$ch == "'" || $ch == "\""} {
            incr pos
         }

         set done 1
         break
      }

      set ch [string index $instr $pos]

      switch $ch {
         " " {
            # a space is an unconditional word
            incr nword
            incr pos

            if {$nword == $which} {
               set done 1
            }

            # move position if the next char is a quote
            if {$done && $pos < $len} {
               set ch [string index $instr $pos]

               if {$ch == "'" || $ch == "\""} {
                  incr pos
               }
            }
         }


         "'" -
         "\"" {
            # if quote is to the right of a non-delimiter, add a word
            if {$pos > 0} {
               set prev_pos [expr $pos - 1]
               set prev_ch [string index $instr $prev_pos]

               if {$prev_ch != " " && $prev_ch != "\"" && $prev_ch != "'"} {
                  incr nword

                  if {$nword == $which} {
                     set done 1
                     break
                  }
               }
            }

            set delim $ch
            set found 0
            set done2 0
            incr pos

            # find matching quote
            while {!$done2} {
               set ch [string index $instr $pos]

               if {$delim == $ch} {
                  set next_pos [expr $pos + 1]
                  set ch [string index $instr $next_pos]

                  if {$ch == " "} {
                     set pos [expr $pos + 2]
                  } else {
                     incr pos
                  }
 
                  # add another word as long as the quote is
                  # not the last character
                  if {$pos < $len} {
                     incr nword

                     if {$nword == $which} {
                        set done 1
                        set ch [string index $instr $pos]

                        if {$ch == "'" || $ch == "\""} {
                           incr pos
                        }
                     }
                  }

                  set found 1
               } else {
                  incr pos
               }

               if {$found || $pos > $len} {
                  set done2 1
               }
            }
         }

         default {
            incr pos
         }
      }

      if {$pos > $len || $done} {
         set done1 1
      }
   }

   if {$done} {
      return $pos
   }

   return -1
}

proc command_wordlen {instr which} {
   # Get and return the length of the 'which' command word
   # in the string 'instr'. Returns the word length upon
   # success (which may be zero), -1 otherwise.
   if {$which <= 0 || $which > [command_words $instr]} {
      return -1
   }

   set indx [command_indxword $instr $which]
   set len [string length $instr]

   # set delimiter
   if {$indx == 0} {
      set delim " "
   } else {
      set delim [string index $instr [expr $indx - 1]]
   }

   # loop looking for the next delimiter or end of the string
   set outlen 0

   for {set i $indx} {$i < $len} {incr i} {
      set ch [string index $instr $i]

      if {$ch == $delim} {
         break
      } else {
         incr outlen
      }
   }

   return $outlen
}

proc sub_string {instr sub} {
   # Find the occurance of 'sub' within 'instr'. Retuns a
   # numeric index if found, -1 otherwise.
   return [string first $sub $instr]
}

proc getyn {prompt} {
   # Get a 'y'es or 'n'o answer from the user. Returns 1
   # for 'y' and 0 for 'n'
   set done 0
   set resp ""

   # shut off 'stdout' buffering
   fconfigure stdout -buffering none

   while {!$done} {
      puts -nonewline "$prompt?(y/n)"
      gets stdin resp

      if {[string length $resp] == 0} {
         puts "please respond with 'y' or 'n'"
         continue
      }

      set ch [string index [ucase $resp] 0]

      if {$ch != "Y" && $ch != "N"} {
         puts "please respond with 'y' or 'n'"
         continue
      }

      if {$ch == "Y"} {
         set ret 1
         set done 1
      } else {
         set ret 0
         set done 1
      }
   }

   return $ret
} 

proc command_worddel {instr outstr which} {
   # Delete the 'which' command word of 'instr'.
   # Upon success, outstr' will be loaded with the new string.
   # Returns 1 upon success, 0 otherwise.
   upvar $outstr lk
   set lk ""
   
   if {$instr == "" || $which <= 0} {
      return 0
   }

   set nwords [command_words $instr]
   set nwords_out 0
   set tmpwrd ""
   set tmpout ""

   if {$which > $nwords} {
      return 0
   }


   # loop to copy all words except the one to delete
   for {set i 1} {$i <= $nwords} {incr i} {
      if {$i != $which} {
         if {![command_word $instr tmpwrd $i]} {
            return 0
         }

         # if word contains multiple space delimited words,
         # put the quotes back
         if {[words $tmpwrd] > 1} {
            # decide which quotes to use based on if there
            # are any existing quotes
            if {[string first "'" $tmpwrd] != -1} {
               set quote "\""
            } else {
               set quote "'"
            }

            append tmpout $quote $tmpwrd $quote
         } else {
            append tmpout $tmpwrd
         }

         incr nwords_out

         # concatenate the output string with a delimiter
         # unless we are on the last word
         if {$nwords_out < [expr $nwords - 1]} {
            append tmpout " "
         }

         # special logic to break if we are done before
         # the natural end of the loop, this should occurr
         # only if the last word is being deleted
         if {$nwords_out == [expr $nwords - 1]} {
            break
         }
      }
   }

   set lk $tmpout
   return 1
}

proc worddel {instr outstr which} {
   # Delete the 'which' space delimited word of 'instr'
   # and place the new string into 'outstr' upon success.
   # Returns 1 upon success, 0 otherwise.
   upvar $outstr lk
   set lk ""

   if {![string length $instr]} {
      return 0
   }

   set nwords [words $instr]

   if {$which > $nwords} {
      return 0
   }

   set tmp ""
   set ret [ll_worddel $instr tmp $which " "]
   set lk $tmp
   return $ret
}

proc ll_worddel {instr outstr which delim} {
   # Delete the 'which' word of 'instr' delimted by 'delim'.
   # Upon success, 'outstr', will be loaded with the new
   # string. Returns 1 upon success, 0 otherwise.
   upvar $outstr lk
   set lk ""

   if {![string length $instr]} {
      return 0
   }

   set nwords [ll_words $instr $delim]

   if {$which > $nwords} {
      return 0
   }

   set pos [ll_indxword $instr $which $delim]

   if {$nwords == $which} {
      # delbytes uses zero len to indicate the rest of the string
      set num_bytes 0

      # if there is more than one word and we are deleting the last,
      # back up one byte to remove the delimiter
      if {$nwords > 1} {
         incr pos -1
      }
   } else {
      set num_bytes [expr [ll_indxword $instr [expr $which + 1] $delim] - $pos]
   }

   set tmp ""

   if {![delbytes $instr tmp $pos $num_bytes]} {
      return 0
   }

   set lk $tmp
   return 1
}

proc ll_wordput {instr outstr wdata which delim} {
   # Place the word 'wdata' into 'instr' as the 'which' word. If the
   # word already exists, it will be replaced, if it does not exist, the
   # string will be extended out to the required word before copying.
   # Each word is delimited by 'delim'. The new string will be returned in
   # 'outstr' upon success. Returns 1 upon success, 0 otherwise.
   upvar $outstr lk
   set lk ""
   
   if {$which <= 0} {
      return 0
   }

   set len [string length $instr]
   set nwords [ll_words $instr $delim]
   set new_str $instr

   if {$which > $nwords} {
      set tmp ""
      
      if {![parse_extend $new_str tmp $which $delim]} {
         return 0
      }

      set new_str $tmp
      set len [string length $new_str]
      set nwords $which
   }
   
   if {!$len} {
      set existing_field_len 0
   } else {
      set existing_field_len [ll_wordlen $new_str $which $delim]
   }

   set new_field_len [string length $wdata]

   # if existing and new words are length zero, nothing more to do
   if {!$new_field_len & !$existing_field_len} {
      set lk $new_str
      return 1
   }

   set tmp ""
   set process 1

   # figure out and copy before and after data
   # handle first word in string
   if {$which == 1} {
      set before ""

      if {$nwords == $which} {
         set after ""
      } else {
         # load 'after' from start of second word to end (no delimiters)
         set indx [ll_indxword $new_str 2 $delim]
         set after [string range $new_str $indx end]
      }

      set process 0
   }

   # handle last word in string
   if {$process && $which == $nwords} {
      # load 'before' from start to delimiter just before 'which'
      set indx [ll_indxword $new_str $which $delim]
      set before [string range $new_str 0 [expr $indx - 1]]
      set after ""
      set process 0
   }

   # handle 'which' in the middle of the string
   if {$process} {
      # load 'before' from the start to delimiter just before 'which'
      set indx [ll_indxword $new_str $which $delim]
      set before [string range $new_str 0 [expr $indx - 1]]

      # load 'after' from the start of word after 'which' to the end
      # (no delimiters)
      set indx [ll_indxword $new_str [expr $which + 1] $delim]
      set after [string range $new_str $indx end]
   }

   # build final string from three parts
   set tmp ""

   # part one, 'before' string
   if {[string length $before]} {
      set tmp $before
   }

   # part two, new word data
   append tmp $wdata

   # part three, 'after' string
   if {[string length $after]} {
      append tmp $delim $after
   }

   set lk $tmp
   return 1
}

proc num {numstr} {
   # Evaluate a string to determine whether it is a valid number.
   # Numbers are the digits 0-9. A minus sign is allowed in the
   # first character. Returns 1 if the string is a valid number,
   # 0 otherwise.
   set len [string length $numstr]

   if {!$len} {
      return 0
   }

   for {set i 0} {$i < $len} {incr i} {
      set ch [string index $numstr $i]


      switch -glob -- $ch {
         [0-9] {
            continue
         }

         - {
            if {$i > 0} {
               return 0
            }
         }

         default {
            return 0
         }
      }
   }

   return 1
}

proc ucase {instr} {
   # Copy a string to its uppercase version. Returns the
   # uppercase version.
   return [string toupper $instr]
}

proc parse_extend {instr outstr which delim} {
   # Extend string data out to 'which' 'delim' delimited word.
   # You may not extend using the space delimiter because of the
   # nature of the space and 'trim'. Returns 1 upon success, 0
   # otherwise. Upon success, 'outstr' will be loaded with the
   # extended string.
   upvar $outstr lk
   set lk ""
   set nwords [ll_words $instr $delim]

   # if the existing string is empty and we are adding the
   # first word, do not extend
   if {!$nwords && $which == 1} {
      return 1
   }

   if {$which <= 0 || $delim == " "} {
      return 0
   }

   # if word is already present, extend not necessary
   if {$nwords >= $which} {
      set lk $instr
      return 1
   }

   set new_rec $instr
   set pos [string length $new_rec]

   # extend string
   for {set i $nwords} {$i < $which} {incr i} {
      append new_rec $delim
   }

   set lk $new_rec
   return 1
}
   
proc initstring {src} {
   # Copy a string. Not really required in TCL but
   # provided for compatibility with 'C' source code.
   # Returns the copy of 'src'.
   set tmp $src
   return $tmp
}

proc inittstring {src} {
   # Copy and 'trim' a string. Returns the 'trim'ed string.
   # Not really required in TCL but provided for
   # compatibility with 'C' source code. Returns the
   # 'trim'ed string.
   set tmp [trim $src]
   return $tmp
}

proc initqstring {src} {
   # Copy and quote a string. The destination string is
   # only quoted if the source string contains more than one space
   # delimited word. Returns the new string.
   set dest ""
   set len [string length $src]

   if {!$len} {
      return $dest
   }

   if {[words $src] > 1} {
      set dest "'"
      append dest $src "'"
   } else {
      set dest $src
   }

   return $dest
}

proc delbytes {instr outstr pos numbytes} {
   # Delete the 'numbytes' of 'instr' starting from bytes 'pos'
   # and place the result into 'outstr'. Returns 1 upon
   # success with the result string in 'outstr', 0 otherwise.
   # 'numbytes' may be zero which indicates the remainder of
   # the string.
   upvar $outstr lk
   set lk ""
   set instrlen [string length $instr]

   if {!$instrlen || $pos < 0 || $numbytes < 0} {
      return 0
   }

   if {[expr $pos + $numbytes] > $instrlen} {
      return 0
   }

   set tmp ""

   # grab all data before the start position 'pos'
   if {$pos > 0} {
      set tmp [string range $instr 0 [expr $pos - 1]]
   }

   if {$numbytes} {
      set slen $numbytes
   } else {
      set slen [expr $instrlen - $pos]
   }

   # grab all data after the removed section
   for {set i [expr $pos + $slen]} {$i < $instrlen} {incr i} {
      set ch [string index $instr $i]
      append tmp $ch
   }

   set lk $tmp
   return 1
}

proc logic_string_2_flag {lstring flag} {
   # Convert a string to a boolean value.
   # Acceptable values of 'lstring' are:

   #   yes, no, true, false, on, off, 0, 1

   # String comparison is case insensitive.
   # Returns 1 upon success with the flag
   # value loaded into 'flag'. Returns 0
   # otherwise.
   upvar $flag lk
   set lk 0

   if {![string length $lstring]} {
      return 0
   }

   set tmp [trim [ucase $lstring]]

   switch $tmp {
      YES -
      TRUE -
      ON -
      1 {
         set ret 1
         set val 1
      }

      NO -
      FALSE -
      OFF -
      0 {
         set ret 1
         set val 0
      }

      default {
         set ret 0
         set val 0
      }
   }

   set lk $val
   return $ret
}
 
proc flag_2_logic_string {flag str} {
   # Convert a flag (0|1) to a string. 'ON' is used
   # to represent 1 and 'OFF' is used to represent
   # 0. The 'flag' must be zero or one. Returns
   # 1 upon success with the string loaded into
   # 'str', 0 is returned otherwise.
   upvar $str lk
   set lk ""

   if {$flag != 1 && $flag != 0} {
      return 0
   }

   if {$flag} {
      set lk "on"
   } else {
      set lk "off"
   }

   return 1
}

proc pmatch {pattern fname} {
   # Match a (file)name to a pattern. Uses 'tcl' 'string match'
   # command. Returns 1 upon a match, 0 otherwise.
   set pat_len [string length $pattern]
   set fname_len [string length $fname]

   if {!$pat_len || !$fname_len} {
      return 0
   }

   return [string match $pattern $fname]
}

proc lpad {istr padch len} {
   # Pad the string 'istr' on the left with the 'padch'
   # to the desired 'len'gth.
   # Returns the new string
   set padstr ""
   set length [string length $istr]

   # if string is already long enough, exit
   if {$length >= $len} {
      return $istr
   }

   for {set i $length} {$i < $len} {incr i} {
      append padstr $padch
   }

   set outstr "$padstr$istr"
   return $outstr
}

proc rpad {istr padch len} {
   # Pad the string 'istr' on the right with the 'padch'
   # character to the desired 'len'gth.
   # Returns new string.
   set outstr $istr
   set length [string length $istr]

   # if string is already long enough, exit
   if {$length >= $len} {
      return $istr
   }

   for {set i $length} {$i < $len} {incr i} {
      append outstr $padch
   }

   return $outstr
}

proc strip_space {instr} {
   # Strip all spaces from 'instr'. Returns the stripped string.
   set outstr ""
   set len [string length $instr]

   if {!$len} {
      return $outstr
   }

   for {set i 0} {$i < $len} {incr i} {
      set ch [string index $instr $i]

      if {$ch != " "} {
         append outstr $ch
      }
   }

   return $outstr
}
