diff options
author | Tom Tromey <tromey@redhat.com> | 1996-11-19 07:40:18 +0000 |
---|---|---|
committer | Tom Tromey <tromey@redhat.com> | 1996-11-19 07:40:18 +0000 |
commit | a5a6e3bd0a4e85c405a31aba675b3a657f299590 (patch) | |
tree | cba276039ffc78e5713b3a8e06099a82441999be /gdb | |
parent | 692a601fb7311430c4b12a47c2dee7f12244171b (diff) | |
download | gdb-a5a6e3bd0a4e85c405a31aba675b3a657f299590.zip gdb-a5a6e3bd0a4e85c405a31aba675b3a657f299590.tar.gz gdb-a5a6e3bd0a4e85c405a31aba675b3a657f299590.tar.bz2 |
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.
Diffstat (limited to 'gdb')
-rw-r--r-- | gdb/ChangeLog | 9 | ||||
-rw-r--r-- | gdb/gdbtk.c | 2 | ||||
-rw-r--r-- | gdb/gdbtk.tcl | 661 |
3 files changed, 11 insertions, 661 deletions
diff --git a/gdb/ChangeLog b/gdb/ChangeLog index 5c11a79..27e172b 100644 --- a/gdb/ChangeLog +++ b/gdb/ChangeLog @@ -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 diff --git a/gdb/gdbtk.c b/gdb/gdbtk.c index a51f6d9..d90dfc0 100644 --- a/gdb/gdbtk.c +++ b/gdb/gdbtk.c @@ -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); diff --git a/gdb/gdbtk.tcl b/gdb/gdbtk.tcl index 598e59c..88058cb 100644 --- a/gdb/gdbtk.tcl +++ b/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" \ @@ -2682,665 +2682,6 @@ proc delete_line {win} { } # -# 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 # of time. |