### Copyright (C) 1995-1997 Jesper K. Pedersen
### 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, write to the Free Software
### Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.


#
# function to chose between two element. just like "? : " operator
#
proc pick {truth true false} {
  if {[uplevel \#0 expr \{$truth\}]} {
    return $true
  } else {
    return $false
  }
}
  

proc _tospace {str} {
  return [join [split $str "_"] " "]
}

proc spaceto_ {str} {
  return [join [split $str " "] "_"]
}

proc checkInt {widget} {
  if {![regexp {^-?[0-9]*$} [$widget get]]} {
    $widget delete [expr [$widget index insert] -1] [$widget index insert]
    error "This entry is only for integers"
  }
}

proc checkFloat {widget} {
  if {![regexp {^-?[0-9]*\.?[0-9]*$} [$widget get]]} {
    $widget delete [expr [$widget index insert] -1] [$widget index insert]
    error "This entry is only for floating points"
  }
}

#
# append to a list, if it the element doesn't exist.
#
proc uniqAppend {list value} {
  upvar $list l
  if {![info exists l]} {
    uplevel set \"$list\" [list \"$value\"]
  } elseif {[lsearch -exact $l $value] == -1} {
    uplevel lappend \"$list\" \"$value\"
  }
}

proc lremove {list value} {
  set index [lsearch -exact $list $value]
  if {$index == -1} {
    return "__error__"
  }
  return [lreplace $list $index $index]
}

proc min {x y} {
  if {$x < $y} {return $x}
  return $y
}
proc max {x y} {
  if {$x > $y} {return $x}
  return $y
}

############################################################
# This function checks wheter element can be a index in
# a widget with noOfElm number of elements.
############################################################
proc isIndex {element noOfElm} {
  if {![regexp {^[0-9]+$} $element]} {
    return 0
  }
  if {[expr $element+1] > $noOfElm} {
    return 0
  }
  return 1
}

proc tkTrue {value} {
  if {$value == "1" || $value == "true" || $value == "yes" || $value == "on"} {
    return 1
  } else {
    return 0
  }
}



######################################################################
# This function takes as argument a number in the range 0-15,
# and return the number as a hexadecimal digit (0..F)
######################################################################
proc hexDigit {i} {
  switch $i {
    10 {return A}
    11 {return B}
    12 {return C}
    13 {return D}
    14 {return E}
    15 {return F}
    default {return $i}
  }
}
######################################################################
# This function takes as argument a number in the range 0-255,
# and return the number as a hexadecimal digit.
######################################################################
proc itoh {i} {
  if {$i>255} {
    error "number to large"
  }
  set j [expr $i/16]
  set k [expr $i%16]
  return "[hexDigit $j][hexDigit $k]"
}
######################################################################
# This function converts a hexadecimal number to an integer.
######################################################################
proc htoi {number} {
  set total 0
  for {set i 0} {$i < [string length $number]} {incr i} {
    set total [expr $total*16 + [htoiDigit [string index $number $i]]]
  }
  return $total
}
######################################################################
# This function converts a hexadecimal diget to a decimal diget
######################################################################
proc htoiDigit {i} {
  switch $i {
    A {return 10}
    B {return 11}
    C {return 12}
    D {return 13}
    E {return 14}
    F {return 15}
    default {return $i}
  }
}
######################################################################
### This function upcase each first letter in a string
######################################################################
proc capitalize {str} {
  set list [split $str]
  set res {}
  foreach elm $list {
    lappend res [string toupper [string index $elm 0]][string tolower [string range $elm 1 end]]
  }
  return [join $res]
}
proc pushGrab {type w} {
  global __grabs
  if {![info exists __grabs]} {
    set __grabs ""
  }
  if {[grab current] != {}} {
    lappend __grabs "[grab current] [grab status [grab current]]"
  }
  if {$type == "global"} {
    grabSet -global $w
  } else {
    grabSet $w
  }
  ### Due to a bug in Tk I need to take the focus, to avoid another window
  ### still to be active.
  focus $w
}

proc popGrab {} {
  global __grabs
  grab release [grab current]
  if {[llength $__grabs] > 0} {
    set grabelm [lindex $__grabs end]
    set __grabs [lrange $__grabs 0 [expr [llength $__grabs] -2]]
    if {[lindex $grabelm 1] == "global"} {
      grabSet -global [lindex $grabelm 0]
    } else {
      grabSet [lindex $grabelm 0]
    }
    ### Due to a bug in Tk I need to take the focus, to avoid another window
    ### still to be active.
    focus [lindex $grabelm 0]
  }
}

proc saveDefinition {func} {
  global __definition
  if {![info exists __definition(body_$func)]} {
    set __definition(body_$func) {}
    set __definition(args_$func) {}
  }
  set __definition(body_$func) \
      [concat [list [info body $func]] $__definition(body_$func)]
  set __definition(args_$func) \
      [concat  [list [info args $func]] $__definition(args_$func)]
}
proc loadDefinition {func} {
  global __definition
  proc $func [lindex $__definition(args_$func) end] \
      [lindex $__definition(body_$func) 0]
  set __definition(args_$func) [lrange $__definition(args_$func) 1 end]
  set __definition(body_$func) [lrange $__definition(body_$func) 1 end]
}

proc space {number} {
  return [string range "                                                                               " 1 $number]
}

proc upCase {text} {
  return [string toupper $text]
}

proc timeWindow {width title text} {
  global __time __timeWindowPath tk_version
  # show only the time window if we are running TK
  # we run tclsh, when bytecompiling!
  if {[info exists tk_version]}  {
    set __time 0
    set w [makeTempWindow $title]
    pack [label $w.text -justify left -text $text]
    for {set i 0} {$i < $width} {incr i} {
      pack [label $w.$i -relief groove -bd 1] -side left -fill x -expand 1
    }
    update
    pushGrab local $w
    wm resizable $w 0 0
    set __timeWindowPath $w
  } else {
    puts $text
  }
}

proc incrTimeWindow {} {
  global __timeWindowPath __time tk_version
  if {[info exists tk_version]} {
    $__timeWindowPath.$__time configure -background black
    incr __time
    update
  } else {
    puts -nonewline "."
    flush stdout
  }
}

proc destroyTimeWindow {} {
  global __timeWindowPath tk_version
  if {[info exists tk_version]} {
    popGrab
    destroy $__timeWindowPath
  } else {
    puts ""
  }
}
rename error error_handler

proc error {args} {
  error_handler [join $args]
}
proc warning {args} {
  puts "Warning:\n[join $args]\n"
}


######################################################################
### This function return a list of widget, which is direct decent
### to the given widget (seen as variables) Ie. a child, which is
### located inside a frame or a window, is also included.
######################################################################
proc variableChildren {func parent} {
  global __children __widgetArgs

  set children {}
  
  foreach child $__children(${func}__$parent) {
    set type $__widgetArgs(${func}__${child}__type)
    if {$type == "window" || $type == "frame"} {
      set children [concat $children [variableChildren $func $child]]
    } else {
      lappend children $child
    }
  }
  return $children
}

proc noOfVariableChildren {func name} {
  global __children __widgetArgs
  set type $__widgetArgs(${func}__${name}__type)
  if {$type == "frame" || $type == "window"} {
    return [llength [variableChildren $func $name]]
  } else {
    return 1
  }
}

######################################################################
### This function is used in for the Command widgets
### it is used to give a user freindly interface.
### The arguments to the function is two list. The first is the option
### with no arguments, and the next is the options with arguments.
### The function set the variable "options" in the scope of the caller
######################################################################
proc parseOpt {noargs withargs list} {
  upvar options options

  set switch ""
  set nextHaveToBeValue 0
  set value ""

  foreach elm $noargs {
    set options($elm) 0
  }
  foreach elm $withargs {
    set options($elm) ""
  }
  foreach elm $list {
    if {[string index $elm 0] == "-" && [string index $elm 1] != "-"} {
      ### The next element is a switch
      if {$nextHaveToBeValue} {
        error "No Value given for option \"$switch\""
      }
      ### save the last switch
      if {$value != ""} {
        if {$value == "{}" || $value == {""}} {
          set value ""
        }
        set options($switch) $value
        set value ""
      }
      set switch [string range $elm 1 end]
      if {[lsearch -exact $noargs $switch] != -1} {
        set options($switch) 1
      } elseif {[lsearch -exact $withargs $switch] != -1} {
        set nextHaveToBeValue 1
      } else {
        error "unknown option: \"$switch\""
      }
    } else {
      set nextHaveToBeValue 0
      if {$switch == ""} {
        error "no switch for value \"$elm\""
      }
      if {[string index $elm 0] == "-"} {
        set elm [string range $elm 1 end]
      }
      append value $elm
    }
  }
  if {$value != ""} {
    set options($switch) $value
  }
}

######################################################################
### These functions sets the busy text in the main window.
######################################################################
proc startBusy {text} {
  global __busy
  .busy configure -text $text
  update
}

proc endBusy {} {
  global __busy
  set length [llength $__busy]
  if {$length  <= 1} {
    set text ""
  } else {
    set text [lindex $__busy [expr $length -2]]
  }
  set __busy [lrange $__busy 0 [expr $length -2]]
  .busy configure -text $text
}

######################################################################
### This function format the text, which is given as argument to
### the Help, Desc, ShortDesc etc. functions
######################################################################
proc makeText {arg} {
  regsub -all "\n " [join $arg] "\n" arg
  return $arg
}

proc createDir {dir} {
  global __system env
  set list [split $dir /]
  if {[lindex $list 0] == ""} {
    set list [lrange $list 1 end]
    set dir /
  } else {
    set dir ""
  }

  ### convert ~
  if {[lindex $list 0] == "~"} {
    set list [concat [list $env(HOME)] [lrange $list 1 end]]
  }
  foreach elm $list {
    set dir $dir$elm
    if {![file exists $dir]} {
      eval "exec $__system(mkdir) $dir"
    }
    set dir $dir/
  }
}  

######################################################################
### This function is used to take grab, so that TDG doesn't crash
### when it cannot take a crash
######################################################################
proc grabSet args {
  if {[llength $args] == 2} {
    set flag [lindex $args 0]
    set win [lindex $args 1]
  } else {
    set win [lindex $args 0]
    set flag ""
  }

  set count 0
  while {$count < 20} {
    set res [catch "grab $flag $win"]
    if {$res} {
      if {$count == 0} {
        puts -nonewline "WAITING FOR GRAB."
        flush stdout
      } else {
        puts -nonewline "."
        flush stdout
      }
      after 500
    } else {
      break
    }
    incr count
  }
  if {$res} {
    puts "Continuing without grab!"
  } elseif {$count > 1} {
    puts "Got it!"
  }
}

proc myGlob args {
  if {[lindex $args 0] == "-nocomplain"} {
    set path [lindex $args 1]
    set res [glob -nocomplain $path]
    if {$res == ""} {
      return ""
    }
  } else {
    set path [lindex $args 0]
    set res [glob $path]
  }

  if {[string index $path [expr [string length $path] -1]] == "/" &&
    [string index $res [expr [string length $res] -1]] != "/"} {
    append res /
  }
  return $res
}