mirror of
https://github.com/darlinghq/darling-gdb.git
synced 2024-11-28 14:30:48 +00:00
Fixes for Tcl 7.6 / Tk 4.2:
* gdbtk.tcl (apply_filespec): Use tk_getOpenFile.
Removed old fileselect code.
* gdbtk.c (Tcl_Alloc): Renamed from Tcl_Malloc.
This commit is contained in:
Tom Tromey
parent
692a601fb7
commit
a5a6e3bd0a
@ -1,3 +1,12 @@
|
||||
start-sanitize-gdbtk
|
||||
Mon Nov 18 23:43:05 1996 Tom Tromey <tromey@cygnus.com>
|
||||
|
||||
Fixes for Tcl 7.6 / Tk 4.2:
|
||||
* gdbtk.tcl (apply_filespec): Use tk_getOpenFile.
|
||||
Removed old fileselect code.
|
||||
* gdbtk.c (Tcl_Alloc): Renamed from Tcl_Malloc.
|
||||
|
||||
end-sanitize-gdbtk
|
||||
Mon Nov 18 15:58:05 1996 Jim Wilson <wilson@cygnus.com>
|
||||
|
||||
* config/mips/tm-mips.h (FIX_CALL_DUMMY): Change unsigned LONGEST
|
||||
|
||||
@ -120,7 +120,7 @@ static int disassemble_from_exec = -1;
|
||||
/* Supply malloc calls for tcl/tk. */
|
||||
|
||||
char *
|
||||
Tcl_Malloc (size)
|
||||
Tcl_Alloc (size)
|
||||
unsigned int size;
|
||||
{
|
||||
return xmalloc (size);
|
||||
|
||||
661
gdb/gdbtk.tcl
661
gdb/gdbtk.tcl
@ -2257,7 +2257,7 @@ proc files_command {} {
|
||||
button .files -text Files -command files_command
|
||||
|
||||
proc apply_filespec {label default command} {
|
||||
set filename [FSBox $label $default]
|
||||
set filename [tk_getOpenFile -title $label -initialfile $default]
|
||||
if {$filename != ""} {
|
||||
if {[catch {gdb_cmd "$command $filename"} retval]} {
|
||||
tk_dialog .filespec_error "gdb : $label error" \
|
||||
@ -2681,665 +2681,6 @@ proc delete_line {win} {
|
||||
set command_line {}
|
||||
}
|
||||
|
||||
#
|
||||
# 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]
|
||||
|
||||
$fileselect(list) configure -selectmode single
|
||||
|
||||
bind $fileselect(list) <Button-1> {
|
||||
# puts stderr "button 1 release"
|
||||
$fileselect(entry) delete 0 end
|
||||
$fileselect(entry) insert 0 [%W get [%W nearest %y]]
|
||||
}
|
||||
|
||||
bind $fileselect(list) <Key> {
|
||||
$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"
|
||||
$fileselect(entry) delete 0 end
|
||||
$fileselect(entry) insert 0 [%W get [%W nearest %y]]
|
||||
$fileselect(ok) invoke
|
||||
}
|
||||
|
||||
bind $fileselect(list) <Return> {
|
||||
$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) {}
|
||||
destroy $w
|
||||
}
|
||||
|
||||
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
|
||||
}
|
||||
destroy $w
|
||||
}
|
||||
|
||||
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
|
||||
destroy $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
|
||||
}
|
||||
|
||||
# FIXME this function is a crock. Can write tilde expanding function
|
||||
# in terms of glob and quote_glob; do so.
|
||||
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.
|
||||
|
||||
#
|
||||
# Create a copyright window and center it on the screen. Arrange for
|
||||
# it to disappear when the user clicks it, or after a suitable period
|
||||
|
||||
Loading…
Reference in New Issue
Block a user