# comdlg.tcl --

#

#	Some functions needed for the common dialog boxes. Probably need to go

#	in a different file.

#

# RCS: @(#) $Id: comdlg.tcl,v 1.9 2003/02/21 13:32:14 dkf Exp $

#

# Copyright (c) 1996 Sun Microsystems, Inc.

#

# See the file "license.terms" for information on usage and redistribution

# of this file, and for a DISCLAIMER OF ALL WARRANTIES.

#

# tclParseConfigSpec --

#

#	Parses a list of "-option value" pairs. If all options and

#	values are legal, the values are stored in

#	$data($option). Otherwise an error message is returned. When

#	an error happens, the data() array may have been partially

#	modified, but all the modified members of the data(0 array are

#	guaranteed to have valid values. This is different than

#	Tk_ConfigureWidget() which does not modify the value of a

#	widget record if any error occurs.

#

# Arguments:

#

# w = widget record to modify. Must be the pathname of a widget.

#

# specs = {

#    {-commandlineswitch resourceName ResourceClass defaultValue verifier}

#    {....}

# }

#

# flags = currently unused.

#

# argList = The list of  "-option value" pairs.

#

proc tclParseConfigSpec {w specs flags argList} {

    upvar #0 $w data

    # 1: Put the specs in associative arrays for faster access

    #

    foreach spec $specs {

	if {[llength $spec] < 4} {

	    error "\"spec\" should contain 5 or 4 elements"

	}

	set cmdsw [lindex $spec 0]

	set cmd($cmdsw) ""

	set rname($cmdsw)   [lindex $spec 1]

	set rclass($cmdsw)  [lindex $spec 2]

	set def($cmdsw)     [lindex $spec 3]

	set verproc($cmdsw) [lindex $spec 4]

    }

    if {[llength $argList] & 1} {

	set cmdsw [lindex $argList end]

	if {![info exists cmd($cmdsw)]} {

	    error "bad option \"$cmdsw\": must be [tclListValidFlags cmd]"

	}

	error "value for \"$cmdsw\" missing"

    }

    # 2: set the default values

    #

    foreach cmdsw [array names cmd] {

	set data($cmdsw) $def($cmdsw)

    }

    # 3: parse the argument list

    #

    foreach {cmdsw value} $argList {

	if {![info exists cmd($cmdsw)]} {

	    error "bad option \"$cmdsw\": must be [tclListValidFlags cmd]"

	}

	set data($cmdsw) $value

    }

    # Done!

}

proc tclListValidFlags {v} {

    upvar $v cmd

    set len [llength [array names cmd]]

    set i 1

    set separator ""

    set errormsg ""

    foreach cmdsw [lsort [array names cmd]] {

	append errormsg "$separator$cmdsw"

	incr i

	if {$i == $len} {

	    set separator ", or "

	} else {

	    set separator ", "

	}

    }

    return $errormsg

}

#----------------------------------------------------------------------

#

#			Focus Group

#

# Focus groups are used to handle the user's focusing actions inside a

# toplevel.

#

# One example of using focus groups is: when the user focuses on an

# entry, the text in the entry is highlighted and the cursor is put to

# the end of the text. When the user changes focus to another widget,

# the text in the previously focused entry is validated.

#

#----------------------------------------------------------------------

# ::tk::FocusGroup_Create --

#

#	Create a focus group. All the widgets in a focus group must be

#	within the same focus toplevel. Each toplevel can have only

#	one focus group, which is identified by the name of the

#	toplevel widget.

#

proc ::tk::FocusGroup_Create {t} {

    variable ::tk::Priv

    if {[string compare [winfo toplevel $t] $t]} {

	error "$t is not a toplevel window"

    }

    if {![info exists Priv(fg,$t)]} {

	set Priv(fg,$t) 1

	set Priv(focus,$t) ""

	bind $t <FocusIn>  [list tk::FocusGroup_In  $t %W %d]

	bind $t <FocusOut> [list tk::FocusGroup_Out $t %W %d]

	bind $t <Destroy>  [list tk::FocusGroup_Destroy $t %W]

    }

}

# ::tk::FocusGroup_BindIn --

#

# Add a widget into the "FocusIn" list of the focus group. The $cmd will be

# called when the widget is focused on by the user.

#

proc ::tk::FocusGroup_BindIn {t w cmd} {

    variable FocusIn

    variable ::tk::Priv

    if {![info exists Priv(fg,$t)]} {

	error "focus group \"$t\" doesn't exist"

    }

    set FocusIn($t,$w) $cmd

}

# ::tk::FocusGroup_BindOut --

#

#	Add a widget into the "FocusOut" list of the focus group. The

#	$cmd will be called when the widget loses the focus (User

#	types Tab or click on another widget).

#

proc ::tk::FocusGroup_BindOut {t w cmd} {

    variable FocusOut

    variable ::tk::Priv

    if {![info exists Priv(fg,$t)]} {

	error "focus group \"$t\" doesn't exist"

    }

    set FocusOut($t,$w) $cmd

}

# ::tk::FocusGroup_Destroy --

#

#	Cleans up when members of the focus group is deleted, or when the

#	toplevel itself gets deleted.

#

proc ::tk::FocusGroup_Destroy {t w} {

    variable FocusIn

    variable FocusOut

    variable ::tk::Priv

    if {[string equal $t $w]} {

	unset Priv(fg,$t)

	unset Priv(focus,$t) 

	foreach name [array names FocusIn $t,*] {

	    unset FocusIn($name)

	}

	foreach name [array names FocusOut $t,*] {

	    unset FocusOut($name)

	}

    } else {

	if {[info exists Priv(focus,$t)] && \

		[string equal $Priv(focus,$t) $w]} {

	    set Priv(focus,$t) ""

	}

	catch {

	    unset FocusIn($t,$w)

	}

	catch {

	    unset FocusOut($t,$w)

	}

    }

}

# ::tk::FocusGroup_In --

#

#	Handles the <FocusIn> event. Calls the FocusIn command for the newly

#	focused widget in the focus group.

#

proc ::tk::FocusGroup_In {t w detail} {

    variable FocusIn

    variable ::tk::Priv

    if {[string compare $detail NotifyNonlinear] && \

	    [string compare $detail NotifyNonlinearVirtual]} {

	# This is caused by mouse moving out&in of the window *or*

	# ordinary keypresses some window managers (ie: CDE [Bug: 2960]).

	return

    }

    if {![info exists FocusIn($t,$w)]} {

	set FocusIn($t,$w) ""

	return

    }

    if {![info exists Priv(focus,$t)]} {

	return

    }

    if {[string equal $Priv(focus,$t) $w]} {

	# This is already in focus

	#

	return

    } else {

	set Priv(focus,$t) $w

	eval $FocusIn($t,$w)

    }

}

# ::tk::FocusGroup_Out --

#

#	Handles the <FocusOut> event. Checks if this is really a lose

#	focus event, not one generated by the mouse moving out of the

#	toplevel window.  Calls the FocusOut command for the widget

#	who loses its focus.

#

proc ::tk::FocusGroup_Out {t w detail} {

    variable FocusOut

    variable ::tk::Priv

    if {[string compare $detail NotifyNonlinear] && \

	    [string compare $detail NotifyNonlinearVirtual]} {

	# This is caused by mouse moving out of the window

	return

    }

    if {![info exists Priv(focus,$t)]} {

	return

    }

    if {![info exists FocusOut($t,$w)]} {

	return

    } else {

	eval $FocusOut($t,$w)

	set Priv(focus,$t) ""

    }

}

# ::tk::FDGetFileTypes --

#

#	Process the string given by the -filetypes option of the file

#	dialogs. Similar to the C function TkGetFileFilters() on the Mac

#	and Windows platform.

#

proc ::tk::FDGetFileTypes {string} {

    foreach t $string {

	if {[llength $t] < 2 || [llength $t] > 3} {

	    error "bad file type \"$t\", should be \"typeName {extension ?extensions ...?} ?{macType ?macTypes ...?}?\""

	}

	eval lappend [list fileTypes([lindex $t 0])] [lindex $t 1]

    }

    set types {}

    foreach t $string {

	set label [lindex $t 0]

	set exts {}

	if {[info exists hasDoneType($label)]} {

	    continue

	}

	set name "$label ("

	set sep ""

	set doAppend 1

	foreach ext $fileTypes($label) {

	    if {[string equal $ext ""]} {

		continue

	    }

	    regsub {^[.]} $ext "*." ext

	    if {![info exists hasGotExt($label,$ext)]} {

		if {$doAppend} {

		    if {[string length $sep] && [string length $name]>40} {

			set doAppend 0

			append name $sep...

		    } else {

			append name $sep$ext

		    }

		}

		lappend exts $ext

		set hasGotExt($label,$ext) 1

	    }

	    set sep ,

	}

	append name ")"

	lappend types [list $name $exts]

	set hasDoneType($label) 1

    }

    return $types

}