tkgoodstuff/tcl/Fvwm.tcl

387 lines
10 KiB
Tcl
Raw Normal View History

#Fvwm module interface for tkgoodstuff
proc FvwmDeclare {} {
TKGDeclare Fvwm(dostyle) 1 -vartype boolean \
-typelist [list General Fvwm]\
-label "Tell Fvwm to make tkgoodstuff stay on top, etc."\
-help {You can configure Fvwm to treat tkgoodstuff specially
by not giving it a title, borders, by letting it stay
on top, not including it in the window list or circulation
list, and so on. By default, when launched by fvwm, tkgoodstuff
tells fvwm to do all of this automatically.}
}
proc FvwmDoOnLoad {} {
if [info exists Fvwm(outid)] return
#ensure tkfvwm is loaded
package require Tkfvwm
# Set up communication with fvwm
if [catch "fvwm init [lindex $argv 0] [lindex $argv 1]" e] {
TKGError "Something went wrong trying to initialize communication with fvwm:
$e" exit
}
set Fvwm(outid) [lindex $argv 0]
if $Fvwm(dostyle) {
setifunset Fvwm(Style) {
"BorderWidth 0"
CirculateSkipIcon
CirculateSkip
ClickToFocus
NoTitle
NoHandles
Sticky
WindowListSkip
StaysOnTop
RandomPlacement
}
fvwm send $Fvwm(outid) "Style \"tkgoodstuff\" [join $Fvwm(Style) ,]"
unset Fvwm(Style)
}
bind TkgButton <1> "FvwmTkgbuttonStuff %W; [bind TkgButton <1>]"
TKGAddToHook TKG_alldone_hook FvwmTKGButtonInit
FvwmStart
}
# Set up bindings for fvwm messages, and ask fvwm for all window data
proc FvwmStart {} {
global Fvwm
fvwm AddWindow {FvwmAddWindow %W %f %x %y %w %h %t}
fvwm ConfigureWindow {FvwmConfigureWindow %W %f %x %y %w %h %t}
fvwm DestroyWindow {FvwmDestroyWindow %W}
fvwm WindowName {FvwmWindowName %W %N}
fvwm IconName {FvwmIconName %W %N}
fvwm ResName {FvwmResName %W %N}
fvwm ResClass {FvwmResClass %W %N}
fvwm NewPage {FvwmNewPage %X %Y %D %x %y}
fvwm NewDesk {FvwmNewDesk %T}
fvwm Map {FvwmMap %W}
fvwm Iconify {FvwmIconify %W %x %y %w %h}
fvwm IconLocation {FvwmIconLocation %W %x %y %w %h}
fvwm Deiconify {FvwmDeiconify %W}
fvwm FocusChange {FvwmFocusChange %W}
# fvwm IconFile {FvwmIconFile %W %N}
# fvwm DefaultIcon {FvwmDefaultIcon %W %N}
# fvwm String {FvwmString %N}
# fvwm MiniIcon {FvwmMiniIcon %W %N}
TKGDoHook FvwmStartHook
fvwm send $Fvwm(outid) Send_WindowList
}
# Cancel fvwm message binding while tkgoodstuff is redrawing
proc FvwmSuspend {} {
foreach c {
AddWindow ConfigureWindow DestroyWindow WindowName IconName
ResName ResClass NewPage NewDesk Map Iconify IconLocation
Deiconify FocusChange} {
fvwm $c {}
# Iconfile DefaultIcon String MiniIcon
}
}
proc FvwmCreateWindow {} {}
# Other clients (e.g., WWW) might call this
proc TKGExec {cmd {name ""}} {
FvwmNextOrExec $cmd $name
}
# A click on a sunken button takes us to next
# window of the appropriate name.
proc FvwmTkgbuttonStuff {w} {
if [string match [$w cget -relief] sunken] {
if ![Empty [set wn [$w cget -windowname]]] {
FvwmNext $wn
}
}
}
# Restarting an fvwm module requires telling fvwm to invoke it.
proc TKGRestart {} {
global Fvwm argv argv0
fvwm send $Fvwm(outid) \
"[file tail $argv0] [lreplace $argv 0 4]"
after 500
TKGQuit
}
# If we just exit, an fvwm bug can make fvwm race if we're leaving
# children (as of fvwm2-0-43).
proc TKGReallyQuit {} {
fvwm send 0 KillMe
exit
}
proc FvwmNextOrExec {cmd {name ""}} {
global Fvwm
if ![FvwmNext [list $name]] {
if [catch "exec $cmd &" err] {
TKGError $err
}
}
}
# We locate the next window in our list whose WindowName or ResClass
# matches one of the names, and goto it.
proc FvwmNext {{names ""} {incr 1}} {
global Fvwm FvwmWL FvwmW
if [info exists Fvwm(NextLast)] {
set current $Fvwm(NextLast)
} else {
set current $FvwmW(focus)
}
set wl [lsort [array names FvwmWL]]
set i [expr ([lsearch $wl $current] + $incr) % [llength $wl]]
set wl [concat [lrange $wl $i end] $wl]
foreach w $wl {
foreach name $names {
set name [string tolower [set name]*]
foreach vartype {windowname resname resclass} {
if [string match $name \
[string tolower $FvwmW($w,$vartype)]] {
set answer 1
break
}
}
if [info exists answer] break
}
if [info exists answer] break
}
if ![info exists answer] {
return 0
}
FvwmGoto $w
return 1
}
# We go to the right desk and page, and raise. If the window has a
# style flag set for ClickToFocus (2^10) or SloppyFocus (2^11) we give
# it focus (with MouseFocus focusing warps the pointer).
proc FvwmGoto {w} {
global Fvwm FvwmW
fvwm send $w {Iconify -1}
fvwm send $w {Raise ""}
fvwm send $Fvwm(outid) "Desk 0 $FvwmW($w,t)"
fvwm send $Fvwm(outid) "GotoPage $FvwmW($w,npagex) $FvwmW($w,npagey)"
if {$FvwmW($w,flags) & 3072} {
fvwm send $w "Focus"
}
set Fvwm(NextLast) $w
}
proc FvwmPrev {{name ""}} {FvwmNext $name -1}
# Code to maintain our own window database
proc FvwmAddWindow {id flags x y w h t} {
FvwmConfigureWindow $id $flags $x $y $w $h $t
TKGDoHook Fvwm_AddWindow_hook $id
}
proc FvwmConfigureWindow {id flags x y w h t} {
global FvwmW FvwmWL
if ![info exists FvwmW($id,iconic)] {set FvwmW($id,iconic) 0}
foreach var {flags x y w h t} {
set FvwmW($id,$var) [set $var]
}
set FvwmW($id,npagex) [expr ($x+$FvwmW(pagex))/[winfo vrootwidth .]]
if {$FvwmW($id,npagex)<0} {set FvwmW($id,npagex) 0}
set FvwmW($id,npagey) [expr ($y+$FvwmW(pagey))/[winfo vrootheight .]]
if {$FvwmW($id,npagey)<0} {set FvwmW($id,npagey) 0}
set FvwmWL($id) 0
TKGDoHook Fvwm_ConfigureWindow_hook $id
}
proc FvwmWindowName {id name} {
global FvwmW
set FvwmW($id,windowname) $name
# sometimes apparently resclass and resname don't get set
# if ![info exists FvwmW($id,resclass)] {
# set FvwmW($id,resclass) dummyclass
# set FvwmW($id,resname) dummyname
# }
FvwmTKGButtonCheck $name
TKGDoHook Fvwm_WindowName_hook $id
}
proc FvwmIconName {id name} {
global FvwmW
set FvwmW($id,iconname) $name
TKGDoHook Fvwm_IconName_hook $id
}
proc FvwmResName {id name} {
global FvwmW
set FvwmW($id,resname) $name
TKGDoHook Fvwm_ResName_hook $id
}
proc FvwmResClass {id name} {
global FvwmW
set FvwmW($id,resclass) $name
FvwmTKGButtonCheck $name
TKGDoHook Fvwm_ResClass_hook $id
}
proc FvwmDestroyWindow {id} {
global FvwmWL FvwmW
catch {unset FvwmWL($id)}
FvwmTKGButtonCheck $FvwmW($id,windowname)
FvwmTKGButtonCheck $FvwmW($id,resclass)
TKGDoHook Fvwm_DestroyWindow_hook $id
foreach index [array names FvwmW] {
if [string match $id, $index] {
unset FvwmW($index)
}
}
}
# For sticky windows, we get no configure message, so we recalc page
# on NewPage.
proc FvwmNewPage {X Y D x y} {
global Fvwm FvwmW FvwmWL
set FvwmW(pagex) $X
set FvwmW(pagey) $Y
set FvwmW(npagex) [expr $FvwmW(pagex)/[winfo vrootwidth .]]
set FvwmW(npagey) [expr $FvwmW(pagey)/[winfo vrootheight .]]
set FvwmW(desktop) $D
set FvwmW(maxpagex) $x
set FvwmW(maxpagey) $y
foreach id [array names FvwmWL] {
if {$FvwmW($id,flags) & 4} {
set FvwmW($id,npagex) [expr ($FvwmW($id,x)+$X)/[winfo vrootwidth .]]
if {$FvwmW($id,npagex)<0} {set FvwmW($id,npagex) 0}
set FvwmW($id,npagey) [expr ($FvwmW($id,y)+$Y)/[winfo vrootheight .]]
if {$FvwmW($id,npagey)<0} {set FvwmW($id,npagey) 0}
set FvwmW($id,t) $D
TKGDoHook Fvwm_ConfigureWindow_hook $id
}
}
TKGDoHook Fvwm_NewPage_hook
}
proc FvwmNewDesk {T} {
global FvwmW
set FvwmW(desktop) $T
TKGDoHook Fvwm_NewDesk_hook
}
proc FvwmIconify {id x y w h} {
global FvwmW
set FvwmW($id,iconic) 1
set FvwmW($id,iconlocx) $x
set FvwmW($id,iconlocy) $y
set FvwmW($id,iconw) $w
set FvwmW($id,iconh) $h
TKGDoHook Fvwm_Iconify_hook $id
}
proc FvwmIconLocation {id x y w h} {
global FvwmW
set FvwmW($id,iconx) $x
set FvwmW($id,icony) $y
set FvwmW($id,iconw) $w
set FvwmW($id,iconh) $h
TKGDoHook Fvwm_IconLocation_hook $id
}
proc FvwmDeiconify {id} {
global FvwmW
set FvwmW($id,iconic) 0
TKGDoHook Fvwm_Deiconify_hook $id
}
proc FvwmFocusChange {id} {
global FvwmW
set FvwmW(focus) $id
TKGDoHook Fvwm_FocusChange_hook $id
}
proc FvwmMap {id} {
global FvwmW
set FvwmW($id,mapped) 1
TKGDoHook Fvwm_Map_hook $id
}
proc FvwmIconFile {id file} {
global FvwmW
set FvwmW($id,iconfile) $file
TKGDoHook Fvwm_IconFile_hook $id
}
proc FvwmMiniIcon {id file} {
REPORT id file
global FvwmW
set FvwmW($id,miniicon) $file
TKGDoHook Fvwm_MiniIcon_hook $id
}
proc FvwmDefaultIcon {id icon} {
global FvwmW
set FvwmW($id,defaulticon) $icon
TKGDoHook Fvwm_DefaultIcon_hook $id
}
# Fvwm can now send modules an arbitrary string
proc FvwmString {s} {
TKGDoHook Fvwm_String_hook $s
}
# Utilities used by TKGButtons
# Check if any windows with windowname or resclass matching pattern
proc FvwmAnyWindowsOfName {pattern} {
global FvwmWL FvwmW
set somewins 0
foreach id [array names FvwmWL] {
if {[string match $pattern $FvwmW($id,windowname)]
|| [string match $pattern $FvwmW($id,resclass)]} {
set somewins 1
break
}
}
return $somewins
}
# Check if any TKGButton is looking for a window with
# windowname or resclass of name.
proc FvwmTKGButtonCheck {name} {
global FvwmWL FvwmW Fvwm_trackbuttons
foreach pattern [array names Fvwm_trackbuttons] {
if [string match $pattern $name] {
FvwmTKGButtonTrack $pattern
}
}
}
# Set relief of all TKGButtons tracking pattern
proc FvwmTKGButtonTrack {pattern} {
global Fvwm_trackbuttons TKG
if [FvwmAnyWindowsOfName $pattern] {
set relief sunken
} else {
set relief notsunken
}
foreach buttonname $Fvwm_trackbuttons($pattern) {
upvar \#0 $buttonname-params P
if [winfo exists $P(pathname)] {
if {[string match notsunken $relief]} {
set relief $P(relief)
if {[Empty $relief]} {
set relief $TKG(butrelief)
}
}
$P(pathname) configure -relief $relief
}
}
}
# Set relief of all TKGButtons
proc FvwmTKGButtonInit {} {
foreach pattern [array names Fvwm_trackbuttons] {
FvwmTKGButtonTrack $pattern
}
}
DEBUG "We're an fvwm module. Loaded Fvwm.tcl"