xmfbox.tcl

genesis 2000 v9.1软件下载

	return
    }
    set subdir [$data(dList) get [$data(dList) curselection]]
    if ![string compare $subdir ""] {
	return
    }

    $data(fList) selection clear 0 end

    case $subdir {
	. {
	    set newDir $data(selectPath)
	}
	.. {
	    set newDir [file dirname $data(selectPath)]
	}
	default {
	    set newDir [file join $data(selectPath) $subdir]
	}
    }

    set data(selectPath) $newDir
    tkMotifFDialog_Update $w

    if [string compare $subdir ..] {
	$data(dList) selection set 0
	$data(dList) activate 0
    } else {
	$data(dList) selection set 1
	$data(dList) activate 1
    }
}

proc tkMotifFDialog_BrowseFList {w} {
    upvar #0 $w data

    focus $data(fList)
    if ![string compare [$data(fList) curselection] ""] {
	return
    }
    set data(selectFile) [$data(fList) get [$data(fList) curselection]]
    if ![string compare $data(selectFile) ""] {
	return
    }

    $data(dList) selection clear 0 end

    $data(fEnt) delete 0 end
    $data(fEnt) insert 0 [file join $data(selectPath) $data(filter)]
    $data(fEnt) xview end
 
    $data(sEnt) delete 0 end
    $data(sEnt) insert 0 [file join $data(selectPath) $data(selectFile)]
    $data(sEnt) xview end
}

proc tkMotifFDialog_ActivateFList {w} {
    upvar #0 $w data

    if ![string compare [$data(fList) curselection] ""] {
	return
    }
    set data(selectFile) [$data(fList) get [$data(fList) curselection]]
    if ![string compare $data(selectFile) ""] {
	return
    } else {
	tkMotifFDialog_ActivateSEnt $w
    }
}

proc tkMotifFDialog_ActivateFEnt {w} {
    upvar #0 $w data

    set list [tkMotifFDialog_InterpFilter $w]
    set data(selectPath) [lindex $list 0]
    set data(filter)    [lindex $list 1]

    tkMotifFDialog_Update $w
}

proc tkMotifFDialog_InterpFilter {w} {
    upvar #0 $w data

    set text [string trim [$data(fEnt) get]]
    # Perform tilde substitution
    #
    if ![string compare [string index $text 0] ~] {
	set list [file split $text]
	set tilde [lindex $list 0]
	catch {
	    set tilde [glob $tilde]
	}
	set text [eval file join [concat $tilde [lrange $list 1 end]]]
    }

    set resolved [file join [file dirname $text] [file tail $text]]

    if [file isdirectory $resolved] {
	set dir $resolved
	set fil $data(filter)
    } else {
	set dir [file dirname $resolved]
	set fil [file tail    $resolved]
    }

    return [list $dir $fil]
}


proc tkMotifFDialog_ActivateSEnt {w} {
    global tkPriv
    upvar #0 $w data

    set selectFilePath [string trim [$data(sEnt) get]]
    set selectFile     [file tail    $selectFilePath]
    set selectPath     [file dirname $selectFilePath]


    if {![string compare $selectFilePath ""]} {
	tkMotifFDialog_FilterCmd $w
	return
    }

    if {[file isdirectory $selectFilePath]} {
	set data(selectPath) [glob $selectFilePath]
	set data(selectFile) ""
	tkMotifFDialog_Update $w
	return
    }

    if [string compare [file pathtype $selectFilePath] "absolute"] {
	tk_messageBox -icon warning -type ok \
	    -message "\"$selectFilePath\" must be an absolute pathname"
	return
    }

    if ![file exists $selectPath] {
	tk_messageBox -icon warning -type ok \
	    -message "Directory \"$selectPath\" does not exist."
	return
    }

    if ![file exists $selectFilePath] {
	if ![string compare $data(type) open] {
	    tk_messageBox -icon warning -type ok \
		-message "File \"$selectFilePath\" does not exist."
	    return
	}
    } else {
	if ![string compare $data(type) save] {
	    set message [format %s%s \
		"File \"$selectFilePath\" already exists.\n\n" \
		"Replace existing file?"]
	    set answer [tk_messageBox -icon warning -type yesno \
		-message $message]
	    if ![string compare $answer "no"] {
		return
	    }
	}
    }

    set tkPriv(selectFilePath) $selectFilePath
    set tkPriv(selectFile)     $selectFile
    set tkPriv(selectPath)     $selectPath
}


proc tkMotifFDialog_OkCmd {w} {
    upvar #0 $w data

    tkMotifFDialog_ActivateSEnt $w
}

proc tkMotifFDialog_FilterCmd {w} {
    upvar #0 $w data

    tkMotifFDialog_ActivateFEnt $w
}

proc tkMotifFDialog_CancelCmd {w} {
    global tkPriv

    set tkPriv(selectFilePath) ""
    set tkPriv(selectFile)     ""
    set tkPriv(selectPath)     ""
}

# tkMotifFDialog_Update
#
#	Load the files and synchronize the "filter" and "selection" fields
#	boxes.
#
# popup:
#	If this is true, then update the selection field according to the
#	"-selection" flag
#
proc tkMotifFDialog_Update {w} {
    upvar #0 $w data

    $data(fEnt) delete 0 end
    $data(fEnt) insert 0 [file join $data(selectPath) $data(filter)]
    $data(sEnt) delete 0 end
    $data(sEnt) insert 0 [file join $data(selectPath) $data(selectFile)]
 
    tkMotifFDialog_LoadFiles $w
}

proc tkMotifFDialog_LoadFiles {w} {
    upvar #0 $w data

    $data(dList) delete 0 end
    $data(fList) delete 0 end

    set appPWD [pwd]
    if [catch {
	cd $data(selectPath)
    }] {
	cd $appPWD

	$data(dList) insert end ".."
	return
    }

    # Make the dir list
    #
    foreach f [lsort -command tclSortNoCase [glob -nocomplain .* *]] {
	if [file isdir $f] {
	    $data(dList) insert end $f
	}
    }
    # Make the file list
    #
    if ![string compare $data(filter) *] {
	set files [lsort -command tclSortNoCase [glob -nocomplain .* *]]
    } else {
	set files [lsort -command tclSortNoCase \
	    [glob -nocomplain $data(filter)]]
    }

    set top 0
    foreach f $files {
	if ![file isdir $f] {
	    $data(fList) insert end $f
	    if [string match .* $f] {
		incr top
	    }
	}
    }

    # The user probably doesn't want to see the . files. We adjust the view
    # so that the listbox displays all the non-dot files
    $data(fList) yview $top

    cd $appPWD
}

proc tkListBoxKeyAccel_Set {w} {
    bind Listbox <Any-KeyPress> ""
    bind $w <Destroy> "tkListBoxKeyAccel_Unset $w"
    bind $w <Any-KeyPress> "tkListBoxKeyAccel_Key $w %A"
}

proc tkListBoxKeyAccel_Unset {w} {
    global tkPriv

    catch {after cancel $tkPriv(lbAccel,$w,afterId)}
    catch {unset tkPriv(lbAccel,$w)}
    catch {unset tkPriv(lbAccel,$w,afterId)}
}

proc tkListBoxKeyAccel_Key {w key} {
    global tkPriv

    append tkPriv(lbAccel,$w) $key
    tkListBoxKeyAccel_Goto $w $tkPriv(lbAccel,$w)
    catch {
	after cancel $tkPriv(lbAccel,$w,afterId)
    }
    set tkPriv(lbAccel,$w,afterId) [after 500 tkListBoxKeyAccel_Reset $w]
}

proc tkListBoxKeyAccel_Goto {w string} {
    global tkPriv

    set string [string tolower $string]
    set end [$w index end]
    set theIndex -1

    for {set i 0} {$i < $end} {incr i} {
	set item [string tolower [$w get $i]]
	if {[string compare $string $item] >= 0} {
	    set theIndex $i
	}
	if {[string compare $string $item] <= 0} {
	    set theIndex $i
	    break
	}
    }

    if {$theIndex >= 0} {
	$w selection clear 0 end
	$w selection set $theIndex $theIndex
	$w activate $theIndex
	$w see $theIndex
    }
}

proc tkListBoxKeyAccel_Reset {w} {
    global tkPriv

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