451 lines
16 KiB
Tcl
451 lines
16 KiB
Tcl
|
#
|
||
|
|
# Copyright (c) 1993 by Sven Delmas
|
||
|
|
# All rights reserved.
|
||
|
|
# See the file COPYRIGHT for the copyright notes.
|
||
|
|
|
||
|
|
global tkSteal_priv
|
||
|
|
set tkSteal_priv(debug) 0
|
||
|
|
|
||
|
|
# this proc is taken from the beta code of the toolbox
|
||
|
|
proc tkSteal_getarg {opts arg var} {
|
||
|
|
set ind [lsearch $opts [concat $arg *]]
|
||
|
|
if {$ind==-1} {
|
||
|
|
error "ARG ERROR: application tried to find nonexistend arg \"$arg\"!"
|
||
|
|
}
|
||
|
|
# The variable named var will contain the value.
|
||
|
|
upvar 1 $var varr
|
||
|
|
set varr [lindex [lindex $opts $ind] 4]
|
||
|
|
if {"[lindex [lindex $opts $ind] 3]" ==
|
||
|
|
"[lindex [lindex $opts $ind] 4]"} {
|
||
|
|
return 0
|
||
|
|
} {
|
||
|
|
return 1
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
# this proc is taken from the beta code of the toolbox
|
||
|
|
proc tkSteal_parseargs {cmdline descr args} {
|
||
|
|
if {$args!=""} {upvar 1 [lindex $args 0] changed}
|
||
|
|
set changed {}
|
||
|
|
for {set i 0} {$i<[llength $cmdline]} {incr i} {
|
||
|
|
set name [lindex $cmdline $i]
|
||
|
|
while {[llength $name]>0} {
|
||
|
|
if {[llength $name]==1} {
|
||
|
|
set value [lindex $cmdline [expr $i+1]]
|
||
|
|
incr i
|
||
|
|
} else {
|
||
|
|
set value [lindex $name 1]
|
||
|
|
set name [lindex $name 0]
|
||
|
|
}
|
||
|
|
# Find option
|
||
|
|
set ind [lsearch $descr [concat $name *]]
|
||
|
|
if {$ind==-1} {
|
||
|
|
set ind [lsearch $descr $name]
|
||
|
|
if {$ind==-1} {
|
||
|
|
error "unknown option \"$name\""
|
||
|
|
}
|
||
|
|
}
|
||
|
|
lappend changed $name
|
||
|
|
# Enter value
|
||
|
|
set descr [lreplace $descr $ind $ind \
|
||
|
|
[lreplace [lindex $descr $ind] 4 4 $value]]
|
||
|
|
set name [lreplace $name 0 1]
|
||
|
|
}
|
||
|
|
}
|
||
|
|
# New optlist
|
||
|
|
set new {}
|
||
|
|
foreach item $descr {
|
||
|
|
if {[llength $item]<=5} {
|
||
|
|
lappend new $item
|
||
|
|
} else {
|
||
|
|
# XXX Maybe should demand the default to be in ready format...
|
||
|
|
# So the exec. time might be a LITTLE faster.
|
||
|
|
#
|
||
|
|
# Eval the type getting actions.
|
||
|
|
set act [lindex $item 5]
|
||
|
|
regsub -all "%\(value\)" $act [lindex $item 3] act
|
||
|
|
set item [lreplace $item 3 3 [eval $act]]
|
||
|
|
set act [lindex $item 5]
|
||
|
|
regsub -all "%\(value\)" $act [lindex $item 4] act
|
||
|
|
lappend new [lreplace $item 4 4 [eval $act]]
|
||
|
|
}
|
||
|
|
}
|
||
|
|
return $new
|
||
|
|
}
|
||
|
|
|
||
|
|
global tkSteal_ARGUMENTS
|
||
|
|
set tkSteal_ARGUMENTS {
|
||
|
|
{-background background Background #d9d9d9 #d9d9d9}
|
||
|
|
{-borderwidth borderWidth BorderWidth 0 0}
|
||
|
|
{-command command Command {} {}}
|
||
|
|
{-foreground foreground Foreground black black}
|
||
|
|
{-font font Font *-Courier-Medium-R-Normal-*-120-* *-Courier-Medium-R-Normal-*-120-*}
|
||
|
|
{-name name Name {} {}}
|
||
|
|
{-height height Height 20 20}
|
||
|
|
{-relief relief Relief flat flat}
|
||
|
|
{-stealwindowid stealWindowId WindowId 0 0}
|
||
|
|
{-takefocus takeFocus TakeFocus 0 0}
|
||
|
|
{-type type Type frame frame}
|
||
|
|
{-width width Width 20 20}
|
||
|
|
{-windowid windowId WindowId {} {}}}
|
||
|
|
|
||
|
|
proc tkSteal {pathName args} {
|
||
|
|
# CBInfo: autoload
|
||
|
|
|
||
|
|
global tk_library
|
||
|
|
global tkSteal_priv
|
||
|
|
global tkSteal_ARGUMENTS
|
||
|
|
|
||
|
|
# check if interpreter can access X
|
||
|
|
catch "xaccess" result
|
||
|
|
if {![string match "wrong # args*" $result]} {
|
||
|
|
error "tkSteal: the command xaccess is not available"
|
||
|
|
}
|
||
|
|
|
||
|
|
# initialize the data
|
||
|
|
set tkSteal_priv($pathName,initialized) 0
|
||
|
|
set tkSteal_priv($pathName,pid) 0
|
||
|
|
set tkSteal_priv($pathName,config) \
|
||
|
|
[tkSteal_parseargs $args $tkSteal_ARGUMENTS]
|
||
|
|
|
||
|
|
# main frame
|
||
|
|
frame $pathName -borderwidth 0 -class TkSteal
|
||
|
|
rename $pathName $pathName-internal
|
||
|
|
proc $pathName args "
|
||
|
|
return \[eval tkSteal_command $pathName \$args\]"
|
||
|
|
|
||
|
|
set index [lsearch $args -type]
|
||
|
|
if {$index != -1 && "[lindex $args [expr $index + 1]]" == "frame"} {
|
||
|
|
frame $pathName.cbl -borderwidth 0
|
||
|
|
} {
|
||
|
|
label $pathName.cbl -borderwidth 0 -padx 1 -pady 1
|
||
|
|
}
|
||
|
|
rename $pathName.cbl $pathName-cblinternal
|
||
|
|
proc $pathName.cbl args "
|
||
|
|
return \[eval tkSteal_command $pathName \$args\]"
|
||
|
|
pack $pathName.cbl -side top -fill both -expand 1
|
||
|
|
|
||
|
|
bind $pathName.cbl <Map> "
|
||
|
|
tkSteal_start $pathName"
|
||
|
|
bind $pathName.cbl <Destroy> "
|
||
|
|
tkSteal_stop $pathName"
|
||
|
|
bind $pathName.cbl <Expose> "
|
||
|
|
$pathName redisplay"
|
||
|
|
bind $pathName.cbl <Configure> "
|
||
|
|
$pathName redisplay"
|
||
|
|
bind $pathName.cbl <Leave> "
|
||
|
|
$pathName redisplay"
|
||
|
|
|
||
|
|
eval $pathName config $args
|
||
|
|
}
|
||
|
|
|
||
|
|
proc tkSteal_start {pathName} {
|
||
|
|
global env
|
||
|
|
global tkSteal_priv
|
||
|
|
|
||
|
|
if {$tkSteal_priv($pathName,initialized) || "$pathName" == ""} {
|
||
|
|
return
|
||
|
|
}
|
||
|
|
|
||
|
|
tkSteal_getarg $tkSteal_priv($pathName,config) -background background
|
||
|
|
tkSteal_getarg $tkSteal_priv($pathName,config) -borderwidth borderwidth
|
||
|
|
tkSteal_getarg $tkSteal_priv($pathName,config) -foreground foreground
|
||
|
|
tkSteal_getarg $tkSteal_priv($pathName,config) -font font
|
||
|
|
tkSteal_getarg $tkSteal_priv($pathName,config) -command command
|
||
|
|
tkSteal_getarg $tkSteal_priv($pathName,config) -name name
|
||
|
|
tkSteal_getarg $tkSteal_priv($pathName,config) -height height
|
||
|
|
tkSteal_getarg $tkSteal_priv($pathName,config) -relief relief
|
||
|
|
tkSteal_getarg $tkSteal_priv($pathName,config) -type type
|
||
|
|
tkSteal_getarg $tkSteal_priv($pathName,config) -width width
|
||
|
|
tkSteal_getarg $tkSteal_priv($pathName,config) -stealwindowid stealwindowid
|
||
|
|
tkSteal_getarg $tkSteal_priv($pathName,config) -windowid windowid
|
||
|
|
|
||
|
|
# run command
|
||
|
|
if {"$command" != ""} {
|
||
|
|
set newCommand $command
|
||
|
|
regsub -all {\$background} $newCommand $background newCommand
|
||
|
|
regsub -all {\$foreground} $newCommand $foreground newCommand
|
||
|
|
regsub -all {\$font} $newCommand $font newCommand
|
||
|
|
regsub -all {\$relief} $newCommand $relief newCommand
|
||
|
|
regsub -all {\$width} $newCommand $width newCommand
|
||
|
|
regsub -all {\$height} $newCommand $height newCommand
|
||
|
|
regsub -all {\$name} $newCommand $name newCommand
|
||
|
|
regsub -all {\$windowid} $newCommand $windowid newCommand
|
||
|
|
regsub -all {\$stealwindowid} $newCommand [format %ld [winfo id $pathName.cbl]] newCommand
|
||
|
|
regsub -all {\$\{background\}} $newCommand $background newCommand
|
||
|
|
regsub -all {\$\{foreground\}} $newCommand $foreground newCommand
|
||
|
|
regsub -all {\$\{font\}} $newCommand $font newCommand
|
||
|
|
regsub -all {\$\{relief\}} $newCommand $relief newCommand
|
||
|
|
regsub -all {\$\{width\}} $newCommand $width newCommand
|
||
|
|
regsub -all {\$\{height\}} $newCommand $height newCommand
|
||
|
|
regsub -all {\$\{name\}} $newCommand $name newCommand
|
||
|
|
regsub -all {\$\{windowid\}} $newCommand $windowid newCommand
|
||
|
|
regsub -all {\$\{stealwindowid\}} $newCommand [format %ld [winfo id $pathName.cbl]] newCommand
|
||
|
|
|
||
|
|
#MDC
|
||
|
|
#Added for tkgoodstuff to allow fvwm modules to be swallowed, etc.
|
||
|
|
global Fvwm
|
||
|
|
if {[info exists Fvwm(outid)] && [string match Fvwm* $newCommand]} {
|
||
|
|
lappend finalCommand fvwm send 0 "Module $newCommand"
|
||
|
|
} elseif {[string match "Tcl *" $newCommand]} {
|
||
|
|
set finalCommand [string range $newCommand 4 end]
|
||
|
|
} else {
|
||
|
|
set finalCommand "eval exec $newCommand &"
|
||
|
|
}
|
||
|
|
|
||
|
|
if {[catch $finalCommand result]} {
|
||
|
|
error $result
|
||
|
|
} {
|
||
|
|
set tkSteal_priv($pathName,pid) $result
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
$pathName-internal conf -background $background
|
||
|
|
$pathName-internal conf -borderwidth $borderwidth
|
||
|
|
$pathName-internal conf -relief $relief
|
||
|
|
$pathName-cblinternal conf -background $background
|
||
|
|
if {"$type" != "frame"} {
|
||
|
|
$pathName-cblinternal conf -padx 0
|
||
|
|
$pathName-cblinternal conf -pady 0
|
||
|
|
}
|
||
|
|
if {"$width" != "" && $width != 0} {
|
||
|
|
$pathName-cblinternal conf -width $width
|
||
|
|
}
|
||
|
|
if {"$height" != "" && $height != 0} {
|
||
|
|
$pathName-cblinternal conf -height $height
|
||
|
|
}
|
||
|
|
$pathName conf -stealwindowid [format %ld [winfo id $pathName.cbl]]
|
||
|
|
|
||
|
|
if {"$windowid" != ""} {
|
||
|
|
if {[catch "xaccess eventreparent -parentwidget $pathName.cbl -windowid $windowid" ret]} {
|
||
|
|
error "tkSteal_start: $ret"
|
||
|
|
}
|
||
|
|
} {
|
||
|
|
if {"$name" != ""} {
|
||
|
|
if {![catch "xaccess eventreparent -parentwidget $pathName.cbl -windowname \{$name\}" ret]} {
|
||
|
|
$pathName conf -windowid $ret
|
||
|
|
} {
|
||
|
|
error "tkSteal_start: $ret"
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
set tkSteal_priv($pathName,initialized) 1
|
||
|
|
after 2000 $pathName redisplay
|
||
|
|
}
|
||
|
|
|
||
|
|
proc tkSteal_stop {pathName} {
|
||
|
|
global tkSteal_priv
|
||
|
|
|
||
|
|
catch "rename $pathName-internal \"\""
|
||
|
|
catch "rename $pathName-cblinternal \"\""
|
||
|
|
if {$tkSteal_priv($pathName,pid) != 0} {
|
||
|
|
catch "exec kill $tkSteal_priv($pathName,pid)"
|
||
|
|
set tkSteal_priv($pathName,pid) 0
|
||
|
|
}
|
||
|
|
set tkSteal_priv($pathName,initialized) 0
|
||
|
|
return ""
|
||
|
|
}
|
||
|
|
|
||
|
|
proc tkSteal_command {pathName minorCommand args} {
|
||
|
|
global tkSteal_priv
|
||
|
|
|
||
|
|
case $minorCommand {
|
||
|
|
{conf*} {
|
||
|
|
if {[llength $args] == 0} {
|
||
|
|
set result ""
|
||
|
|
foreach element $tkSteal_priv($pathName,config) {
|
||
|
|
lappend result [list [lindex $element 0] [lindex $element 1] [lindex $element 2] [lindex $element 3] [lindex $element 4]]
|
||
|
|
}
|
||
|
|
return $result
|
||
|
|
} {
|
||
|
|
if {[llength $args] == 1} {
|
||
|
|
set resourceIndex [lsearch $tkSteal_priv($pathName,config) $args*]
|
||
|
|
if {$resourceIndex != -1} {
|
||
|
|
set element [lindex $tkSteal_priv($pathName,config) $resourceIndex]
|
||
|
|
return [list [lindex $element 0] [lindex $element 1] [lindex $element 2] [lindex $element 3] [lindex $element 4]]
|
||
|
|
} {
|
||
|
|
error "unknown resource: $args"
|
||
|
|
}
|
||
|
|
} {
|
||
|
|
set tkSteal_priv($pathName,config) \
|
||
|
|
[tkSteal_parseargs $args $tkSteal_priv($pathName,config)]
|
||
|
|
for {set counter 0} {$counter < [llength $args]} {incr counter} {
|
||
|
|
case [lindex $args $counter] {
|
||
|
|
{-back*} {
|
||
|
|
tkSteal_getarg $tkSteal_priv($pathName,config) \
|
||
|
|
-background background
|
||
|
|
$pathName-internal conf -background $background
|
||
|
|
$pathName-cblinternal conf -background $background
|
||
|
|
}
|
||
|
|
{-border*} {
|
||
|
|
tkSteal_getarg $tkSteal_priv($pathName,config) \
|
||
|
|
-borderwidth borderwidth
|
||
|
|
$pathName-internal conf -borderwidth $borderwidth
|
||
|
|
}
|
||
|
|
{-reli*} {
|
||
|
|
tkSteal_getarg $tkSteal_priv($pathName,config) \
|
||
|
|
-relief relief
|
||
|
|
$pathName-internal conf -relief $relief
|
||
|
|
}
|
||
|
|
{-heig*} {
|
||
|
|
tkSteal_getarg $tkSteal_priv($pathName,config) \
|
||
|
|
-height height
|
||
|
|
$pathName-cblinternal conf -height $height
|
||
|
|
}
|
||
|
|
{-widt*} {
|
||
|
|
tkSteal_getarg $tkSteal_priv($pathName,config) \
|
||
|
|
-width width
|
||
|
|
$pathName-cblinternal conf -width $width
|
||
|
|
}
|
||
|
|
}
|
||
|
|
incr counter
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
{focusin} {
|
||
|
|
if {$tkSteal_priv($pathName,initialized)} {
|
||
|
|
tkSteal_getarg $tkSteal_priv($pathName,config) \
|
||
|
|
-windowid windowid
|
||
|
|
catch "xaccess eventfocusin \
|
||
|
|
-windowid $windowid"
|
||
|
|
}
|
||
|
|
}
|
||
|
|
{focusout} {
|
||
|
|
if {$tkSteal_priv($pathName,initialized)} {
|
||
|
|
tkSteal_getarg $tkSteal_priv($pathName,config) \
|
||
|
|
-windowid windowid
|
||
|
|
catch "xaccess eventfocusout \
|
||
|
|
-windowid $windowid"
|
||
|
|
}
|
||
|
|
}
|
||
|
|
{redi*} {
|
||
|
|
if {$tkSteal_priv($pathName,initialized)} {
|
||
|
|
tkSteal_getarg $tkSteal_priv($pathName,config) \
|
||
|
|
-windowid windowid
|
||
|
|
catch "xaccess eventconfigure \
|
||
|
|
-windowid $windowid \
|
||
|
|
-borderwidth 0 \
|
||
|
|
-x [winfo rootx [winfo toplevel $pathName]] \
|
||
|
|
-y [winfo rooty [winfo toplevel $pathName]] \
|
||
|
|
-width [winfo width $pathName.cbl] \
|
||
|
|
-height [winfo height $pathName.cbl]"
|
||
|
|
}
|
||
|
|
}
|
||
|
|
{buttonclick} {
|
||
|
|
if {[llength $args] != 1 && [llength $args] != 2} {
|
||
|
|
error "wrong # of args: should be \"$pathName buttonclick button ?state?\""
|
||
|
|
}
|
||
|
|
tkSteal_getarg $tkSteal_priv($pathName,config) \
|
||
|
|
-windowid windowid
|
||
|
|
if {[llength $args] == 1} {
|
||
|
|
catch "xaccess eventbuttonpress -windowid $windowid -button [lindex $args 0]"
|
||
|
|
catch "xaccess eventbuttonrelease -windowid $windowid -button [lindex $args 0]"
|
||
|
|
} {
|
||
|
|
catch "xaccess eventbuttonpress -windowid $windowid -button [lindex $args 0] -state [lindex $args 1]"
|
||
|
|
catch "xaccess eventbuttonrelease -windowid $windowid -button [lindex $args 0] -state [lindex $args 1]"
|
||
|
|
}
|
||
|
|
}
|
||
|
|
{buttonpress} {
|
||
|
|
if {[llength $args] != 1 && [llength $args] != 2} {
|
||
|
|
error "wrong # of args: should be \"$pathName buttonpress button ?state?\""
|
||
|
|
}
|
||
|
|
tkSteal_getarg $tkSteal_priv($pathName,config) \
|
||
|
|
-windowid windowid
|
||
|
|
if {[llength $args] == 1} {
|
||
|
|
catch "xaccess eventbuttonpress -windowid $windowid -button [lindex $args 0]"
|
||
|
|
} {
|
||
|
|
catch "xaccess eventbuttonpress -windowid $windowid -button [lindex $args 0] -state [lindex $args 1]"
|
||
|
|
}
|
||
|
|
}
|
||
|
|
{buttonrelease} {
|
||
|
|
if {[llength $args] != 1 && [llength $args] != 2} {
|
||
|
|
error "wrong # of args: should be \"$pathName buttonpress button ?state?\""
|
||
|
|
}
|
||
|
|
tkSteal_getarg $tkSteal_priv($pathName,config) \
|
||
|
|
-windowid windowid
|
||
|
|
if {[llength $args] == 1} {
|
||
|
|
catch "xaccess eventbuttonrelease -windowid $windowid -button [lindex $args 0]"
|
||
|
|
} {
|
||
|
|
catch "xaccess eventbuttonrelease -windowid $windowid -button [lindex $args 0] -state [lindex $args 1]"
|
||
|
|
}
|
||
|
|
}
|
||
|
|
{keyclick} {
|
||
|
|
if {[llength $args] != 1 && [llength $args] != 2} {
|
||
|
|
error "wrong # of args: should be \"$pathName keytype keycode ?state?\""
|
||
|
|
}
|
||
|
|
tkSteal_getarg $tkSteal_priv($pathName,config) \
|
||
|
|
-windowid windowid
|
||
|
|
if {[llength $args] == 1} {
|
||
|
|
catch "xaccess eventkeypress -windowid $windowid -keycode [lindex $args 0]"
|
||
|
|
catch "xaccess eventkeyrelease -windowid $windowid -keycode [lindex $args 0]"
|
||
|
|
} {
|
||
|
|
catch "xaccess eventkeypress -windowid $windowid -keycode [lindex $args 0] -state [lindex $args 1]"
|
||
|
|
catch "xaccess eventkeyrelease -windowid $windowid -keycode [lindex $args 0] -state [lindex $args 1]"
|
||
|
|
}
|
||
|
|
}
|
||
|
|
{keypress} {
|
||
|
|
if {[llength $args] != 1 && [llength $args] != 2} {
|
||
|
|
error "wrong # of args: should be \"$pathName keypress keycode ?state?\""
|
||
|
|
}
|
||
|
|
tkSteal_getarg $tkSteal_priv($pathName,config) \
|
||
|
|
-windowid windowid
|
||
|
|
if {[llength $args] == 1} {
|
||
|
|
catch "xaccess eventkeypress -windowid $windowid -keycode [lindex $args 0]"
|
||
|
|
} {
|
||
|
|
catch "xaccess eventkeypress -windowid $windowid -keycode [lindex $args 0] -state [lindex $args 1]"
|
||
|
|
}
|
||
|
|
}
|
||
|
|
{keyrelease} {
|
||
|
|
if {[llength $args] != 1 && [llength $args] != 2} {
|
||
|
|
error "wrong # of args: should be \"$pathName keyrelease keycode ?state?\""
|
||
|
|
}
|
||
|
|
tkSteal_getarg $tkSteal_priv($pathName,config) \
|
||
|
|
-windowid windowid
|
||
|
|
if {[llength $args] == 1} {
|
||
|
|
catch "xaccess eventkeyrelease -windowid $windowid -keycode [lindex $args 0]"
|
||
|
|
} {
|
||
|
|
catch "xaccess eventkeyrelease -windowid $windowid -keycode [lindex $args 0] -state [lindex $args 1]"
|
||
|
|
}
|
||
|
|
}
|
||
|
|
{sendstring} {
|
||
|
|
if {[llength $args] != 1 && [llength $args] != 2} {
|
||
|
|
error "wrong # of args: should be \"$pathName sendstring string ?interval?\""
|
||
|
|
}
|
||
|
|
tkSteal_getarg $tkSteal_priv($pathName,config) \
|
||
|
|
-windowid windowid
|
||
|
|
if {[llength $args] == 1} {
|
||
|
|
catch "xaccess sendstring -windowid $windowid -data \{[lindex $args 0]\}"
|
||
|
|
} {
|
||
|
|
catch "xaccess sendstring -windowid $windowid -data \{[lindex $args 0]\} -interval [lindex $args 1]"
|
||
|
|
}
|
||
|
|
}
|
||
|
|
{motion} {
|
||
|
|
if {[llength $args] != 1 && [llength $args] != 2} {
|
||
|
|
error "wrong # of args: should be \"$pathName motion x y\""
|
||
|
|
}
|
||
|
|
tkSteal_getarg $tkSteal_priv($pathName,config) \
|
||
|
|
-windowid windowid
|
||
|
|
catch "xaccess eventmotion -windowid $windowid -x [lindex $args 0] -y [lindex $args 1]"
|
||
|
|
}
|
||
|
|
{stoptksteal} {
|
||
|
|
if {[llength $args] != 0} {
|
||
|
|
error "wrong # of args: should be \"$pathName stoptksteal\""
|
||
|
|
}
|
||
|
|
tkSteal_stop $pathName
|
||
|
|
}
|
||
|
|
}
|
||
|
|
return ""
|
||
|
|
}
|
||
|
|
|
||
|
|
proc tkSteal_redisplay {pathName} {
|
||
|
|
global tkSteal_priv
|
||
|
|
|
||
|
|
if {$tkSteal_priv($pathName,initialized)} {
|
||
|
|
$pathName redisplay
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
# eof
|
||
|
|
|