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" \
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
projects / binutils-gdb.git / commitdiff