tkgoodstuff/tcl/utils.tcl

293 lines
6.6 KiB
Tcl
Raw Permalink Normal View History

proc setifunset { varname value } {
if ![uplevel [list info exists $varname]] {
uplevel [list set $varname $value]
}
}
# Is string $s empty?
proc Empty {s} {string match "" $s}
# Is string $i in the list $l?
proc In {i l} {expr [lsearch -exact $l $i] != -1}
proc ListAdd {listvar item} {
upvar $listvar list
if {![info exists list]
|| ![In $item $list]} {
lappend list $item
}
return $list
}
proc ListRemove {listvar item} {
upvar $listvar list
while {[set i [lsearch -exact $list $item]] != -1} {
set list [lreplace $list $i $i]
}
return $list
}
# Apply: use: Apply command arglist
proc Apply args {
foreach i $args { foreach j $i { lappend l $j } }
uplevel 1 $l
}
proc GetFile {f} {
set id [open $f]
set ret [read $id]
close $id
return $ret
}
proc Min args {
set m [lindex $args 0]
foreach a [lrange $args 1 end] {
if $a<$m {set m $a}
}
return $m
}
proc Max args {
set m [lindex $args 0]
foreach a [lrange $args 1 end] {
if $a>$m {set m $a}
}
return $m
}
proc TKGDoHook {hook args} {
global $hook
if ![info exists $hook] return
foreach command [set $hook] {
uplevel \#0 "eval $command $args"
}
}
proc TKGAddToHook {hook args} {
global $hook
foreach arg $args {
lappend $hook [list $arg]
}
}
proc TKGRemoveFromHook {hook cmd} {
global $hook
if ![info exists $hook] return
while {[set i [lsearch -exact [set $hook] [list $cmd]]] != -1} {
set $hook [lreplace [set $hook] $i $i]
}
}
proc TKGResetHook {hook} {
global $hook
catch {unset $hook}
}
proc TKGZeroTrim { s } {
set o ""
scan $s "%d" o
return $o
}
# Replace @selection@ in string with X selection
proc SelectionSub {s} {
if [catch {set sel [string trim [selection get]]}] {
set sel ""
}
regsub -all -nocase @selection@ $s $sel s
return $s
}
# TKGEncode and TKGDecode --
# Reversibly encode a string into a safe string (lowercase, no
# whitespace, backslashes, newlines, or dots).
proc TKGEncode {s} {
regsub -all ~ $s ~~ s
regsub -all { } $s ~s s
regsub -all "\t" $s ~t s
regsub -all "\n" $s ~n s
regsub -all {\.} $s ~d s
return $s
}
proc TKGDecode {s} {
regsub -all ~~ $s ~ s
regsub -all ~s $s { } s
regsub -all ~t $s "\t" s
regsub -all ~n $s "\n" s
regsub -all ~d $s . s
return $s
}
# TKGSexpr --
# Parses an S-expression and returns a tcl list.
proc TKGSexpr {E} {
set level 0
for {set i 0} {$i < [string length $E]} {incr i} {
switch -- [string index $E $i] {
( {
append L \{
} ) {
append L \}
} " " {
append L " "
} \" {
set tmp ""
while {[string comp [set c [string index $E [incr i]]] \"]} {
append tmp $c
}
append L "[list $tmp]"
} \{ {
set n ""
while {[string comp [set c [string index $E [incr i]]] \}]} {
append n $c
}
append L "[list [string range $E [expr $i + 3] [expr $i + $n + 2]]]"
incr i [expr $n + 2]
} default {
append L [list [string range $E $i [set i [ expr [string wordend $E $i] - 1]]]]
}
}
}
return [lindex $L 0]
}
proc TKGCenter {w} {
update idletasks
set x [expr ([winfo vrootwidth $w] - [winfo reqwidth $w] )/2]
set y [expr ([winfo vrootheight $w] - [winfo reqheight $w] )/2]
wm geometry $w +$x+$y
wm deiconify $w
}
proc ColorConfig { pathname fore back } {
foreach child [winfo children $pathname] {
ColorConfig $child $fore $back
}
if { "$fore" != "-" } {
catch "$pathname configure -foreground $fore"
}
if { "$back" != "-" } {
catch "$pathname configure -background $back"
}
}
proc RecursiveBind { pathname seq command } {
foreach window [winfo children $pathname] {
RecursiveBind $window $seq $command
}
regsub -all @W $command $pathname c
bind $pathname $seq $c
}
proc SetImage { name file } {
global TKG
if [regexp %(.*) $file file file] {
set file ${file}$TKG(iconscale).xpm
}
if [file exists $file] {
set f $file
} else {
foreach dir [split $TKG(icons) :] {
if [file exists $dir/$file] {
set f $dir/$file
break
}
}
}
if ![info exists f] {
TKGError "Can't locate image file $file." exit
}
foreach imagetype [image types] {
if {! [catch { image create $imagetype $name -file $f }]} {
return $imagetype
}
}
TKGError "File $file does not contain an image we can parse." exit
}
proc TKGGetPassword {title {message ""}} {
set i 0
while {[winfo exists .getpswd$i]} {incr i}
set w .getpswd$i
set v getpassword$i
global $v
TKGDialog getpswd$i \
-title $title \
-wmtitle $title \
-image question \
-nodismiss -nodeiconify\
-buttons [list \
[list abort "Abort" "set $v @@ABORT@@; destroy $w"] \
[list ok "OK" "destroy $w"]]
if ![Empty $message] {
grid [message $w.m -text $message] -row 1 -column 0 -sticky nsew
}
grid [frame $w.w] -row 2 -column 0 -sticky nsew
grid columnconfigure $w.w 1 -weight 1
grid [label $w.w.l2 -text "Password:"] \
-row 1 -column 0 -sticky w
set i 0
grid [entry $w.w.e2 -textvariable $v -show *] \
-row 1 -column 1 -sticky we
bind $w.w.e2 <Key-Return> [subst {
$w.buttons.ok flash
$w.buttons.ok invoke
}]
focus $w.w.e2
TKGCenter $w
tkwait window $w
set password [set $v]
unset $v
return $password
}
# reset all grid row and column weights to 0
proc TKGClearWeights {w} {
set size [grid size $w]
for {set col 0} {$col < [lindex $size 0]} {incr col} {
grid columnconfigure $w $col -weight 0
}
for {set row 0} {$row < [lindex $size 1]} {incr row} {
grid rowconfigure $w $row -weight 0
}
}
# takes percentage of normal settings (as in "xset q")
# we default to a higher than normal bell pitch
# but respect other parameters by default
proc TKGBell {{percent 1} {pitch {1.2}} {duration {1}}} {
global TKG
if $TKG(nobeep) return
if {![info exists TKG(bell,pitch)]} {
set TKG(bell,pitch) ""
set TKG(bell,percent) ""
set TKG(bell,duration) ""
if [catch {
scan [exec xset q | grep bell ] \
" %s %s %d %s %s %d %s %s %d "\
x x TKG(bell,percent) \
x x TKG(bell,pitch) \
x x TKG(bell,duration)
} err] {TKGNotice $err}
}
if {![Empty TKG(bell,pitch)]} {
foreach param {percent pitch duration} {
set $param [expr int($TKG(bell,$param)*[set $param])]
}
if {$percent > 100} {set percent 100}
exec xset b $percent $pitch $duration
}
bell
if {![Empty TKG(bell,pitch)]} {
exec xset b $TKG(bell,percent) $TKG(bell,pitch) $TKG(bell,duration)
}
}
proc allAfterInfo {} {
foreach id [after info] {
lappend ret "[after info $id]\n"
}
return $ret
}