* gdbtk.tcl (FSBox): New proc, File Selection Box code from exmh.
(not_implemented_yet): New proc. (build_framework): Add various file commands to file menu.
This commit is contained in:
Stan Shebs
parent
d5f4140317
commit
e12533e3e9
2 changed files with 711 additions and 3 deletions
|
|
@ -1,3 +1,11 @@
|
|||
start-sanitize-gdbtk
|
||||
Fri Dec 30 15:49:00 1994 Stan Shebs <shebs@andros.cygnus.com>
|
||||
|
||||
* gdbtk.tcl (FSBox): New proc, File Selection Box code from exmh.
|
||||
(not_implemented_yet): New proc.
|
||||
(build_framework): Add various file commands to file menu.
|
||||
end-sanitize-gdbtk
|
||||
|
||||
Thu Dec 29 22:40:00 1994 Jeff Law (law@snake.cs.utah.edu)
|
||||
|
||||
* Allow up to 10 whitespace separated arguments to user defined
|
||||
|
|
|
|||
706
gdb/gdbtk.tcl
706
gdb/gdbtk.tcl
|
|
@ -678,7 +678,7 @@ proc asm_window_button_1 {win x y xrel yrel} {
|
|||
#
|
||||
# Local procedure:
|
||||
#
|
||||
# do_nothing - Does absoultely nothing.
|
||||
# do_nothing - Does absolutely nothing.
|
||||
#
|
||||
# Description:
|
||||
#
|
||||
|
|
@ -692,6 +692,21 @@ proc do_nothing {} {}
|
|||
#
|
||||
# Local procedure:
|
||||
#
|
||||
# not_implemented_yet - warn that a feature is unavailable
|
||||
#
|
||||
# Description:
|
||||
#
|
||||
# This procedure warns that something doesn't actually work yet.
|
||||
#
|
||||
|
||||
proc not_implemented_yet {message} {
|
||||
tk_dialog .unimpl "gdb : unimpl" "$message: not implemented yet" \
|
||||
{} 1 "OK"
|
||||
}
|
||||
|
||||
##
|
||||
# Local procedure:
|
||||
#
|
||||
# create_expr_win - Creat expression display window
|
||||
#
|
||||
# Description:
|
||||
|
|
@ -723,7 +738,7 @@ proc create_expr_win {} {
|
|||
#
|
||||
# Description:
|
||||
#
|
||||
# Display EXPRESSION and it's value in the expression display window.
|
||||
# Display EXPRESSION and its value in the expression display window.
|
||||
#
|
||||
|
||||
proc display_expression {expression} {
|
||||
|
|
@ -1557,12 +1572,43 @@ proc build_framework {win {title GDBtk} {label {}}} {
|
|||
-menu ${win}.menubar.file.menu -underline 0
|
||||
|
||||
menu ${win}.menubar.file.menu
|
||||
${win}.menubar.file.menu add command -label File... \
|
||||
-command {
|
||||
set filename [FSBox "File" "a.out"]
|
||||
gdb_cmd "file $filename"
|
||||
update_ptr
|
||||
}
|
||||
${win}.menubar.file.menu add command -label Target... \
|
||||
-command { gdb_cmd not_implemented_yet "target" }
|
||||
${win}.menubar.file.menu add command -label Edit \
|
||||
-command {exec $editor +[expr ($screen_top + $screen_bot)/2] $cfile &}
|
||||
${win}.menubar.file.menu add separator
|
||||
${win}.menubar.file.menu add command -label "Exec File..." \
|
||||
-command {
|
||||
set filename [FSBox "Exec File" "a.out"]
|
||||
gdb_cmd "exec-file $filename"
|
||||
update_ptr
|
||||
}
|
||||
${win}.menubar.file.menu add command -label "Symbol File..." \
|
||||
-command {
|
||||
set filename [FSBox "Symbol File" "a.out"]
|
||||
gdb_cmd "symbol-file $filename"
|
||||
update_ptr
|
||||
}
|
||||
${win}.menubar.file.menu add command -label "Add Symbol File..." \
|
||||
-command { not_implemented_yet "menu item, add symbol file" }
|
||||
${win}.menubar.file.menu add command -label "Core File..." \
|
||||
-command {
|
||||
set filename [FSBox "Core File" "core"]
|
||||
gdb_cmd "core-file $filename"
|
||||
update_ptr
|
||||
}
|
||||
${win}.menubar.file.menu add separator
|
||||
${win}.menubar.file.menu add command -label Close \
|
||||
-command "destroy ${win}"
|
||||
${win}.menubar.file.menu add separator
|
||||
${win}.menubar.file.menu add command -label Quit \
|
||||
-command {catch {gdb_cmd quit}}
|
||||
-command { catch { gdb_cmd quit } }
|
||||
|
||||
menubutton ${win}.menubar.view -padx 12 -text View \
|
||||
-menu ${win}.menubar.view.menu -underline 0
|
||||
|
|
@ -1741,6 +1787,660 @@ proc create_command_window {} {
|
|||
}
|
||||
}
|
||||
|
||||
#
|
||||
# fileselect.tcl --
|
||||
# simple file selector.
|
||||
#
|
||||
# Mario Jorge Silva msilva@cs.Berkeley.EDU
|
||||
# University of California Berkeley Ph: +1(510)642-8248
|
||||
# Computer Science Division, 571 Evans Hall Fax: +1(510)642-5775
|
||||
# Berkeley CA 94720
|
||||
#
|
||||
#
|
||||
# Copyright 1993 Regents of the University of California
|
||||
# Permission to use, copy, modify, and distribute this
|
||||
# software and its documentation for any purpose and without
|
||||
# fee is hereby granted, provided that this copyright
|
||||
# notice appears in all copies. The University of California
|
||||
# makes no representations about the suitability of this
|
||||
# software for any purpose. It is provided "as is" without
|
||||
# express or implied warranty.
|
||||
#
|
||||
|
||||
|
||||
# names starting with "fileselect" are reserved by this module
|
||||
# no other names used.
|
||||
# Hack - FSBox is defined instead of fileselect for backwards compatibility
|
||||
|
||||
|
||||
# this is the proc that creates the file selector box
|
||||
# purpose - comment string
|
||||
# defaultName - initial value for name
|
||||
# cmd - command to eval upon OK
|
||||
# errorHandler - command to eval upon Cancel
|
||||
# If neither cmd or errorHandler are specified, the return value
|
||||
# of the FSBox procedure is the selected file name.
|
||||
|
||||
proc FSBox {{purpose "Select file:"} {defaultName ""} {cmd ""} {errorHandler
|
||||
""}} {
|
||||
global fileselect
|
||||
set w .fileSelect
|
||||
if [Exwin_Toplevel $w "Select File" FileSelect] {
|
||||
# path independent names for the widgets
|
||||
|
||||
set fileselect(list) $w.file.sframe.list
|
||||
set fileselect(scroll) $w.file.sframe.scroll
|
||||
set fileselect(direntry) $w.file.f1.direntry
|
||||
set fileselect(entry) $w.file.f2.entry
|
||||
set fileselect(ok) $w.but.ok
|
||||
set fileselect(cancel) $w.but.cancel
|
||||
set fileselect(msg) $w.label
|
||||
|
||||
set fileselect(result) "" ;# value to return if no callback procedures
|
||||
|
||||
# widgets
|
||||
Widget_Label $w label {top fillx pady 10 padx 20} -anchor w -width 24
|
||||
Widget_Frame $w file Dialog {left expand fill} -bd 10
|
||||
|
||||
Widget_Frame $w.file f1 Exmh {top fillx}
|
||||
Widget_Label $w.file.f1 label {left} -text "Dir"
|
||||
Widget_Entry $w.file.f1 direntry {right fillx expand} -width 30
|
||||
|
||||
Widget_Frame $w.file sframe
|
||||
|
||||
scrollbar $w.file.sframe.yscroll -relief sunken \
|
||||
-command [list $w.file.sframe.list yview]
|
||||
listbox $w.file.sframe.list -relief sunken \
|
||||
-yscroll [list $w.file.sframe.yscroll set] -setgrid 1
|
||||
pack append $w.file.sframe \
|
||||
$w.file.sframe.yscroll {right filly} \
|
||||
$w.file.sframe.list {left expand fill}
|
||||
|
||||
Widget_Frame $w.file f2 Exmh {top fillx}
|
||||
Widget_Label $w.file.f2 label {left} -text Name
|
||||
Widget_Entry $w.file.f2 entry {right fillx expand}
|
||||
|
||||
# buttons
|
||||
$w.but.quit configure -text Cancel \
|
||||
-command [list fileselect.cancel.cmd $w]
|
||||
|
||||
Widget_AddBut $w.but ok OK \
|
||||
[list fileselect.ok.cmd $w $cmd $errorHandler] {left padx 1}
|
||||
|
||||
Widget_AddBut $w.but list List \
|
||||
[list fileselect.list.cmd $w] {left padx 1}
|
||||
Widget_CheckBut $w.but listall "List all" fileselect(pattern)
|
||||
$w.but.listall configure -onvalue "{*,.*}" -offvalue "*" \
|
||||
-command {fileselect.list.cmd $fileselect(direntry)}
|
||||
$w.but.listall deselect
|
||||
|
||||
# Set up bindings for the browser.
|
||||
foreach ww [list $w $fileselect(entry)] {
|
||||
bind $ww <Return> [list $fileselect(ok) invoke]
|
||||
bind $ww <Control-c> [list $fileselect(cancel) invoke]
|
||||
}
|
||||
bind $fileselect(direntry) <Return> [list fileselect.list.cmd %W]
|
||||
bind $fileselect(direntry) <Tab> [list fileselect.tab.dircmd]
|
||||
bind $fileselect(entry) <Tab> [list fileselect.tab.filecmd]
|
||||
|
||||
tk_listboxSingleSelect $fileselect(list)
|
||||
|
||||
|
||||
bind $fileselect(list) <Button-1> {
|
||||
# puts stderr "button 1 release"
|
||||
%W select from [%W nearest %y]
|
||||
$fileselect(entry) delete 0 end
|
||||
$fileselect(entry) insert 0 [%W get [%W nearest %y]]
|
||||
}
|
||||
|
||||
bind $fileselect(list) <Key> {
|
||||
%W select from [%W nearest %y]
|
||||
$fileselect(entry) delete 0 end
|
||||
$fileselect(entry) insert 0 [%W get [%W nearest %y]]
|
||||
}
|
||||
|
||||
bind $fileselect(list) <Double-ButtonPress-1> {
|
||||
# puts stderr "double button 1"
|
||||
%W select from [%W nearest %y]
|
||||
$fileselect(entry) delete 0 end
|
||||
$fileselect(entry) insert 0 [%W get [%W nearest %y]]
|
||||
$fileselect(ok) invoke
|
||||
}
|
||||
|
||||
bind $fileselect(list) <Return> {
|
||||
%W select from [%W nearest %y]
|
||||
$fileselect(entry) delete 0 end
|
||||
$fileselect(entry) insert 0 [%W get [%W nearest %y]]
|
||||
$fileselect(ok) invoke
|
||||
}
|
||||
}
|
||||
set fileselect(text) $purpose
|
||||
$fileselect(msg) configure -text $purpose
|
||||
$fileselect(entry) delete 0 end
|
||||
$fileselect(entry) insert 0 [file tail $defaultName]
|
||||
|
||||
if {[info exists fileselect(lastDir)] && ![string length $defaultName]} {
|
||||
set dir $fileselect(lastDir)
|
||||
} else {
|
||||
set dir [file dirname $defaultName]
|
||||
}
|
||||
set fileselect(pwd) [pwd]
|
||||
fileselect.cd $dir
|
||||
$fileselect(direntry) delete 0 end
|
||||
$fileselect(direntry) insert 0 [pwd]/
|
||||
|
||||
$fileselect(list) delete 0 end
|
||||
$fileselect(list) insert 0 "Big directory:"
|
||||
$fileselect(list) insert 1 $dir
|
||||
$fileselect(list) insert 2 "Press Return for Listing"
|
||||
|
||||
fileselect.list.cmd $fileselect(direntry) startup
|
||||
|
||||
# set kbd focus to entry widget
|
||||
|
||||
# Exwin_ToplevelFocus $w $fileselect(entry)
|
||||
|
||||
# Wait for button hits if no callbacks are defined
|
||||
|
||||
if {"$cmd" == "" && "$errorHandler" == ""} {
|
||||
# wait for the box to be destroyed
|
||||
update idletask
|
||||
grab $w
|
||||
tkwait variable fileselect(result)
|
||||
grab release $w
|
||||
|
||||
set path $fileselect(result)
|
||||
set fileselect(lastDir) [pwd]
|
||||
fileselect.cd $fileselect(pwd)
|
||||
return [string trimright [string trim $path] /]
|
||||
}
|
||||
fileselect.cd $fileselect(pwd)
|
||||
return ""
|
||||
}
|
||||
|
||||
proc fileselect.cd { dir } {
|
||||
global fileselect
|
||||
if [catch {cd $dir} err] {
|
||||
fileselect.yck $dir
|
||||
cd
|
||||
}
|
||||
}
|
||||
# auxiliary button procedures
|
||||
|
||||
proc fileselect.yck { {tag {}} } {
|
||||
global fileselect
|
||||
$fileselect(msg) configure -text "Yck! $tag"
|
||||
}
|
||||
proc fileselect.ok {} {
|
||||
global fileselect
|
||||
$fileselect(msg) configure -text $fileselect(text)
|
||||
}
|
||||
|
||||
proc fileselect.cancel.cmd {w} {
|
||||
global fileselect
|
||||
set fileselect(result) {}
|
||||
}
|
||||
|
||||
proc fileselect.list.cmd {w {state normal}} {
|
||||
global fileselect
|
||||
set seldir [$fileselect(direntry) get]
|
||||
if {[catch {glob $seldir} dir]} {
|
||||
fileselect.yck "glob failed"
|
||||
return
|
||||
}
|
||||
if {[llength $dir] > 1} {
|
||||
set dir [file dirname $seldir]
|
||||
set pat [file tail $seldir]
|
||||
} else {
|
||||
set pat $fileselect(pattern)
|
||||
}
|
||||
fileselect.ok
|
||||
update idletasks
|
||||
if [file isdirectory $dir] {
|
||||
fileselect.getfiles $dir $pat $state
|
||||
focus $fileselect(entry)
|
||||
} else {
|
||||
fileselect.yck "not a dir"
|
||||
}
|
||||
}
|
||||
|
||||
proc fileselect.ok.cmd {w cmd errorHandler} {
|
||||
global fileselect
|
||||
set selname [$fileselect(entry) get]
|
||||
set seldir [$fileselect(direntry) get]
|
||||
|
||||
if [string match /* $selname] {
|
||||
set selected $selname
|
||||
} else {
|
||||
if [string match ~* $selname] {
|
||||
set selected $selname
|
||||
} else {
|
||||
set selected $seldir/$selname
|
||||
}
|
||||
}
|
||||
|
||||
# some nasty file names may cause "file isdirectory" to return an error
|
||||
if [catch {file isdirectory $selected} isdir] {
|
||||
fileselect.yck "isdirectory failed"
|
||||
return
|
||||
}
|
||||
if [catch {glob $selected} globlist] {
|
||||
if ![file isdirectory [file dirname $selected]] {
|
||||
fileselect.yck "bad pathname"
|
||||
return
|
||||
}
|
||||
set globlist $selected
|
||||
}
|
||||
fileselect.ok
|
||||
update idletasks
|
||||
|
||||
if {[llength $globlist] > 1} {
|
||||
set dir [file dirname $selected]
|
||||
set pat [file tail $selected]
|
||||
fileselect.getfiles $dir $pat
|
||||
return
|
||||
} else {
|
||||
set selected $globlist
|
||||
}
|
||||
if [file isdirectory $selected] {
|
||||
fileselect.getfiles $selected $fileselect(pattern)
|
||||
$fileselect(entry) delete 0 end
|
||||
return
|
||||
}
|
||||
|
||||
if {$cmd != {}} {
|
||||
$cmd $selected
|
||||
} else {
|
||||
set fileselect(result) $selected
|
||||
}
|
||||
}
|
||||
|
||||
proc fileselect.getfiles { dir {pat *} {state normal} } {
|
||||
global fileselect
|
||||
$fileselect(msg) configure -text Listing...
|
||||
update idletasks
|
||||
|
||||
set currentDir [pwd]
|
||||
fileselect.cd $dir
|
||||
if [catch {set files [lsort [glob -nocomplain $pat]]} err] {
|
||||
$fileselect(msg) configure -text $err
|
||||
$fileselect(list) delete 0 end
|
||||
update idletasks
|
||||
return
|
||||
}
|
||||
switch -- $state {
|
||||
normal {
|
||||
# Normal case - show current directory
|
||||
$fileselect(direntry) delete 0 end
|
||||
$fileselect(direntry) insert 0 [pwd]/
|
||||
}
|
||||
opt {
|
||||
# Directory already OK (tab related)
|
||||
}
|
||||
newdir {
|
||||
# Changing directory (tab related)
|
||||
fileselect.cd $currentDir
|
||||
}
|
||||
startup {
|
||||
# Avoid listing huge directories upon startup.
|
||||
$fileselect(direntry) delete 0 end
|
||||
$fileselect(direntry) insert 0 [pwd]/
|
||||
if {[llength $files] > 32} {
|
||||
fileselect.ok
|
||||
return
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
# build a reordered list of the files: directories are displayed first
|
||||
# and marked with a trailing "/"
|
||||
if [string compare $dir /] {
|
||||
fileselect.putfiles $files [expr {($pat == "*") ? 1 : 0}]
|
||||
} else {
|
||||
fileselect.putfiles $files
|
||||
}
|
||||
fileselect.ok
|
||||
}
|
||||
|
||||
proc fileselect.putfiles {files {dotdot 0} } {
|
||||
global fileselect
|
||||
|
||||
$fileselect(list) delete 0 end
|
||||
if {$dotdot} {
|
||||
$fileselect(list) insert end "../"
|
||||
}
|
||||
foreach i $files {
|
||||
if {[file isdirectory $i]} {
|
||||
$fileselect(list) insert end $i/
|
||||
} else {
|
||||
$fileselect(list) insert end $i
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
proc FileExistsDialog { name } {
|
||||
set w .fileExists
|
||||
global fileExists
|
||||
set fileExists(ok) 0
|
||||
{
|
||||
message $w.msg -aspect 1000
|
||||
pack $w.msg -side top -fill both -padx 20 -pady 20
|
||||
$w.but.quit config -text Cancel -command {FileExistsCancel}
|
||||
button $w.but.ok -text OK -command {FileExistsOK}
|
||||
pack $w.but.ok -side left
|
||||
bind $w.msg <Return> {FileExistsOK}
|
||||
}
|
||||
$w.msg config -text "Warning: file exists
|
||||
$name
|
||||
OK to overwrite it?"
|
||||
|
||||
set fileExists(focus) [focus]
|
||||
focus $w.msg
|
||||
grab $w
|
||||
tkwait variable fileExists(ok)
|
||||
grab release $w
|
||||
return $fileExists(ok)
|
||||
}
|
||||
proc FileExistsCancel {} {
|
||||
global fileExists
|
||||
set fileExists(ok) 0
|
||||
}
|
||||
proc FileExistsOK {} {
|
||||
global fileExists
|
||||
set fileExists(ok) 1
|
||||
}
|
||||
|
||||
proc fileselect.getfiledir { dir {basedir [pwd]} } {
|
||||
global fileselect
|
||||
|
||||
set path [$fileselect(direntry) get]
|
||||
set returnList {}
|
||||
|
||||
if {$dir != 0} {
|
||||
if {[string index $path 0] == "~"} {
|
||||
set path $path/
|
||||
}
|
||||
} else {
|
||||
set path [$fileselect(entry) get]
|
||||
}
|
||||
if [catch {set listFile [glob -nocomplain $path*]}] {
|
||||
return $returnList
|
||||
}
|
||||
foreach el $listFile {
|
||||
if {$dir != 0} {
|
||||
if [file isdirectory $el] {
|
||||
lappend returnList [file tail $el]
|
||||
}
|
||||
} elseif ![file isdirectory $el] {
|
||||
lappend returnList [file tail $el]
|
||||
}
|
||||
}
|
||||
|
||||
return $returnList
|
||||
}
|
||||
|
||||
proc fileselect.gethead { list } {
|
||||
set returnHead ""
|
||||
|
||||
for {set i 0} {[string length [lindex $list 0]] > $i}\
|
||||
{incr i; set returnHead $returnHead$thisChar} {
|
||||
set thisChar [string index [lindex $list 0] $i]
|
||||
foreach el $list {
|
||||
if {[string length $el] < $i} {
|
||||
return $returnHead
|
||||
}
|
||||
if {$thisChar != [string index $el $i]} {
|
||||
return $returnHead
|
||||
}
|
||||
}
|
||||
}
|
||||
return $returnHead
|
||||
}
|
||||
|
||||
proc fileselect.expand.tilde { } {
|
||||
global fileselect
|
||||
|
||||
set entry [$fileselect(direntry) get]
|
||||
set dir [string range $entry 1 [string length $entry]]
|
||||
|
||||
if {$dir == ""} {
|
||||
return
|
||||
}
|
||||
|
||||
set listmatch {}
|
||||
|
||||
## look in /etc/passwd
|
||||
if [file exists /etc/passwd] {
|
||||
if [catch {set users [exec cat /etc/passwd | sed s/:.*//]} err] {
|
||||
puts "Error\#1 $err"
|
||||
return
|
||||
}
|
||||
set list [split $users "\n"]
|
||||
}
|
||||
if {[lsearch -exact $list "+"] != -1} {
|
||||
if [catch {set users [exec ypcat passwd | sed s/:.*//]} err] {
|
||||
puts "Error\#2 $err"
|
||||
return
|
||||
}
|
||||
set list [concat $list [split $users "\n"]]
|
||||
}
|
||||
$fileselect(list) delete 0 end
|
||||
foreach el $list {
|
||||
if [string match $dir* $el] {
|
||||
lappend listmatch $el
|
||||
$fileselect(list) insert end $el
|
||||
}
|
||||
}
|
||||
set addings [fileselect.gethead $listmatch]
|
||||
if {$addings == ""} {
|
||||
return
|
||||
}
|
||||
$fileselect(direntry) delete 0 end
|
||||
if {[llength $listmatch] == 1} {
|
||||
$fileselect(direntry) insert 0 [file dirname ~$addings/]
|
||||
fileselect.getfiles [$fileselect(direntry) get]
|
||||
} else {
|
||||
$fileselect(direntry) insert 0 ~$addings
|
||||
}
|
||||
}
|
||||
|
||||
proc fileselect.tab.dircmd { } {
|
||||
global fileselect
|
||||
|
||||
set dir [$fileselect(direntry) get]
|
||||
if {$dir == ""} {
|
||||
$fileselect(direntry) delete 0 end
|
||||
$fileselect(direntry) insert 0 [pwd]
|
||||
if [string compare [pwd] "/"] {
|
||||
$fileselect(direntry) insert end /
|
||||
}
|
||||
return
|
||||
}
|
||||
if [catch {set tmp [file isdirectory [file dirname $dir]]}] {
|
||||
if {[string index $dir 0] == "~"} {
|
||||
fileselect.expand.tilde
|
||||
}
|
||||
return
|
||||
}
|
||||
if {!$tmp} {
|
||||
return
|
||||
}
|
||||
set dirFile [fileselect.getfiledir 1 $dir]
|
||||
if ![llength $dirFile] {
|
||||
return
|
||||
}
|
||||
if {[llength $dirFile] == 1} {
|
||||
$fileselect(direntry) delete 0 end
|
||||
$fileselect(direntry) insert 0 [file dirname $dir]
|
||||
if [string compare [file dirname $dir] /] {
|
||||
$fileselect(direntry) insert end /[lindex $dirFile 0]/
|
||||
} else {
|
||||
$fileselect(direntry) insert end [lindex $dirFile 0]/
|
||||
}
|
||||
fileselect.getfiles [$fileselect(direntry) get] \
|
||||
"[file tail [$fileselect(direntry) get]]$fileselect(pattern)" opt
|
||||
return
|
||||
}
|
||||
set headFile [fileselect.gethead $dirFile]
|
||||
$fileselect(direntry) delete 0 end
|
||||
$fileselect(direntry) insert 0 [file dirname $dir]
|
||||
if [string compare [file dirname $dir] /] {
|
||||
$fileselect(direntry) insert end /$headFile
|
||||
} else {
|
||||
$fileselect(direntry) insert end $headFile
|
||||
}
|
||||
if {$headFile == "" && [file isdirectory $dir]} {
|
||||
fileselect.getfiles $dir\
|
||||
"[file tail [$fileselect(direntry) get]]$fileselect(pattern)" opt
|
||||
} else {
|
||||
fileselect.getfiles [file dirname $dir]\
|
||||
"[file tail [$fileselect(direntry) get]]*" newdir
|
||||
}
|
||||
}
|
||||
|
||||
proc fileselect.tab.filecmd { } {
|
||||
global fileselect
|
||||
|
||||
set dir [$fileselect(direntry) get]
|
||||
if {$dir == ""} {
|
||||
set dir [pwd]
|
||||
}
|
||||
if {![file isdirectory $dir]} {
|
||||
error "dir $dir doesn't exist"
|
||||
}
|
||||
set listFile [fileselect.getfiledir 0 $dir]
|
||||
puts $listFile
|
||||
if ![llength $listFile] {
|
||||
return
|
||||
}
|
||||
if {[llength $listFile] == 1} {
|
||||
$fileselect(entry) delete 0 end
|
||||
$fileselect(entry) insert 0 [lindex $listFile 0]
|
||||
return
|
||||
}
|
||||
set headFile [fileselect.gethead $listFile]
|
||||
$fileselect(entry) delete 0 end
|
||||
$fileselect(entry) insert 0 $headFile
|
||||
fileselect.getfiles $dir "[$fileselect(entry) get]$fileselect(pattern)" opt
|
||||
}
|
||||
|
||||
proc Exwin_Toplevel { path name {class Dialog} {dismiss yes}} {
|
||||
global exwin
|
||||
if [catch {wm state $path} state] {
|
||||
set t [Widget_Toplevel $path $name $class]
|
||||
if ![info exists exwin(toplevels)] {
|
||||
set exwin(toplevels) [option get . exwinPaths {}]
|
||||
}
|
||||
set ix [lsearch $exwin(toplevels) $t]
|
||||
if {$ix < 0} {
|
||||
lappend exwin(toplevels) $t
|
||||
}
|
||||
if {$dismiss == "yes"} {
|
||||
set f [Widget_Frame $t but Menubar {top fill}]
|
||||
Widget_AddBut $f quit "Dismiss" [list Exwin_Dismiss $path]
|
||||
}
|
||||
return 1
|
||||
} else {
|
||||
if {$state != "normal"} {
|
||||
catch {
|
||||
wm geometry $path $exwin(geometry,$path)
|
||||
# Exmh_Debug Exwin_Toplevel $path $exwin(geometry,$path)
|
||||
}
|
||||
wm deiconify $path
|
||||
} else {
|
||||
catch {raise $path}
|
||||
}
|
||||
return 0
|
||||
}
|
||||
}
|
||||
|
||||
proc Exwin_Dismiss { path {geo ok} } {
|
||||
global exwin
|
||||
case $geo {
|
||||
"ok" {
|
||||
set exwin(geometry,$path) [wm geometry $path]
|
||||
}
|
||||
"nosize" {
|
||||
set exwin(geometry,$path) [string trimleft [wm geometry $path] 0123456789x]
|
||||
}
|
||||
default {
|
||||
catch {unset exwin(geometry,$path)}
|
||||
}
|
||||
}
|
||||
wm withdraw $path
|
||||
}
|
||||
|
||||
proc Widget_Toplevel { path name {class Dialog} {x {}} {y {}} } {
|
||||
set self [toplevel $path -class $class]
|
||||
set usergeo [option get $path position Position]
|
||||
if {$usergeo != {}} {
|
||||
if [catch {wm geometry $self $usergeo} err] {
|
||||
# Exmh_Debug Widget_Toplevel $self $usergeo => $err
|
||||
}
|
||||
} else {
|
||||
if {($x != {}) && ($y != {})} {
|
||||
# Exmh_Debug Event position $self +$x+$y
|
||||
wm geometry $self +$x+$y
|
||||
}
|
||||
}
|
||||
wm title $self $name
|
||||
wm group $self .
|
||||
return $self
|
||||
}
|
||||
|
||||
proc Widget_Frame {par child {class GDB} {where {top expand fill}} args } {
|
||||
if {$par == "."} {
|
||||
set self .$child
|
||||
} else {
|
||||
set self $par.$child
|
||||
}
|
||||
eval {frame $self -class $class} $args
|
||||
pack append $par $self $where
|
||||
return $self
|
||||
}
|
||||
|
||||
proc Widget_AddBut {par but txt cmd {where {right padx 1}} } {
|
||||
# Create a Packed button. Return the button pathname
|
||||
set cmd2 [list button $par.$but -text $txt -command $cmd]
|
||||
if [catch $cmd2 t] {
|
||||
puts stderr "Widget_AddBut (warning) $t"
|
||||
eval $cmd2 {-font fixed}
|
||||
}
|
||||
pack append $par $par.$but $where
|
||||
return $par.$but
|
||||
}
|
||||
proc Widget_CheckBut {par but txt var {where {right padx 1}} } {
|
||||
# Create a check button. Return the button pathname
|
||||
set cmd [list checkbutton $par.$but -text $txt -variable $var]
|
||||
if [catch $cmd t] {
|
||||
puts stderr "Widget_CheckBut (warning) $t"
|
||||
eval $cmd {-font fixed}
|
||||
}
|
||||
pack append $par $par.$but $where
|
||||
return $par.$but
|
||||
}
|
||||
|
||||
proc Widget_Label { frame {name label} {where {left fill}} args} {
|
||||
set cmd [list label $frame.$name ]
|
||||
if [catch [concat $cmd $args] t] {
|
||||
puts stderr "Widget_Label (warning) $t"
|
||||
eval $cmd $args {-font fixed}
|
||||
}
|
||||
pack append $frame $frame.$name $where
|
||||
return $frame.$name
|
||||
}
|
||||
proc Widget_Entry { frame {name entry} {where {left fill}} args} {
|
||||
set cmd [list entry $frame.$name ]
|
||||
if [catch [concat $cmd $args] t] {
|
||||
puts stderr "Widget_Entry (warning) $t"
|
||||
eval $cmd $args {-font fixed}
|
||||
}
|
||||
pack append $frame $frame.$name $where
|
||||
return $frame.$name
|
||||
}
|
||||
|
||||
# End of fileselect.tcl.
|
||||
|
||||
# Setup the initial windows
|
||||
|
||||
create_source_window
|
||||
|
|
|
|||
Loading…
Reference in a new issue