tkfbox.tcl

genesis 2000 v9.1软件下载

#
# Arguments:
# w -		The IconList widget.
# amount -	+1 to move down one item, -1 to move back one item.
#
proc tkIconList_UpDown {w amount} {
    upvar #0 $w data

    if ![info exists data(list)] {
	return
    }

    if {$data(curItem) == {}} {
	set rTag [lindex [lindex $data(list) 0] 2]
    } else {
	set oldRTag [lindex [lindex $data(list) $data(curItem)] 2]
	set rTag [lindex [lindex $data(list) [expr $data(curItem)+$amount]] 2]
	if ![string compare $rTag ""] {
	    set rTag $oldRTag
	}
    }

    if [string compare $rTag ""] {
	tkIconList_Select $w $rTag
	tkIconList_See $w $rTag
    }
}

# tkIconList_LeftRight --
#
# Moves the active element left or right by one column
#
# Arguments:
# w -		The IconList widget.
# amount -	+1 to move right one column, -1 to move left one column.
#
proc tkIconList_LeftRight {w amount} {
    upvar #0 $w data

    if ![info exists data(list)] {
	return
    }
    if {$data(curItem) == {}} {
	set rTag [lindex [lindex $data(list) 0] 2]
    } else {
	set oldRTag [lindex [lindex $data(list) $data(curItem)] 2]
	set newItem [expr $data(curItem)+($amount*$data(itemsPerColumn))]
	set rTag [lindex [lindex $data(list) $newItem] 2]
	if ![string compare $rTag ""] {
	    set rTag $oldRTag
	}
    }

    if [string compare $rTag ""] {
	tkIconList_Select $w $rTag
	tkIconList_See $w $rTag
    }
}

#----------------------------------------------------------------------
#		Accelerator key bindings
#----------------------------------------------------------------------

# tkIconList_KeyPress --
#
#	Gets called when user enters an arbitrary key in the listbox.
#
proc tkIconList_KeyPress {w key} {
    global tkPriv

    append tkPriv(ILAccel,$w) $key
    tkIconList_Goto $w $tkPriv(ILAccel,$w)
    catch {
	after cancel $tkPriv(ILAccel,$w,afterId)
    }
    set tkPriv(ILAccel,$w,afterId) [after 500 tkIconList_Reset $w]
}

proc tkIconList_Goto {w text} {
    upvar #0 $w data
    upvar #0 $w:textList textList
    global tkPriv
    
    if ![info exists data(list)] {
	return
    }

    if {[string length $text] == 0} {
	return
    }

    if {$data(curItem) == {} || $data(curItem) == 0} {
	set start  0
    } else {
	set start  $data(curItem)
    }

    set text [string tolower $text]
    set theIndex -1
    set less 0
    set len [string length $text]
    set len0 [expr $len-1]
    set i $start

    # Search forward until we find a filename whose prefix is an exact match
    # with $text
    while 1 {
	set sub [string range $textList($i) 0 $len0]
	if {[string compare $text $sub] == 0} {
	    set theIndex $i
	    break
	}
	incr i
	if {$i == $data(numItems)} {
	    set i 0
	}
	if {$i == $start} {
	    break
	}
    }

    if {$theIndex > -1} {
	set rTag [lindex [lindex $data(list) $theIndex] 2]
	tkIconList_Select $w $rTag 0
	tkIconList_See $w $rTag
    }
}

proc tkIconList_Reset {w} {
    global tkPriv

    catch {unset tkPriv(ILAccel,$w)}
}

#----------------------------------------------------------------------
#
#		      F I L E   D I A L O G
#
#----------------------------------------------------------------------

# tkFDialog --
#
#	Implements the TK file selection dialog. This dialog is used when
#	the tk_strictMotif flag is set to false. This procedure shouldn't
#	be called directly. Call tk_getOpenFile or tk_getSaveFile instead.
#
proc tkFDialog {args} {
    global tkPriv
    set w .__tk_filedialog
    upvar #0 $w data

    # 1st level for UNIX, 2nd for NT (MK trick) 
    if { ![string compare [lindex [info level 0] 0] tk_getOpenFile] ||
         ![string compare [lindex [info level -1] 0] tk_getOpenFile] } {
	set type open
    } else {
	set type save
    }

    tkFDialog_Config $w $type $args

    # (re)create the dialog box if necessary
    #
    if {![winfo exists $w]} {
	tkFDialog_Create $w
    } elseif {[string compare [winfo class $w] TkFDialog]} {
	destroy $w
	tkFDialog_Create $w
    }
    wm transient $w $data(-parent)

    # 5. Initialize the file types menu
    #
    if {$data(-filetypes) != {}} {
	$data(typeMenu) delete 0 end
	foreach type $data(-filetypes) {
	    set title  [lindex $type 0]
	    set filter [lindex $type 1]
	    $data(typeMenu) add command -label $title \
		-command [list tkFDialog_SetFilter $w $type]
	}
	tkFDialog_SetFilter $w [lindex $data(-filetypes) 0]
	$data(typeMenuBtn) config -state normal
	$data(typeMenuLab) config -state normal
    } else {
	set data(filter) "*"
	$data(typeMenuBtn) config -state disabled -takefocus 0
	$data(typeMenuLab) config -state disabled
    }

    tkFDialog_UpdateWhenIdle $w

    # 6. Withdraw the window, then update all the geometry information
    # so we know how big it wants to be, then center the window in the
    # display and de-iconify it.

    wm withdraw $w
    update idletasks
    set x [expr [winfo screenwidth $w]/2 - [winfo reqwidth $w]/2 \
	    - [winfo vrootx [winfo parent $w]]]
    set y [expr [winfo screenheight $w]/2 - [winfo reqheight $w]/2 \
	    - [winfo vrooty [winfo parent $w]]]
    wm geom $w [winfo reqwidth $w]x[winfo reqheight $w]+$x+$y
    wm deiconify $w
    wm title $w $data(-title)

    # 7. Set a grab and claim the focus too.

    set oldFocus [focus]
    set oldGrab [grab current $w]
    if {$oldGrab != ""} {
	set grabStatus [grab status $oldGrab]
    }
    grab $w
    focus $data(ent)
    $data(ent) delete 0 end
    $data(ent) insert 0 $data(selectFile)
    $data(ent) select from 0
    $data(ent) select to   end
    $data(ent) icursor end

    # 8. Wait for the user to respond, then restore the focus and
    # return the index of the selected button.  Restore the focus
    # before deleting the window, since otherwise the window manager
    # may take the focus away so we can't redirect it.  Finally,
    # restore any grab that was in effect.

    tkwait variable tkPriv(selectFilePath)
    catch {focus $oldFocus}
    grab release $w
    wm withdraw $w
    if {$oldGrab != ""} {
	if {$grabStatus == "global"} {
	    grab -global $oldGrab
	} else {
	    grab $oldGrab
	}
    }
    return $tkPriv(selectFilePath)
}

# tkFDialog_Config --
#
#	Configures the TK filedialog according to the argument list
#
proc tkFDialog_Config {w type argList} {
    upvar #0 $w data

    set data(type) $type

    # 1: the configuration specs
    #
    set specs {
	{-defaultextension "" "" ""}
	{-filetypes "" "" ""}
	{-initialdir "" "" ""}
	{-initialfile "" "" ""}
	{-parent "" "" "."}
	{-title "" "" ""}
    }

    # 2: default values depending on the type of the dialog
    #
    if ![info exists data(selectPath)] {
	# first time the dialog has been popped up
	set data(selectPath) [pwd]
	set data(selectFile) ""
    }

    # 3: parse the arguments
    #
    tclParseConfigSpec $w $specs "" $argList

    if ![string compare $data(-title) ""] {
	if ![string compare $type "open"] {
	    set data(-title) "Open"
	} else {
	    set data(-title) "Save As"
	}
    }

    # 4: set the default directory and selection according to the -initial
    #    settings
    #
    if [string compare $data(-initialdir) ""] {
	if [file isdirectory $data(-initialdir)] {
	    set data(selectPath) [glob $data(-initialdir)]
	} else {
	    error "\"$data(-initialdir)\" is not a valid directory"
	}
    }
    set data(selectFile) $data(-initialfile)

    # 5. Parse the -filetypes option
    #
    set data(-filetypes) [tkFDGetFileTypes $data(-filetypes)]

    if ![winfo exists $data(-parent)] {
	error "bad window path name \"$data(-parent)\""
    }
}

proc tkFDialog_Create {w} {
    upvar #0 $w data
    global tk_library

    toplevel $w -class TkFDialog

    # f1: the frame with the directory option menu
    #
    set f1 [frame $w.f1]
    label $f1.lab -text "Directory:" -under 0
    set data(dirMenuBtn) $f1.menu
    set data(dirMenu) [tk_optionMenu $f1.menu [format %s(selectPath) $w] ""]
    set data(upBtn) [button $f1.up]
    if ![info exists tkPriv(updirImage)] {
	set tkPriv(updirImage) [image create bitmap -data {
#define updir_width 28
#define updir_height 16
static char updir_bits[] = {
   0x00, 0x00, 0x00, 0x00, 0x80, 0x1f, 0x00, 0x00, 0x40, 0x20, 0x00, 0x00,
   0x20, 0x40, 0x00, 0x00, 0xf0, 0xff, 0xff, 0x01, 0x10, 0x00, 0x00, 0x01,
   0x10, 0x02, 0x00, 0x01, 0x10, 0x07, 0x00, 0x01, 0x90, 0x0f, 0x00, 0x01,
   0x10, 0x02, 0x00, 0x01, 0x10, 0x02, 0x00, 0x01, 0x10, 0x02, 0x00, 0x01,
   0x10, 0xfe, 0x07, 0x01, 0x10, 0x00, 0x00, 0x01, 0x10, 0x00, 0x00, 0x01,
   0xf0, 0xff, 0xff, 0x01};}]
    }
    $data(upBtn) config -image $tkPriv(updirImage)

    $f1.menu config -takefocus 1 -highlightthickness 2
 
    pack $data(upBtn) -side right -padx 4 -fill both
    pack $f1.lab -side left -padx 4 -fill both
    pack $f1.menu -expand yes -fill both -padx 4

    # data(icons): the IconList that list the files and directories.
    #
    set data(icons) [tkIconList $w.icons \
	-browsecmd "tkFDialog_ListBrowse $w" \
	-command   "tkFDialog_ListInvoke $w"]

    # f2: the frame with the OK button and the "file name" field
    #
    set f2 [frame $w.f2 -bd 0]
    label $f2.lab -text "File name:" -anchor e -width 14 -under 5 -pady 0
    set data(ent) [entry $f2.ent]

    # The font to use for the icons. The default Canvas font on Unix
    # is just deviant.
    global $w.icons
    set $w.icons(font) [$data(ent) cget -font]

    # f3: the frame with the cancel button and the file types field
    #
    set f3 [frame $w.f3 -bd 0]

    # The "File of types:" label needs to be grayed-out when
    # -filetypes are not specified. The label widget does not support
    # grayed-out text on monochrome displays. Therefore, we have to
    # use a button widget to emulate a label widget (by setting its
    # bindtags)

    set data(typeMenuLab) [button $f3.lab -text "Files of type:" \
	-anchor e -width 14 -under 9 \
	-bd [$f2.lab cget -bd] \
	-highlightthickness [$f2.lab cget -highlightthickness] \
	-relief [$f2.lab cget -relief] \
	-padx [$f2.lab cget -padx] \
	-pady [$f2.lab cget -pady]]
    bindtags $data(typeMenuLab) [list $data(typeMenuLab) Label \
	    [winfo toplevel $data(typeMenuLab)] all]

    set data(typeMenuBtn) [menubutton $f3.menu -indicatoron 1 -menu $f3.menu.m]
    set data(typeMenu) [menu $data(typeMenuBtn).m -tearoff 0]
    $data(typeMenuBtn) config -takefocus 1 -highlightthickness 2 \
	-relief raised -bd 2 -anchor w

    # the okBtn is created after the typeMenu so that the keyboard traversal
    # is in the right order
    set data(okBtn)     [button $f2.ok     -text OK     -under 0 -width 6 \
	-default active -pady 3]
    set data(cancelBtn) [button $f3.cancel -text Cancel -under 0 -width 6\
	-default normal -pady 3]

    # pack the widgets in f2 and f3
    #
    pack $data(okBtn) -side right -padx 4 -anchor e
    pack $f2.lab -side left -padx 4
    pack $f2.ent -expand yes -fill x -padx 2 -pady 0
    
    pack $data(cancelBtn) -side right -padx 4 -anchor w
    pack $data(typeMenuLab) -side left -padx 4
    pack $data(typeMenuBtn) -expand yes -fill x -side right

    # Pack all the frames together. We are done with widget construction.
    #
    pack $f1 -side top -fill x -pady 4
    pack $f3 -side bottom -fill x
    pack $f2 -side bottom -fill x
    pack $data(icons) -expand yes -fill both -padx 4 -pady 1

    # Set up the event handlers
    #
    bind $data(ent) <Return>  "tkFDialog_ActivateEnt $w"
    
    $data(upBtn)     config -command "tkFDialog_UpDirCmd $w"
    $data(okBtn)     config -command "tkFDialog_OkCmd $w"
    $data(cancelBtn) config -command "tkFDialog_CancelCmd $w"

    trace variable data(selectPath) w "tkFDialog_SetPath $w"

    bind $w <Alt-d> "focus $data(dirMenuBtn)"
    bind $w <Alt-t> [format {
	if {"[%s cget -state]" == "normal"} {
	    focus %s
	}
    } $data(typeMenuBtn) $data(typeMenuBtn)]
    bind $w <Alt-n> "focus $data(ent)"
    bind $w <KeyPress-Escape> "tkButtonInvoke $data(cancelBtn)"
    bind $w <Alt-c> "tkButtonInvoke $data(cancelBtn)"
    bind $w <Alt-o> "tkFDialog_InvokeBtn $w Open"
    bind $w <Alt-s> "tkFDialog_InvokeBtn $w Save"

    wm protocol $w WM_DELETE_WINDOW "tkFDialog_CancelCmd $w"

    # Build the focus group for all the entries
    #
    tkFocusGroup_Create $w
    tkFocusGroup_BindIn $w  $data(ent) "tkFDialog_EntFocusIn $w"
    tkFocusGroup_BindOut $w $data(ent) "tkFDialog_EntFocusOut $w"
}

# tkFDialog_UpdateWhenIdle --
#
#	Creates an idle event handler which updates the dialog in idle
#	time. This is important because loading the directory may take a long
#	time and we don't want to load the same directory for multiple times
#	due to multiple concurrent events.
#
proc tkFDialog_UpdateWhenIdle {w} {
    upvar #0 $w data

    if [info exists data(updateId)] {
	return
    } else {
	set data(updateId) [after idle tkFDialog_Update $w]
    }
}

# tkFDialog_Update --
#
#	Loads the files and directories into the IconList widget. Also
#	sets up the directory option menu for quick access to parent
#	directories.
#
proc tkFDialog_Update {w} {
    upvar #0 $w data
    global tk_library tkPriv

    # This proc may be called within an idle handler. Make sure that the
    # window has not been destroyed before this proc is called
    if {![winfo exists $w] || [string compare [winfo class $w] TkFDialog]} {
	return
    } else {
	catch {unset data(updateId)}
    }

    set TRANSPARENT_GIF_COLOR [$w cget -bg]
    if ![info exists tkPriv(folderImage)] {
	set tkPriv(folderImage) [image create photo -data {
R0lGODlhEAAMAKEAAAD//wAAAPD/gAAAACH5BAEAAAAALAAAAAAQAAwAAAIghINhyycvVFsB
QtmS3rjaH1Hg141WaT5ouprt2HHcUgAAOw==}]
	set tkPriv(fileImage)   [image create photo -data {
R0lGODlhDAAMAKEAALLA3AAAAP//8wAAACH5BAEAAAAALAAAAAAMAAwAAAIgRI4Ha+IfWHsO
rSASvJTGhnhcV3EJlo3kh53ltF5nAhQAOw==}]
    }
    set folder $tkPriv(folderImage)
    set file   $tkPriv(fileImage)

    set appPWD [pwd]
    if [catch {
	cd $data(selectPath)
    }] {
	# We cannot change directory to $data(selectPath). $data(selectPath)