# Procedures specific to tcl
# 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

# Added proc 'catch_exec'. Jul/2006, Rick Smereka
 
proc const {name value} {
   # Implement simple constants in TCL.
   # Taken from wiki.tcl.tk/constants
   uplevel 1 [list set $name $value]
   uplevel 1 [list trace var $name w "set $name [list $value];#"]
}

proc sleep {n} {
   # Sleep for 'n' seconds. Taken from: www.tcl.tk/man/tcl8.4/tclcmd/after.htm
   after [expr {int($n * 1000)}]
}

proc int_remove_lz {inval} {
   # Remove all leading zeros from an integer value. This #^#& language
   # flags an error if it encounters an integer with leading zeros
   # thinking that it is an improper octal number. Returns the integer
   # value stripped of all the leading zeros.
   if {$inval == ""} {
      return 0
   }

   # scan and get the index position of the last zero, check for no
   # leading zeros
   if {[string index $inval 0] != "0"} {
      return $inval
   }

   set len [string length $inval]
   set pos 0

   for {set i 0} {$i < $len} {incr i} {
      if {[string index $inval $i] != "0"} {
         set pos [expr $i - 1]
         break
      }
   }

   # remove leading zeros
   set result [string replace $inval 0 $pos]
   return $result
}

proc catch_exec {com result} {
   # Execute a child process and trap all available information upon exit.
   # Returns exit code with zero(0) being successful. Message data is
   # contained in 'result' as a tcl 'list. Adapted from 
   # http://wiki.tcl.tk/1039.
   upvar $result uresult
   set nwords [words $com]
   set command exec

   # since this #@*! language won't execute a subprocess in a straight
   # string, I have to split the string into words and then re-build
   # as a tcl 'list'
   for {set i 1} {$i <= $nwords} {incr i} {
      word $com wrd $i
      lappend command $wrd
   }
      
   # command is executed using 'eval' as per wiki
   set status [catch {eval $command} rout]   

   if {$status == 0} {
      # command was successful and wrote nothing to stderr
      set res $rout
   } elseif {[string equal $::errorCode NONE]} {
      # command exited with normal (but non zero) status and wrote
      # something to stderr
      set res $rout
   } else {
      switch -exact -- [lindex $::errorCode 0] {
         CHILDKILLED {
            # child with 'pid' died on sig 'sigName'
            foreach {- pid sigName msg} $::errorCode break
            set res "child($pid) died on sig($sigName)"
            lappend res $msg
         }

         CHILDSTATUS {
            # child 'pid' exited with non-zero status
            foreach {- pid code} $::errorCode break
            set res "child($pid) exit($code)"
         }
   
         CHILDSUSP {
            # child 'pid' suspended on sig 'sigName'
            foreach {- pid sigName msg} $::errorCode break
            set res "child($pid) suspended on sig($sigName)"
            lappend res $msg
         }

         POSIX {
            # kernel call failed
            foreach {- errName msg} $::errorCode break
            set res "kernel call failed rc($errName)"
            lappend res $msg
         }
      }
   }

   # convert 'res' to proper list
   set uresult [split $res "\n"]
   return $status
}

