tkprompt & xtext-bind
John Robert LoVerso
xprompt (or xprompt2) program in the X contrib repository. It pops up
a window containing one or more prompts and an input areas. Each input
area can have an initial value. The user can traverse between the
different inputs areas and enter responses to the prompts. It is a
two-way xmessage, in effect.
The hightlight of the widget with the focus is done by increasing
the border width of the widget. Normally each widget has a bw of 2
and a pack padding of 2. When it has the focus, it gets a bw of 4
and a padding of 0. This works well for the text widgets used.
The other interesting item is my "xtext" library. tkprompt will
use this if you install it. It provides some bindings and behaviors
reminiscent of the damnable Athena text widget. That is, that same
old horrible set of emacs-like bindings. [I'll fix this as soon as
I get more free time to work on tkvi].
The other thing xtext provides is the ability to dynamically expand
the size of the text widget so that there is no need for scrollbars
or scanning. This is the logical equivalent of the "resizable" or
"AllowShellResize" Athena widget option. The fancy thing about this
is that tkprompt starts with a 20-unit wide input area, but as you
type toward the right margin or hit ^J for a new line, it grows
accordingly. This becomes a handy multi-line entry widget.
I hope this is useful to someone.
I use this as:
env DISPLAY=(someone else's display) \
tkprompt -p "When is a good time for lunch?" -r "noon" \
-p "(and be on time)"
John
#!/bin/sh
# This is a shell archive (produced by shar 3.49)
# To extract the files from this archive, save it to a file, remove
# everything above the "!/bin/sh" line above, and type "sh file_name".
#
# made 12/01/1993 02:30 UTC by <jo...@loverso.southborough.ma.us>.
#
# existing files will NOT be overwritten unless -c is specified
#
# This shar contains:
# length mode name
# ------ ---------- ------------------------------------------
# 4371 -rwxr-xr-x tkprompt
# 6836 -rw-r--r-- xtext-bind.tcl
#
# ============= tkprompt ==============
if test -f 'tkprompt' -a X"$1" != X"-c"; then
echo 'x - skipping tkprompt (File already exists)'
else
echo 'x - extracting tkprompt (Text)'
sed 's/^X//' << 'SHAR_EOF' > 'tkprompt' &&
#!/usr/local/bin/wish -f
#
# $Id: tkprompt,v 2.1 1993/12/01 02:29:54 loverso Exp loverso $
#
# An xprompt-like program for Tk3.3.
# Written by John Robert LoVerso <jo...@loverso.southborough.ma.us>
# If you use this or parts of it, please have the courtesy to acknowledge me.
#
X
# Change this to include the location of the xtext-bind library.
if ![catch {glob ~/local/lib/tcl} path] {
X set auto_path "$path $auto_path"
}
# For before this is installed
set auto_path ". $auto_path"
X
# defaults - should use options database
set rlen 20
set aspect 1000
set grab 0
set xtext 1
set hl #eed5b7
X
set pfn -*-courier-bold-o-*--*-140-*
set rfn -*-courier-medium-r-*--*-140-*
#set pfn -Adobe-Helvetica-Bold-R-Normal--*-140-*
#set rfn -Adobe-Helvetica-Medium-R-Normal--*-140-*
X
proc usage {} {
X puts stderr {
Usage: tkprompt [flags] {-p prompt [-r reply]} ...
X
where flags is one or more of:
X-rlen <length> Maximum length of user's reply: default 20
X-grab Grab keyboard
X-nograb Don't grab keyboard (default)
X-pfn <font> Prompt font
X-rfn <font> Reply font
X-hl <color> Input highlight color
X
X-aspect Aspect of the label (1000 default)
X-xtext Use extended Text widget (default)
X-noxtext Don't use extended Text widget
X
The default prompt is "?"
}
X
X exit 1
}
X
set prompts -1
set skip 0
set i 0
foreach a $argv {
X incr i
X if $skip {set skip 0; continue}
X switch -glob -- $a {
X -p {
X incr prompts
X set prompt($prompts) [lindex $argv $i]
X set reply($prompts) {}
X set skip 1
X }
X -r {
X if {$prompts < 0} usage
X set reply($prompts) [lindex $argv $i]
X set skip 1
X }
X -asp* {set aspect [lindex $argv $i]; set skip 1}
X -rlen {set rlen [lindex $argv $i]; set skip 1}
X -pfn {set pfn [lindex $argv $i]; set skip 1}
X -rfn {set rfn [lindex $argv $i]; set skip 1}
X -hl {set hl [lindex $argv $i]; set skip 1}
X -grab {set grab 1}
X -nograb {set grab 0}
X -x* {set xtext 1}
X -nox* {set xtext 0}
X default usage
X }
}
X
if {$prompts < 0} {
X incr prompts
X set prompt(0) ?
X set reply(0) {}
}
X
X
#
# Load expanding Text widget with emacs-like bindings
#
if {!$xtext || [catch {xtext-bind emacs}]} {
X # workaround
X
X proc text-ins {w t} {
X $w insert insert $t
X $w yview -pickplace insert
X }
X
X set otherTopts {-setgrid 1}
} else {
X set otherTopts {-wrap none}
}
X
#####
#
# Xprompt application
#
X
bind Text <Tab> {advance-field 1 1}
bind Text <Down> {advance-field 1 1}
bind Text <Return> {advance-field 1 0}
bind Text <KP_Enter> {advance-field 1 0}
X
bind Text <Up> {advance-field -1 1}
bind Text <Control-Tab> {advance-field -1 1}
bind Text <Shift-Tab> {advance-field -1 1}
X
bind Text <Control-c> bail-application
X
proc bail-application {} {exit 0}
proc advance-field {dir runmore} {
X global prompts focus
X set newfocus [expr $focus + $dir]
X if {$newfocus > $prompts} {
X if !$runmore {
X for {set i 0} {$i <= $prompts} {incr i} {
X puts stdout [.line$i.reply get 0.0 end]
X }
X exit 0
X }
X set newfocus 0
X }
X if {$newfocus < 0} {set newfocus $prompts}
X set-focus $newfocus
}
# Would like to just change the padding on the text widget,
# but a bug in Tk3.3(3.6) prevents this (it doesn't redraw the smaller border).
proc set-focus {nf} {
X global focus hl
X
X .line$focus.reply config \
X -background [lindex [.line$focus.reply config -background] 3] \
X -borderw 2
X pack .line$focus.reply -padx 2 -pady 2
X set focus $nf
X .line$focus.reply config -background $hl -borderw 4
X pack .line$focus.reply -padx 0 -pady 0
X focus .line$focus.reply
}
X
. config -relief ridge -borderw 2
for {set i 0} {$i <= $prompts} {incr i} {
X set f [frame .line$i]
X pack $f -anchor w -expand 1 -fill both -padx 5 -pady 5
X
X set cmd [concat message $f.prompt -text [list $prompt($i)] -font $pfn \
X -borderw 2 -relief ridge -aspect $aspect]
X if [catch $cmd] {
X eval $cmd {-font -Adobe-Helvetica-Bold-R-Normal--*-120-*}
X }
X pack $f.prompt -side left -ipadx 1 -ipady 1
X
X set cmd [concat text $f.reply -borderw 2 -relief ridge $otherTopts \
X -padx 2 -pady 2 \
X -width $rlen -height 1 -font $rfn]
X if [catch $cmd] {
X eval $cmd {-font -Adobe-Helvetica-Medium-R-Normal--*-120-*}
X }
X pack $f.reply -side right -expand 1 -fill both -padx 2 -pady 2
X bind $f.reply <FocusIn> "set-focus $i"
X #text-ins $f.reply $reply($i)
}
for {set i 0} {$i <= $prompts} {incr i} {
X text-ins .line$i.reply $reply($i)
}
X
if $grab {update idletasks; grab -global .}
X
set focus 0
set-focus 0
X
#eof
SHAR_EOF
chmod 0755 tkprompt ||
echo 'restore of tkprompt failed'
Wc_c="`wc -c < 'tkprompt'`"
test 4371 -eq "$Wc_c" ||
echo 'tkprompt: original size 4371, current size' "$Wc_c"
fi
# ============= xtext-bind.tcl ==============
if test -f 'xtext-bind.tcl' -a X"$1" != X"-c"; then
echo 'x - skipping xtext-bind.tcl (File already exists)'
else
echo 'x - extracting xtext-bind.tcl (Text)'
sed 's/^X//' << 'SHAR_EOF' > 'xtext-bind.tcl' &&
#####
#
# Tk Text bindings reminescent of Emacs and/or the Athena text widget
#
# $Id: xtext-bind.tcl,v 2.1 1993/12/01 02:29:54 loverso Exp loverso $
#
# Written by John Robert LoVerso <jo...@loverso.southborough.ma.us>
# If you use this or parts of it, please have the courtesy to acknowledge me.
#
# Parts of this were inspired by Brent Welch's sedit (part of exmh).
# In particular, the text-line function.
#
X
# Change this to include the location of the xtext-bind library.
X
# auto-load hack
proc xtext-bind {style} {
}
X
bind Text <Escape> { }
X
foreach k {<Return> <KP_Enter> <Control-j> <Control-m>} {
X bind Text $k {text-taller %W}
}
bind Text <Control-o> {text-taller %W 1}
X
# Del to BOL
bind Text <Control-u> {%W delete "insert linestart" insert}
# Del to EOL
bind Text <Control-k> {text-if %W lineend \
X {%W delete insert "insert +1 chars"} \
X {%W delete insert "insert lineend"}}
# Del forward
bind Text <Control-d> {text-if %W lineend {%W delete insert}}
X
# Del backward
foreach k {<BackSpace> <Delete> <Control-h>} {
X bind Text $k {text-if %W linestart {%W delete insert-1c insert}}
}
X
# Del forward word
bind Text <Escape>d {text-if %W lineend {%W delete insert "insert wordend"}}
# Del backward word
bind Text <Control-w> {text-if %W linestart \
X {%W delete "insert -1c wordstart" insert}}
X
# Ins char
bind Text <Any-KeyPress> {if {"%A" != ""} {%W insert insert %A; text-wider %W}}
X
# Forw/back char
bind Text <Control-f> {%W mark set insert "insert +1 chars"}
bind Text <Control-b> {%W mark set insert "insert -1 chars"}
X
# Forw/back word
bind Text <Escape>f {
X if [%W compare insert == "insert wordend"] {
X %W mark set insert "insert +1 chars"
X }
X %W mark set insert "insert wordend"
}
bind Text <Escape>b {
X if [%W compare insert == "insert wordstart"] {
X %W mark set insert "insert -1 chars"
X }
X %W mark set insert "insert wordstart"
}
X
X
# Beginning/End of text
bind Text <Escape><Key-less> {%W mark set insert 1.0}
bind Text <Escape><Key-greater> {%W mark set insert end}
X
# Beginning/End of line
bind Text <Control-a> {%W mark set insert "insert linestart"}
bind Text <Control-e> {%W mark set insert "insert lineend"}
X
# Up/down line
bind Text <Control-p> {if [%W compare insert > 1.end] {text-line %W -1}}
bind Text <Control-n> {if [%W compare insert < "end lines"] {text-line %W 1}}
X
# Del/ins selection
bind Text <Control-x> {text-delsel %W}
bind Text <Control-v> {if ![catch {selection get} s] {text-ins %W $s}}
bind Text <Insert> {if ![catch {selection get} s] {text-ins %W $s}}
X
#
# support
#
X
proc text-line {w dir} {
X global Xtext
X
X if {![info exists Xtext(pos,$w)] ||
X $Xtext(pos,$w) != [$w index insert]} {
X set parts [split [set Xtext(pos,$w) [$w index insert]] .]
X set Xtext(col,$w) [lindex $parts 1]
X set Xtext(line,$w) [lindex $parts 0]
X }
X set parts [split [$w index [incr Xtext(line,$w) $dir].end] .]
X set lastcol [lindex $parts 1]
X set column $Xtext(col,$w)
X if {$column > $lastcol} {
X set column end
X }
X $w mark set insert $Xtext(line,$w).$column
X set Xtext(pos,$w) [$w index insert]
}
proc text-delsel {w} {
X if [catch {$w index sel.first} sel] return
X $w delete sel.first sel.last
X text-wider $w $sel
}
proc text-if {w dir true {false {}}} {
X if [$w compare insert == "insert $dir"] {
X eval $true
X text-wider $w
X } else {
X if [string match "" $false] {
X eval $true
X } else {
X eval $false
X }
X }
}
X
# Compute the geometry of the text
proc text-grid {w} {
X global Xtext
X
X set Xtext(x,$w) [winfo reqwidth $w]
X set Xtext(y,$w) [winfo reqheight $w]
X set x [expr $Xtext(x,$w) - 2 * \
X ([lindex [$w config -padx] 4] + \
X [lindex [$w config -borderw ] 4] )]
X set y [expr [winfo reqheight $w] - 2 * \
X ([lindex [$w config -padx] 4] + \
X [lindex [$w config -borderw ] 4] )]
X set Xtext(gridX,$w) [expr $x / [lindex [$w config -width] 4]]
X set Xtext(gridY,$w) [expr $y / [lindex [$w config -height] 4]]
}
X
# Make the text wider
proc text-wider {w {index insert}} {
X global Xtext
X
X if 0 {
X # this only works for fixed width fonts
X scan [$w index "$index lineend"] "%*d.%d" wid
X if {$wid >= [lindex [$w config -width] 4]} {
X $w config -width [expr $wid +1]
X }
X return
X }
X
X if ![info exists Xtext(gridX,$w)] {
X text-grid $w
X }
X
X set pos [split [$w index "$index lineend"] .]
X set row [lindex $pos 0]
X set rowy [expr $Xtext(gridY,$w) * $row]
X
X update idletasks
X set x [winfo reqwidth $w]
X if [$w compare "$index lineend" > @$x,$rowy] {
X # the character position of the end of the line
X set lineend [lindex $pos 1]
X
X # the character position at the right window border
X set pos [split [$w index @$x,$rowy] .]
X set atx [lindex $pos 1]
X
X # An estimate of how much space to move
X # This is correct for fixed width fonts, but probably
X # an overestimation for proportionally spaced ones.
X set fullincr [expr $lineend - $atx]
X
X # since $incr is an over-estimation,
X # we'll approach the margin by halves
X set incr [expr ($fullincr + 1)/ 2]
X if !$incr {set incr 1}
X
X set p 1
X if !$p {
X set incrX [expr $incr * $Xtext(gridX,$w)]
X }
X
X set wid [lindex [$w config -width] 4]
X
X while {[$w compare "$index lineend" > @$x,$rowy]} {
X #$w yview -pickplace insert
X $w config -width [incr wid $incr]
X
X if $p {
X set x [expr $x + ($incr * $Xtext(gridX,$w))]
X set incr [expr ($incr + 1)/ 2]
X if !$incr {set incr 1}
X } else {
X incr x $incrX
X }
X
X # or else @ won't return new info
X update idletasks
X }
X set Xtext(x,$w) $x
X if {$Xtext(x,$w) != [winfo reqwidth $w]} {
X puts "x mismatch $Xtext(x,$w) != [winfo reqwidth $w]"
X puts [winfo geom $w]
X puts [winfo width $w]
X puts [winfo reqwidth $w]
X puts [$w config -padx]
X puts [$w config -borderw]
X }
X }
}
X
# Insert into the text, allowing it to grow taller or wider
proc text-ins {w t} {
X while [string compare "" $t] {
X set n [string first \n $t]
X if {$n == -1} {
X $w insert insert $t
X text-wider $w
X break
X }
X if $n {
X $w insert insert [string range $t 0 [expr $n -1]]
X text-wider $w
X }
X text-taller $w
X incr n
X set t [string range $t $n end]
X }
}
X
# Make the text taller
proc text-taller {w {stay 0}} {
X scan [$w index end] "%d.%*d" line
X set h [lindex [$w config -height] 4]
X if {$h <= $line} {
X $w config -height [expr $h + 1]
X #####update idletasks
X }
X $w insert insert \n
X if $stay {
X $w mark set insert "insert -1c"
X }
}
X
#
# Allow b2 to paste
#
# Adapted from code written by Tom Phelps <phe...@ginkgo.CS.Berkeley.EDU>
#
set Text(b2-time-delta) 1000; set Text(b2-motion-delta) 4
set Text(b2-time) 0; set Text(b2-x) 0; set Text(b2-y) 0
bind Text <Button-2> {+
X set Text(b2-time) %t
X set Text(b2-x) %x
X set Text(b2-y) %y
}
bind Text <ButtonRelease-2> {
X if {%t-$Text(b2-time)<$Text(b2-time-delta) &&
X abs(%x-$Text(b2-x))<$Text(b2-motion-delta) &&
X abs(%y-$Text(b2-y))<$Text(b2-motion-delta)} {
X if ![catch {selection get} s] {text-ins %W $s}
X }
}
SHAR_EOF
chmod 0644 xtext-bind.tcl ||
echo 'restore of xtext-bind.tcl failed'
Wc_c="`wc -c < 'xtext-bind.tcl'`"
test 6836 -eq "$Wc_c" ||
echo 'xtext-bind.tcl: original size 6836, current size' "$Wc_c"
fi
exit 0