# use_util.tcl
#   - some utilities for USE
#
# Copyright (c) 1994 R"udiger Franke
# All Rights Reserved.
# 
# Redistribution and use in any form, with or without modification, 
# is permitted, provided that the following conditions are met:
# 1. Redistributions of source code must retain the above copyright
#    notice, this list of conditions and the following disclaimer.
# 2. Redistributions in other form must reproduce the above copyright
#    notice, this list of conditions and the following disclaimer in the
#    documentation and/or other materials provided with the distribution.
# 3. All advertising materials mentioning features or use of this software
#    must display the following acknowledgement:
#       This product includes software developed by R"udiger Franke.
# 4. The name of the author may not be used to endorse or promote products
#    derived from this software without specific prior written permission.
# 
# THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR
# IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
# OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
# IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT,
# INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
# NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
# DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
# THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
# (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
# THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

#
# use_asend --  asynchron sending
#   - command returns if target application has received the sended script
#   --> transmission is enshured by use_asend
#   --> source needn't to wait for target to complete (and gets no result)
#
proc use_asend { dst args} {
  send $dst after 1 $args
}

#
# use_optionread:
#  - read users application defaults Intrinsics like
#  - return name of last read option file
#
proc use_optionread {{paths {}} {name {}} {suffix {}}} {
  
  global env

  # initialize paths

  if {$paths == {}} {
    if [info exists env(HOME)] {
      set home $env(HOME)
    } else {
      set home {}
    }
    if [info exists env(XUSERFILESEARCHPATH)] {
      set paths $env(XUSERFILESEARCHPATH)
    } else {
      if [info exists env(XAPPLRESDIR)] {
        set dir $env(XAPPLRESDIR)
        set paths $dir/%L/%N:$dir/%l/%N:$dir/%N:$home/%N
      } else {
        set paths $home/%L/%N:$home/%l/%N:$home/%N
      }
    }
  }

  # determine applications name

  if {$name == {}} {
    set name [lindex [winfo name .] 0]
  }
  if {$name == {}} {
    return {}
  }

  # perform substitutions

  regsub -all %T $paths app-defaults paths
  regsub -all %N $paths $name paths
  regsub -all %S $paths $suffix paths
  regsub -all %. $paths {} paths
  regsub -all //+ $paths / paths

  # read option files

  set read {}
  foreach file [split $paths :] {
    if {[catch {glob $file} ret] == 0 && $ret == $file} {
      if {[catch {option readfile $file} reason] != 0} {
        puts "Error while reading option file $file"
        puts "($reason)"
      } else {
        set read $file
      }
    }
  }

  return $read
}

#
# use_bakfile:
#  - backup files with a tilde at the end
#  - don't backup multiple changes during one session
#  - hold information in global variable use(bakfiles)
#
proc use_bakfile {fname} {
  global use

  if {[info exists use(bakfiles)] && [lsearch $use(bakfiles) $fname] >= 0} {
    return
  }

  lappend use(bakfiles) $fname
  if [file exists $fname] {
    catch {exec mv $fname $fname\~}
  }
}

#
# create a temporary file with unique name
# return file name
# file must be deleted by caller
#
proc use_tmpname {} {

  set i 0
  set uid [exec whoami]
  set ret -1
  while {$ret != 0} {
    incr i
    if {$i > 200} {
      error "too many temporary files use.$uid.XXX.tcl"
    }
    set fname /tmp/use.$uid.$i.tcl
    set ret [catch {set fid [open $fname "RDWR CREAT EXCL"]}]
  }
  close $fid

  return $fname
}

#
# build a file head for a Tcl file from use(trghead)
#
proc use_filehead {fname} {
  global use

  set head [join $use(trghead) "\n# "]
  regsub -all @filename@ $head $fname head

  return "# $head"
}

# handle a simple user dialog in a popup window
# (reference: John K. Ousterhout: An Introduction to Tcl and Tk)
#
proc dialog { w title text bitmap default args} {

    global dialogButton

    # create a top-level wondow and devide it into two parts

    toplevel $w -class Dialog
    wm title $w $title
    wm protocol $w WM_DELETE_WINDOW "set dialogButton -1"

    frame $w.top -relief raised -bd 1
    frame $w.bot -relief raised -bd 1
    pack append $w \
	$w.top {top fill expand} \
	$w.bot {top fill}

    # fill the top part with the bitmap and message

    message $w.top.msg -width 3i -text $text -padx 5m -pady 5m
    pack append $w.top $w.top.msg {right expand}

    if { $bitmap != ""} {
	if { [catch "label $w.top.bitmap -bitmap $bitmap" errmsg] == 0} {
	    pack append $w.top $w.top.bitmap {left padx 5m pady 5m}
	} else {
	    puts stderr "dialog: $errmsg"
	}
    }

    # create a row of buttons at the bottom of the dialog

    set i 0
    foreach but $args {

	if { $i == $default} {
	    frame $w.bot.default \
		-relief sunken -bd 1
	    pack append $w.bot \
		$w.bot.default {left expand padx 5m pady 2m}
	    button $w.bot.default.button$i \
		-text $but -command "set dialogButton $i" -padx 2m
	    pack append $w.bot.default \
		$w.bot.default.button$i {left expand padx 3m pady 3m}

	} else {
	    button $w.bot.button$i \
		-text $but -command "set dialogButton $i" -padx 2m
	    pack append $w.bot \
		$w.bot.button$i {left expand padx 5m pady 5m}
	}
	incr i
    }

    # set up a binding for <Return> if there is a default,
    # make w transient to it's parent
    # set a grab, claim the focus

    if { $default >= 0} {
	bind $w <Return> "$w.bot.default.button$default flash; \
                          set dialogButton $default"
    }

    useMakeTransient $w
    
    # grab doesn't work for not realized windows (Tk 3.2)
    if { [catch "grab $w" errmsg] != 0} {
	puts stderr "dialog: $errmsg"
    }

    set oldFocus [focus]
    focus $w

    # wait for the user to respond

    tkwait variable dialogButton

    focus $oldFocus
    destroy $w
    return $dialogButton
}

#
# show a message in a popup window with just an ok - button
#
proc topmessage { w title text {bitmap info}} {

    # create a top-level window and devide it into two parts

    if [winfo exists $w] {
        destroy $w
    }
    toplevel $w -class Dialog
    wm title $w $title

    frame $w.top -relief raised -bd 1
    frame $w.bot -relief raised -bd 1
    pack append $w \
	$w.top {top fill expand} \
	$w.bot {top fill}

    # fill the top part with the bitmap and message

    message $w.top.msg -width 3i -text $text -padx 5m -pady 5m
    pack append $w.top $w.top.msg {right expand}

    if { $bitmap != ""} {
	if { [catch "label $w.top.bitmap -bitmap $bitmap" errmsg] == 0} {
	    pack append $w.top $w.top.bitmap {left padx 5m pady 5m}
	} else {
	    puts stderr "dialog: $errmsg"
	}
    }

    # create an ok button at the bottom of the dialog

    frame $w.bot.default \
	-relief sunken -bd 1
    pack append $w.bot \
	$w.bot.default {left expand padx 5m pady 2m}
    button $w.bot.default.button0 \
	-text OK -command "destroy $w" -padx 2m
    pack append $w.bot.default \
	$w.bot.default.button0 {left expand padx 3m pady 3m}

    # set up a binding for <Return>
    # make w transient to it's parent

    bind $w <Return> "
        $w.bot.default.button0 flash
        $w.bot.default.button0 invoke
    "
    useMakeTransient $w
}

proc useMakeTransient { w} {

    # request w to be transient to it's parent-toplevel

    set parent [winfo toplevel [winfo parent $w]]
    wm transient $w $parent

    # position w in the middle over it's parent
    # (w's geometry must be calculated first --> update idletasks)

    set geom [winfo geometry $parent]
    regexp {([0-9]+)\x([0-9]+)\+([0-9]+)\+([0-9]+)} $geom \
	dummy width height x y
#    set geom [winfo geometry $w]
#    regexp {([0-9]+)\x([0-9]+)} $geom dummy ww wh
    set ww 200
    set wh 100
    wm geometry $w +[expr $x+($width-$ww)/2]+[expr $y+($height-$wh)/2]
    update
}

proc use_unique {wpath} {

  set i 1
  set unique $wpath
  while {[winfo exists $unique]} {
    incr i
    set unique $wpath$i
  }

  return $unique
}
  
proc use_ontop {w cmd name {title {}} args} {

  if [winfo exists $w] {
    wm deiconify $w
    catch {blt_win raise $w}

  } else {
    toplevel $w -width 200 -height 200
    wm minsize $w 10 10
    if { $title != {}} {
      wm title $w $title
    }

    set slave [eval [concat $cmd $w.$name $args]]
    pack $slave -fill both -expand true

    bind $slave <Destroy> \
      "+after 1 \{if \[winfo exists $w\] \{destroy $w\}\}"
  }

  return $w
}

# return the value of the given tk option for the given widget
# 
proc useWidgetInfo {w option} {
  return [lindex [$w config $option] 4]
}

# exchange foreground and background colors
#
proc useToggleColors {w} {
  $w configure \
     -fg [lindex [$w configure -bg] 4] \
     -bg [lindex [$w configure -fg] 4]
}
