tkgate-data 1.8.7-4 / usr / share / tkgate-1.8.7 / scripts / misc.tcl

#   Copyright (C) 1987-2007 by Jeffery P. Hansen
#
#   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.
#
# Last edit by hansen on Sat Jan 27 16:27:46 2007
#
# offsetgeometry win dx dy
#
# Return a geomtry string with the specified offset from the specified window.
#
#

proc ul {n} {
  global lang

  if { $lang == "en" } {
      return $n
  } else {
      return -1
  }
}

proc offsetgeometry { win dx dy } {
  set g [wm geometry $win]
  set x [string range $g [expr [string first "+" $g] + 1] end]
  set p [string first "+" $x]
  set y [string range $x [expr $p + 1] end]
  set x [string range $x 0 [expr $p - 1]]
  return +[expr $x + $dx ]+[expr $y + $dy]
}

proc okcancel {w ok can} {
  frame $w -relief raised -bd 2
  button $w.ok -text [m b.ok] -command $ok
  button $w.cancel -text [m b.cancel] -command $can
  pack $w.ok -side left -padx 5 -pady 5
  pack $w.cancel -side right -padx 5 -pady 5
}

#
# Insert an item i into listbox lb using comparison procedure cf.  The item
# is inserted at in sorted order, and it is assumed the listbox is
# already sorted.  A binary search is used for the insert.
#
proc lbSortInsert {lb iitem cf} {

  set b 0
  set e [$lb size]

  while { $b < $e } {
    set m [expr ($b + $e)/2 ]
    set litem [$lb get $m]
    set r [eval "$cf {$iitem} {$litem}"]
    if {$r < 0 } {
      set e [expr $m]
    } elseif {$r > 0 } {
      set b [expr $m + 1]
    } else {
      return
    }
  }
  $lb insert $b $iitem
}

#
# Same as lbSortInsert, except that an item it replaced if it already
# exists (decoration of the item may change).
#
proc lbSortRInsert {lb iitem cf} {
  set b 0
  set e [$lb size]

  while { $b < $e } {
    set m [expr ($b + $e)/2 ]
    $lb get 0
    set litem [$lb get $m]
    set r [eval "$cf {$iitem} {$litem}"]
    if {$r < 0 } {
      set e [expr $m]
    } elseif {$r > 0 } {
      set b [expr $m + 1]
    } else {
      $lb delete $m
      $lb insert $m $iitem
      return
    }
  }
  $lb insert $b $iitem
}

#
# Delete item iitem from listbox lb using comparison function cf.  It is
# assumed that the items in the listbox are sorted, as a binary search
# is used to find the item. 
#
proc lbSortDelete {lb iitem cf} {
  set b 0
  set e [$lb size]

  while { $b < $e } {
    set m [expr ($b + $e)/2 ]
    set litem [$lb get $m]
    set r [eval "$cf $iitem $litem"]
    if {$r < 0 } {
      set e [expr $m]
    } elseif {$r > 0} {
      set b [expr $m + 1]
    } else {
      $lb delete $m
      return
    }
  }
}

#
# Copy listbox contents of s to d.
#
proc lbCopy {s d} {
  set n [$s size]
  for {set i 0} { $i < $n } { incr i } {
    $d insert end [$s get $i]
  }
}

#
# Delete any occurances of chars from dset in str
#
proc tr-d {str dset} {
  set R ""
  set L [string length $str]

  for {set i 0} {$i < $L} {incr i} {
    set c [string index $str $i]
    if {[string first $c $dset] < 0} {
      append R $c
    }
  }

  return $R
}

#
# Replace the extension of name with ext.  "ext" should
# include the '.' character if it is desired.
#
proc replaceExtension {name ext} {
  set p [string last "." $name ]
  if { $p >= 0 } {
    set name [string range $name 0 [expr $p - 1]]
  }
  return "$name$ext"
}

#
# remove i from list l
#
proc ldelete {l i} {
  set p [lsearch $l $i]
  if { $p >= 0 } {
    return [lreplace $l $p $p]
  } {
    return $l
  }
}

bind HexEntry <Delete> { continue }
bind HexEntry <BackSpace> { continue }
bind HexEntry <Control-KeyPress> { continue }
bind HexEntry <KeyPress> {
  set c [string tolower %A]

  if { $c == "" } { continue }

  if { [string first $c "0123456789abcdef"] < 0 } { break }


  if {[%W selection present]} {
    %W delete sel.first sel.last
  } else {
    %W delete insert
  }
  set L [string length [%W get]]

  if { $L >= 8 } { break }

  #
  # Temporarily disable the "HexEntry" event handler and send a regular
  # event to insert the character.
  #
  bindtags %W [lrange [bindtags %W] 1 end]
  event generate %W <KeyPress> -keysym $c
  bindtags %W [concat [list HexEntry] [bindtags %W]]

  break
}

proc copyVar {vd vs} {
  global $vd $vs
  eval "set $vd $$vs"
}

proc checkCopyVar {vd vs minv maxv} {
  global $vd $vs


  eval "set n $$vs"

  if { [scan $n "%d" n] != 1 } { set n $minv }

  if { $n < $minv } { set n $minv }
  if { $n > $maxv } { set n $maxv }

  eval "set $vd $n"
}

#
# Given a list of the form {{t1 v1} {t2 v2} ... }
# return the value from the pair having the tag 'tag'.
#
proc assoc {tag l} {
  set value ""
  catch {
    foreach p $l {
      if {[lindex $p 0] == $tag } { 
	set value [lindex $p 1]
	break
      }
    }
  }
  return $value
}

##############################################################################
#
# Parse an argument list
#
proc parseargs {argv nameset} {
  while { [llength $argv] > 0 } {

    set sw [lindex $argv 0]

    if { [lsearch -exact $nameset $sw] < 0 } {
      error "bad option \"$sw\" must be one of: $nameset"
      return
    }

    set vname [string range $sw 1 end]
    set val [lindex $argv 1]
    set argv [lrange $argv 2 end]

    upvar $vname local_$vname
    set  local_$vname $val
  }
}

proc tabbox_select {w i} {
  global tabbox_details tabbox_active

  if { $tabbox_active($w) == $i } return

  set tabbox_active($w) $i

  set details $tabbox_details($w)
  set bd [assoc bd $details]
  set tabheight [assoc tabheight $details]
  set tabwidth [assoc tabwidth $details]
  set activecolor [assoc activecolor $details]
  set inactivecolor [assoc inactivecolor $details]
  set command [assoc command $details]
  set tabs [assoc tabs $details]

  $w coords hider [expr $bd + $i*$tabwidth] $tabheight

  catch {
    for { set j 0 } { 1 } { incr j } {
      if { $j == $i } {
	$w.b$j configure -background $activecolor
	$w.b$j.l configure -background $activecolor
      } else {
	$w.b$j configure -background $inactivecolor
	$w.b$j.l configure -background $inactivecolor
      }
    }
  }

  if { $command != "" } {
    catch { destroy $w.f.f }
    $command $w.f.f [lindex $tabs $i]
    catch { pack $w.f.f -anchor center -expand 1 -fill both}
  }
}

proc tabbox {w args} {
  global tabbox_details tabbox_active

  set activecolor "#d9d9d9"
  set inactivecolor [. cget -background]
  set width 300
  set height 300
  set tabheight 25
  set tabwidth 50
  set tabs {}
  set tablabels {}
  set bd 2
  set relief raised
  set command ""
  set startpage ""

  set tabbox_active($w) ""

  parseargs $args {-width -height -tabheight -tabwidth -bd -relief -tabs -activecolor -inactivecolor -command -tablabels -startpage}

  if { [llength $tablabels] == 0 } {
    set tablabels $tabs
  }
  if { [llength $tablabels] != [llength $tabs] } {
    error "-tablabels and -tabs must be of equal length"
  }

  set tabbox_details($w) {}
  lappend tabbox_details($w) [list width $width]
  lappend tabbox_details($w) [list height $height]
  lappend tabbox_details($w) [list tabwidth $tabwidth]
  lappend tabbox_details($w) [list tabheight $tabheight]
  lappend tabbox_details($w) [list activecolor $activecolor]
  lappend tabbox_details($w) [list inactivecolor $inactivecolor]
  lappend tabbox_details($w) [list bd $bd]
  lappend tabbox_details($w) [list command $command]
  lappend tabbox_details($w) [list tabs $tabs]
  lappend tabbox_details($w) [list tablabels $tablabels]

  canvas $w -width $width -height $height -highlightthickness 0

  set x 0
  set y $tabheight

  set i 0
  foreach t $tablabels {
    frame $w.b$i -height $tabheight -width $tabwidth -bd $bd -relief $relief
    frame $w.b$i.v -height [expr $tabheight - 2*$bd] -width 0
    frame $w.b$i.h -height 0 -width [expr $tabwidth -2*$bd-1]
    label $w.b$i.l -text $t
    pack $w.b$i.v -side left
    pack $w.b$i.h
    pack $w.b$i.l

    $w create window $x [expr $y + $bd] -anchor sw -window $w.b$i -tags tab$i
    set x [expr $x + $tabwidth]

    bind $w.b$i <Button-1> "tabbox_select $w $i"
    bind $w.b$i.l <Button-1> "tabbox_select $w $i"

    incr i
  }

  set start_idx [lsearch -exact $tabs $startpage]
  if { $start_idx < 0 } {
    set start_idx 0
  }

  frame $w.f -width $width  -height [expr $height - $tabheight] -bd $bd -relief $relief
  frame $w.f.v -height [expr $height - $tabheight - 2*$bd] -width 0
  frame $w.f.h -height 0 -width [expr $width -2*$bd-1]
  pack $w.f.v -side left
  pack $w.f.h

  $w create window 0 $tabheight -anchor nw -window $w.f

  frame $w.hider -width [expr $tabwidth - 2*$bd] -height [expr 2*$bd+1]
  $w create window 0 0 -anchor w -window $w.hider -tags hider


  tabbox_select $w $start_idx

  set tabheight 30
}

proc viewFile {label file} {
  if {[catch { set f [open $file]}]} {
    errmsg "Can not open file $file"
    return
  }


  set w .vfwin
  set i 0
  while { [catch { toplevel $w$i}] } {
    incr i
  }
  set w $w$i

  wm title $w $label

  frame $w.main
  text $w.main.text -yscrollcommand "$w.main.vb set" -xscrollcommand "$w.main.hb set"
  scrollbar $w.main.vb -command "$w.main.text yview"
  scrollbar $w.main.hb -orient horizontal -command "$w.main.text xview"

  grid rowconfigure $w.main 0 -weight 1
  grid columnconfigure $w.main 0 -weight 1
  grid $w.main.text -row 0 -column 0 -sticky nsew
  grid $w.main.vb -row 0 -column 1 -sticky ns
  grid $w.main.hb -row 1 -column 0 -sticky ew

  button $w.dismiss -text Dismiss -command "destroy $w"

  pack $w.main -fill both -expand 1
  pack $w.dismiss -fill x

  catch {
    $w.main.text insert end [read $f]
    close $f
  }
  $w.main.text configure -state disabled
}

#
# Note on bindtags usage - In tcl/tk bindings for multi key sequences
# are executed regardless of overlap with other bindings.  For example,
# if "Ctl-X Ctl-S" and "Ctl-S g" are commands, then the key sequence
# "Ctl-X Ctl-S g" will cause commands to be executed.  To avoid this
# confusing behavior, a special nop command key are used.  After the
# end of a two-key sequence, a special key not used in any commands is
# forced into the event stream to break up any unexpected commands. 
#
# Another problem is when "g" is a command, but "Ctl-X g" is not a
# command.  Since "Ctl-X" is a command prefix, if the next character
# does not form a valid mult-charcter command, it should be ignored.
# We implement this using bindtags on windows.  Single charcter commands
# are bound to the tag "keywin", and multi-character commands are bound
# to the tag "key2win".  These tags are attached to all windows where
# which process commands.  When a prefix character is entered, the
# "keywin" tag is temporarily removed from all windows, and restored after
# a second character has been entered. 
#

set bind_win_list [list]

proc endPrefix {} {
  global bind_win_list
  foreach w $bind_win_list {
    catch {
      set bt [bindtags $w]
      if { [lsearch $bt keywin] < 0 } {
	bindtags $w [concat keywin $bt]
      }
    }
  }
  event generate . <Meta-KeyPress-U>
}

proc startPrefix {} {
  global bind_win_list
  foreach w $bind_win_list {
    catch { bindtags $w [ldelete [bindtags $w] keywin] }
  }
}

proc tkg_setBindings {w} {
  global bind_win_list

  if { [lsearch $bind_win_list $w] < 0 } {
    append bind_win_list $w
    bindtags $w [concat keywin key2win [bindtags $w]]
  }
}

proc newPrefix {key} {
  set old [string trim [bind keywin $key]]

  if { $old == "" } {
    bind keywin $key 		{ startPrefix }
    bind key2win $key<KeyPress>	{ if { [string compare %A ""] != 0 } { endPrefix } }
  } elseif { $old != "startPrefix" } {
    puts "tkgate: Prefix $key has already been defined as a key command."
  }
}

#
# Actually the same as "newBinding" but without an override test
#
proc keyBinding {key cmd args} {
  set p [string first ">" $key]
  set l [string length $key]
  incr p

  if { $p != $l } {
    set pkey [string range $key 0 [expr $p -1]]

    newPrefix $pkey

    set k "key2win"
    set cmd "$cmd ; endPrefix"
  } else {
    set k "keywin"
  }

  if { $args == "-new" } {
    if { [bind $k $key] != "" } {
      puts "tkgate: Redefinition of binding $key"
    }
  }

  if { [catch { eval "bind $k $key { $cmd }"}] } {
    puts "tkgate: Illegal key binding $key"
  }
}

proc newBinding {key cmd} {
  keyBinding $key $cmd -new
}

namespace eval Sequence {
  proc sequence_buttons {w n1 s1 n2 s2} {
    $w.bb.back configure -text $n1 -state $s1
    $w.bb.next configure -text $n2 -state $s2
  }

  ##############################################################################
  #
  # Generic function for setting the current page in a sequence box
  #
  proc sequence_setpage {w page} {
    global sequence_current
    global sequence_command
    global sequence_finish
    global sequence_size

    set sequence_current($w) $page

    if { $sequence_current($w) == "finish" } {
      destroy $w
      frame $w
      pack $w
      frame $w.h -width [lindex $sequence_size($w) 0] -height 0
      frame $w.v -width 0 -height [lindex $sequence_size($w) 1]
      pack $w.h
      pack $w.v -side left

      $sequence_finish($w) $w
      return
    }

    focus $w.bb.next

    catch { destroy $w.f.p }


    frame $w.f.p
    $sequence_command($w) $w $w.f.p $sequence_current($w)
    pack $w.f.p -fill both -expand 1
  }

  ##############################################################################
  #
  # Advance to the next page in a sequence
  #
  proc sequence_next {w} {
    global sequence_current
    global sequence_pages
    global sequence_command

    $sequence_command($w) $w $w.f.p $sequence_current($w)+
  }

  ##############################################################################
  #
  # Go back a page in a sequence
  #
  proc sequence_back {w} {
    global sequence_current
    global sequence_pages
    global sequence_command

    $sequence_command($w) $w $w.f.p $sequence_current($w)-
  }

  proc sequence_cancel {w} {
    destroy .
  }

  proc sequence {w args} {
    global sequence_current
    global sequence_command
    global sequence_finish
    global sequence_size
    global sequence_cancelName

    set width 400
    set height 300
    set bd 0
    set relief flat
    set command ""
    set finishcommand ""
    set cancelname Cancel

    parseargs $args {-width -height -bd -relief -command -finishcommand -cancelname}

    set sequence_current($w) first
    set sequence_command($w) $command
    set sequence_finish($w) $finishcommand
    set sequence_size($w) [list $width $height]
    set sequence_cancelName($w) $cancelname

    frame $w -bd $bd -relief $relief

    frame $w.h -width $width -height 0
    frame $w.v -height $height -width 0
    frame $w.x -height 4 -width [expr $width - 20] -bd 2 -relief sunken 
    pack $w.h -side top
    pack $w.v -side left

    frame $w.f
    frame $w.bb
    pack $w.f -fill both -expand 1
    pack $w.x -pady 5
    pack $w.bb -fill x

    button $w.bb.back   -text "<Back" -command "sequence_back $w"
    button $w.bb.next   -text "Next>" -command "sequence_next $w"
    button $w.bb.cancel -text $sequence_cancelName($w) -command "sequence_cancel $w"
    pack $w.bb.cancel $w.bb.next $w.bb.back -side right -anchor e -padx 5 -pady 5

    bind $w.bb.back <Return> "sequence_back $w"
    bind $w.bb.next <Return> "sequence_next $w"
    bind $w.bb.cancel <Return> "sequence_cancel $w"

    sequence_setpage $w start+
  }
}

namespace eval Tabbox {
  variable details
  variable active

  proc reselect {w} {
    variable active
    _select $w $active($w)
  }

  proc select {w i} {
    variable active

    if { $active($w) == $i } return
    _select $w $i
  }

  proc _select {w i} {
    variable details
    variable active

    set active($w) $i

    set det $details($w)
    set bd [assoc bd $det]
    set tabheight [assoc tabheight $det]
    set tabwidth [assoc tabwidth $det]
    set activecolor [assoc activecolor $det]
    set inactivecolor [assoc inactivecolor $det]
    set command [assoc command $det]
    set tabs [assoc tabs $det]

    $w coords hider [expr $bd + $i*$tabwidth] $tabheight

    catch {
      for { set j 0 } { 1 } { incr j } {
	if { $j == $i } {
	  $w.b$j configure -background $activecolor
	  $w.b$j.l configure -background $activecolor
	} else {
	  $w.b$j configure -background $inactivecolor
	  $w.b$j.l configure -background $inactivecolor
	}
      }
    }

    if { $command != "" } {
      catch { destroy $w.f.f }
      $command $w.f.f [lindex $tabs $i]
      catch { pack $w.f.f -anchor center -expand 1 -fill both}
    }
  }
  
  proc new {w args} {
    variable details
    variable active

    set activecolor "#d9d9d9"
    set inactivecolor [. cget -background]
    set width 300
    set height 300
    set tabheight 25
    set tabwidth 50
    set tabs {}
    set bd 2
    set relief raised
    set command ""

    set active($w) ""

    parseargs $args {-width -height -tabheight -tabwidth -bd -relief -tabs -activecolor -inactivecolor -command}

    set details($w) {}
    lappend details($w) [list width $width]
    lappend details($w) [list height $height]
    lappend details($w) [list tabwidth $tabwidth]
    lappend details($w) [list tabheight $tabheight]
    lappend details($w) [list activecolor $activecolor]
    lappend details($w) [list inactivecolor $inactivecolor]
    lappend details($w) [list bd $bd]
    lappend details($w) [list command $command]
    lappend details($w) [list tabs $tabs]

    canvas $w -width $width -height $height -highlightthickness 0

    set x 0
    set y $tabheight

    set i 0
    foreach t $tabs {
      frame $w.b$i -height $tabheight -width $tabwidth -bd $bd -relief $relief
      frame $w.b$i.v -height [expr $tabheight - 2*$bd] -width 0
      frame $w.b$i.h -height 0 -width [expr $tabwidth -2*$bd-1]
      label $w.b$i.l -text $t
      pack $w.b$i.v -side left
      pack $w.b$i.h
      pack $w.b$i.l

      $w create window $x [expr $y + $bd] -anchor sw -window $w.b$i -tags tab$i
      set x [expr $x + $tabwidth]

      bind $w.b$i <Button-1> "Tabbox::select $w $i"
      bind $w.b$i.l <Button-1> "Tabbox::select $w $i"

      incr i
    }


    frame $w.f -width $width  -height [expr $height - $tabheight] -bd $bd -relief $relief
    frame $w.f.v -height [expr $height - $tabheight - 2*$bd] -width 0
    frame $w.f.h -height 0 -width [expr $width -2*$bd-1]
    pack $w.f.v -side left
    pack $w.f.h

    $w create window 0 $tabheight -anchor nw -window $w.f

    frame $w.hider -width [expr $tabwidth - 2*$bd] -height [expr 2*$bd+1]
    $w create window 0 0 -anchor w -window $w.hider -tags hider

    Tabbox::select $w 0

    set tabheight 30
  }
}

proc min args {
  if {[llength $args] == 0 } { return 0 }

  set m [lindex $args 0]
  foreach v $args {
    if {$v < $m} { set m $v }
  }
  return $m
}

proc max args {
  if {[llength $args] == 0 } { return 0 }

  set m [lindex $args 0]
  foreach v $args {
    if {$v > $m} { set m $v }
  }
  return $m
}

#
# Create a labeled grooved frame.
#
proc labelframe {w lab args} {
  frame $w -bd 2 -relief groove
  eval "$w configure $args"
#    frame $w.labelframe_pad -height 10
#    pack $w.labelframe_pad
  label ${w}_label -text $lab
  place ${w}_label -in $w -x 10 -y -10
}

#
# Create an image object from a .gif file name.
#
proc gifI {f} {
  global gifTable

  #
  # Try to get the image from the image table first.  If we don't find it,
  # create the image and save it in the table.
  #
  catch {
    return $gifTable($f)
  }

  set gifTable($f) [image create photo -file $f]
  return $gifTable($f)
}

proc gifIb {f} {
  global bd
  return [gifI "$bd/$f"]
}

#
# Post the splash window.
#
proc start_splash {} {
  global sd bd splash_start_time tkg_doSplash

  if { ! $tkg_doSplash} { return } 

  if {[catch { set splash_start_time [clock clicks -milliseconds] }]} {
    set splash_start_time "rawdelay"
  }

  if {[catch { wm state . withdrawn }]} {
    wm iconify .
  }

  update

  toplevel .splash -class Splash
  label .splash.logo -image [gifI "$bd/biggatelogo.gif"]
  pack .splash.logo
  wm overrideredirect .splash 1
  wm transient .splash ""

  set iwidth [image width [.splash.logo cget -image]]
  set iheight [image height [.splash.logo cget -image]]

  set x [expr ([winfo screenwidth .] - $iwidth)/2 ]
  set y [expr ([winfo screenheight .] - $iheight)/2 ]
  wm geometry .splash +${x}+${y}
  update
}

#
# Remove the splash window
#
proc end_splash {} {
  global bd splash_start_time tkg_doSplash tkg_splashWait

  if { ! $tkg_doSplash} { return } 

  if { $splash_start_time == "rawdelay" } {
    set time_to_go 1000
  } else {
    set time_to_go [expr $tkg_splashWait - ([clock clicks -milliseconds] - $splash_start_time)]
  }

  if { $time_to_go < 1 } { set time_to_go 1 }

  after $time_to_go {
    destroy .splash
    wm deiconify .
    update
  }
}

#
# Create an image radiobutton with accompaning text and explaination.
#
proc imageRadioButton {w args} {
  set onimage ""
  set offimage ""
  set variable ""
  set label ""
  set description ""
  set value ""
  set wraplength 200

  parseargs $args {-onimage -offimage -variable -value -label -description -wraplength}

  frame $w
  radiobutton $w.button -image $offimage -selectimage $onimage -variable $variable -value $value -indicatoron 0
  label $w.header -text $label -font dialogBigExpFont
  label $w.details -text $description -justify left -wraplength $wraplength -font dialogExpFont
  frame $w.pad -width 4

  pack $w.button  -side left -anchor nw
  pack $w.pad -side left
  pack $w.header  -anchor nw
  pack $w.details -anchor nw -pady 2
}

proc yesno {msg} {
  return [tk_messageBox -default no -type yesno -icon warning -message $msg]
}