1 package require Tcl 8.0 ;# we need binary command
4 # Define fvwm message types of fvwm95-2.0.43
37 536870912 NewAddWindow
38 1073741824 NewConfigureWindow
39 2147483648 UnknownMessage
40 -2147483647 UnknownMessage1
41 -2147483646 UnknownMessage2
42 -2147483645 UnknownMessage3
43 -2147483644 UnknownMessage4
44 -2147483640 UnknownMessage8
48 array set gravityText {
62 foreach {code name} [array get msgType] {
63 set msgCodes($name) $code
64 set AllEvents [expr $AllEvents|$code]
66 set msgCodes(DeadPipe) 0
67 variable WindowListMask [expr $msgCodes(End_WindowList)|\
68 $msgCodes(NewDesk)|$msgCodes(NewPage)| $msgCodes(FocusChange)|\
69 $msgCodes(DefaultIcon)|$msgCodes(ConfigureWindow)|\
70 $msgCodes(WindowName)|$msgCodes(IconName)| $msgCodes(ResName)|\
71 $msgCodes(ResClass)|$msgCodes(IconFile)|$msgCodes(MiniIcon)]
72 variable MessagesWithString [expr $msgCodes(WindowName)|$msgCodes(IconName)|\
73 $msgCodes(ResClass)|$msgCodes(ResName)|$msgCodes(Error)|\
74 $msgCodes(ConfigInfo)|$msgCodes(String)|$msgCodes(DefaultIcon)|\
75 $msgCodes(IconFile)|$msgCodes(MiniIcon)|$msgCodes(VisibleName)]
77 # Find out how to format binary integers
78 # Note, on 64-bit platform there should be 64bit integer
81 if {$::tcl_platform(byteOrder)=="littleEndian"} {
86 if {$::argc<5||![regexp {[0-9]+} [lindex $::argv 0]]||
87 ![regexp {[0-9]+} [lindex $::argv 1]]||
88 ! [regexp {[0-9]+} [lindex $::argv 3]]||
89 ![regexp {[0-9]+} [lindex $::argv 4]]} {
90 error "Should be started as fvwm module" {FVWM 0 "Invalid invocation"}
92 if {[catch {package require Tclx}]} {
93 if {[string equal $tcl_platform(os) Linux]} {
94 variable outfd [open /dev/fd/[lindex $::argv 0] w]
95 variable infd [open /dev/fd/[lindex $::argv 1] r]
97 error "Tclx is required for all systems except Linux"
100 variable outfd [dup [lindex $::argv 0]]
101 variable infd [dup [lindex $::argv 1]]
103 if {[info tclversion]>=8.1} {
104 fconfigure $outfd -buffering none -translation binary -encoding binary
105 fconfigure $infd -buffering none -blocking yes -translation binary -encoding binary
106 proc get_eventString {infd stringLen} {
107 return [encoding convertfrom [lindex [split [read $infd $stringLen] "\0"] 0]]
110 fconfigure $outfd -buffering none -translation binary
111 fconfigure $infd -buffering none -blocking yes -translation binary
112 proc get_eventString {infd stringLen} {
113 return [lindex [split [read $infd $stringLen] "\0"] 0]
116 variable configFile [lindex $::argv 2]
117 variable WindowId [lindex $::argv 3]
119 variable Mask $AllEvents
120 switch [lindex $::argv 4] {
121 0 {set Context NO_CONTEXT}
122 1 {set Context WINDOW}
123 2 {set Context TITLE}
126 16 {set Context FRAME}
127 32 {set Context SIDEBAR}
128 64 {set Context LEFT1}
129 128 {set Context LEFT2}
130 256 {set Context LEFT3}
131 512 {set Context LEFT4}
132 1024 {set Context LEFT5}
133 2048 {set Context RIGHT1}
134 4096 {set Context RIGHT2}
135 8192 {set Context RIGHT3}
136 16384 {set Context RIGHT4}
137 32768 {set Context RIGHT5}
138 default {set Context Unknown}
141 set ::argv {lrange 5 end $::argv}
145 DeadPipe ::fvwm::myExit
152 # Send message to fvwm
154 proc send {message {window 0}} {
157 puts -nonewline $outfd [binary format ${intFormat}2 \
158 [list $window [string length $message]]]
159 puts -nonewline $outfd $message
160 puts -nonewline $outfd [binary format $intFormat 1]
163 # Used for special event handling during list asquition
165 variable internalHandler ""
168 # Indicates that list is done
172 # Fileevent handler for fvwm input pipe
177 variable internalHandler
182 set event [ReadMessage]
183 set type [lindex $event 0]
186 # Process getting list specially
188 if [string length $internalHandler] {
189 eval $internalHandler $event
192 if [info exist handlers($type)] {
193 namespace eval :: "$handlers($type) $event"
197 # Parses fvwm message and converts it to list
199 proc ReadMessage {} {
204 variable MessagesWithString
205 variable internalHandler
206 binary scan [read $infd $intSize] $intFormat sign
207 binary scan [read $infd $intSize] $intFormat type
208 binary scan [read $infd $intSize] $intFormat len
209 binary scan [read $infd $intSize] $intFormat timestamp
210 if {[eof $infd] && ![ info exist type]} {
214 if {![info exist msgType($type)]} {
215 after idle [list error "Unknown message type [format %x $type]" {} [list FVWM 1 $type "Unknown message"]]
216 set msgType($type) $type
218 set event $msgType($type)
219 if {($type & $MessagesWithString) !=0} {
220 set stringLen [expr ($len-7)*$intSize]
223 for {set i 4} {$i<$len} {incr i} {
224 binary scan [read $infd 4] $intFormat value
228 lappend event [get_eventString $infd $stringLen]
235 # setMask - set event mask for fvwm
240 if {[llength $list]==1&&![catch {expr $list+1}]} {
241 #mask is numeric. Suppose user knows what he does
242 send "Set_Mask $list"
248 if {![info exist msgCodes($type)]} {
249 return -code error -errorcode [list FVWM 3 $type "Invalid event"]\
250 "Invalid event name $type"
252 set value [expr {$value|$msgCodes($type)}]
254 send "Set_Mask $value"
258 # Binds handler to specific event
263 if ![llength $args] {
264 return [array names handlers]
266 set type [lindex $args 0]
267 if ![info exist msgCodes($type)] {
268 return -code error -errorcode [list FVWM 3 $type "Invalid event"]\
269 "Invalid event name $type"
271 if [llength $args]==1 {
272 if [info exist handlers($type)] {
273 return $handlers($type)
278 if {![llength $args]>2} {
279 return -code error -errorcode NONE "Wrong # args should be \
280 ::fvwm::bind event script"
282 set handlers($type) [lindex $args 1]
289 # configHandler - internal procedure which handles config
292 proc configHandler {type args} {
293 variable configPattern
295 variable internalHandler
296 if {$type=="End_ConfigInfo"} {
297 uplevel \#0 set ::fvwm::listDone 1
298 } elseif {$type=="ConfigInfo"} {
299 regsub "\[\t\n\r \]*$" [lindex $args 3] "" line
300 if {[regexp "\\*(\[a-zA-Z0-9_-\]+)\[ \t\]*(.*)\$" $line junk name value]} {
301 if [string match $configPattern $name] {
302 lappend listToFill($name) $value
304 } elseif {[regexp "(\[a-zA-Z0-9_-\]+)\[ \t\]*(.*)\$" $line junk\
306 if [string match *Path $name] {
307 eval lappend listToFill($name) [split $value ":"]
309 lappend listToFill($name) $value
315 # getConfig - requests from fvwm configuration info and fills given
318 proc getConfig {array {pattern *}} {
320 variable configPattern
323 variable internalHandler
327 set myMask [expr $msgCodes(ConfigInfo)|$msgCodes(End_ConfigInfo)]
328 if {($Mask&$myMask)!=$myMask} {
329 send "Set_Mask $myMask"
331 set configPattern $pattern
332 set internalHandler configHandler
333 send "Send_ConfigInfo"
334 vwait ::fvwm::listDone
335 set internalHandler ""
336 if [info exists listToFill(PixmapPath)] {
337 set PixmapPath $listToFill(PixmapPath)
341 if [info exists listToFill(IconPath)] {
342 set IconPath $listToFill(IconPath)
346 uplevel array set $array [list [array get listToFill]]
348 if {($Mask&$myMask)!=$myMask} {
349 send "Set_Mask $Mask"
353 # winListHandler - handles various events which fvwm sends in response
356 proc winListHandler {type args} {
361 End_WindowList {uplevel #0 set ::fvwm::listDone 1}
362 NewDesk {set listToFill(Desk) [lindex $args 0]}
364 set listToFill(Page) [concat [lrange $args 0 1] [lrange $args 2 3]]
367 set listToFill(Focus) [lindex $args 0]
368 # Don't know how to convert fvwm color info to something
370 # set listToFill(FocusColors) [list\
371 # [format "#%06x" [lindex $args 1]]\
372 # [format "#%06x" [lindex $args 2]]]
374 DefaultIcon {set listToFill(DefaultIcon) [lindex $args 3]}
376 set windowId [lindex $args 0]
377 set listToFill($windowId,frame) [concat [lindex $args 1]\
378 [lrange $args 3 6] [lrange $args 9 10]]
379 set listToFill($windowId,desk) [lindex $args 7]
380 set listToFill($windowId,flags) [lindex $args 8]
381 set listToFill($windowId,base) [lrange $args 11 12]
382 set listToFill($windowId,grid) [lrange $args 13 14]
383 set listToFill($windowId,minSize) [lrange $args 15 16]
384 set listToFill($windowId,maxSize) [lrange $args 17 18]
385 set listToFill($windowId,iconIds) [lrange $args 19 20]
386 set listToFill($windowId,gravity) $gravityText([lindex $args 22])
387 # set listToFill($windowId,colors) [list\
388 # [format "#%06x" [lindex $args 22]]\
389 # [format "#%06x" [lindex $args 23]]]
392 set windowId [lindex $args 0]
393 set listToFill($windowId,frame) [concat [lindex $args 1]\
394 [lrange $args 3 6] [lrange $args 9 10]]
395 set listToFill($windowId,desk) [lindex $args 7]
396 set listToFill($windowId,flags) [lindex $args 26]
397 set listToFill($windowId,base) [lrange $args 10 11]
398 set listToFill($windowId,grid) [lrange $args 12 13]
399 set listToFill($windowId,minSize) [lrange $args 14 15]
400 set listToFill($windowId,maxSize) [lrange $args 16 17]
401 set listToFill($windowId,iconIds) [lrange $args 18 19]
402 # set fd [open $::env(HOME)/tflog a]
403 # puts $fd [array get listToFill $windowId,*]
405 set listToFill($windowId,gravity) $gravityText([lindex $args 22])
406 # set listToFill($windowId,colors) [list\
407 # [format "#%06x" [lindex $args 22]]\
408 # [format "#%06x" [lindex $args 23]]]
410 WindowName {set listToFill([lindex $args 0],title) [lindex $args 3]}
411 IconName {set listToFill([lindex $args 0],iconName) [lindex $args 3]}
412 ResName {set listToFill([lindex $args 0],resource) [lindex $args 3]}
413 ResClass {set listToFill([lindex $args 0],class) [lindex $args 3]}
414 IconFile {set listToFill([lindex $args 0],icon) [lindex $args 3]}
415 MiniIcon {set listToFill([lindex $args 0],miniIcon) [lindex $args 3]}
416 Iconify {set listToFill([lindex $args 0],iconic) 1}
420 # getWindowList - fills given array with info of current desktop
422 proc getWindowList {array {pattern *}} {
427 variable WindowListMask
428 variable internalHandler
431 if {($Mask&$WindowListMask)!=$WindowListMask} {
432 send "Set_Mask $WindowListMask"
434 catch {unset listToFill}
435 set internalHandler winListHandler
436 send "Send_WindowList"
437 vwait ::fvwm::listDone
438 set internalHandler ""
439 uplevel array set $array [list [array get listToFill]]
441 if {($Mask&$WindowListMask)!=$WindowListMask} {
442 send "Set_Mask $WindowListMask"
446 # searches icon through fvwm PixmapPath or IconPath
448 proc iconPath {name {where -pixmap}} {
451 if {![info exist PixmapPath]&&![info exist IconPath]} {
454 if {$where=="-pixmap"} {
456 } elseif {$where=="-icon"} {
459 return -code error "Invalid option. Should be -pixmap or -icon"
463 if {[lsearch -exact [glob -nocomplain [file join $dir *]]\
464 [file join $dir $name]]!=-1} {
465 return [file join $dir $name]
473 fileevent $infd readable [namespace code getMessage]
475 # Default handler for fvwm error message. Raises Tcl asynchroneus error
476 # after idle to avoid closing pipe. Defined in the global namespace
479 if {[llength [info command Error]]==0} {
480 proc Error {msgtype zero0 zero1 zero2 msg} {
481 after idle "error [list $msg] \{[list FVWM 2 $msg]\}"
484 package provide Fvwm 1.4