+package require Tcl 8.0 ;# we need binary command
+namespace eval fvwm {
+#
+# Define fvwm message types of fvwm95-2.0.43
+#
+variable msgType
+array set msgType {
+1 NewPage
+2 NewDesk
+4 AddWindow
+8 RaiseWindow
+16 LowerWindow
+32 ConfigureWindow
+64 FocusChange
+128 DestroyWindow
+256 Iconify
+512 Deiconify
+1024 WindowName
+2048 IconName
+4096 ResClass
+8192 ResName
+16384 End_WindowList
+32768 IconLocation
+65536 Map
+131072 Error
+262144 ConfigInfo
+524288 End_ConfigInfo
+1048576 IconFile
+2097152 DefaultIcon
+4194304 String
+8388608 FunctionEnd
+16777216 MiniIcon
+33554432 ScrollRegion
+67108864 VisibleName
+134217728 Unknown2
+268435456 Restack
+536870912 NewAddWindow
+1073741824 NewConfigureWindow
+}
+
+variable gravityText
+array set gravityText {
+0 ForgetGravity
+1 NorthWestGravity
+2 NorthGravity
+3 NorthEastGravity
+4 WestGravity
+5 CenterGravity
+6 EastGravity
+7 SouthWestGravity
+8 SouthGravity
+9 SouthEastGravity
+10 StaticGravity}
+variable msgCodes
+variable AllEvents 0
+foreach {code name} [array get msgType] {
+ set msgCodes($name) $code
+ set AllEvents [expr $AllEvents|$code]
+}
+set msgCodes(DeadPipe) 0
+variable WindowListMask [expr $msgCodes(End_WindowList)|\
+ $msgCodes(NewDesk)|$msgCodes(NewPage)| $msgCodes(FocusChange)|\
+ $msgCodes(DefaultIcon)|$msgCodes(ConfigureWindow)|\
+ $msgCodes(WindowName)|$msgCodes(IconName)| $msgCodes(ResName)|\
+ $msgCodes(ResClass)|$msgCodes(IconFile)|$msgCodes(MiniIcon)]
+variable MessagesWithString [expr $msgCodes(WindowName)|$msgCodes(IconName)|\
+ $msgCodes(ResClass)|$msgCodes(ResName)|$msgCodes(Error)|\
+ $msgCodes(ConfigInfo)|$msgCodes(String)|$msgCodes(DefaultIcon)|\
+ $msgCodes(IconFile)|$msgCodes(MiniIcon)|$msgCodes(VisibleName)]
+#
+# Find out how to format binary integers
+# Note, on 64-bit platform there should be 64bit integer
+variable intSize 4
+variable intFormat
+if {$::tcl_platform(byteOrder)=="littleEndian"} {
+ set intFormat "i"
+} else {
+ set intFormat "I"
+}
+if {$::argc<5||![regexp {[0-9]+} [lindex $::argv 0]]||
+ ![regexp {[0-9]+} [lindex $::argv 1]]||
+ ! [regexp {[0-9]+} [lindex $::argv 3]]||
+ ![regexp {[0-9]+} [lindex $::argv 4]]} {
+ error "Should be started as fvwm module" {FVWM 0 "Invalid invocation"}
+}
+if {[catch {package require Tclx}]} {
+ if {[string equal $tcl_platform(os) Linux]} {
+ variable outfd [open /dev/fd/[lindex $::argv 0] w]
+ variable infd [open /dev/fd/[lindex $::argv 1] r]
+ } else {
+ error "Tclx is required for all systems except Linux"
+ }
+} else {
+ variable outfd [dup [lindex $::argv 0]]
+ variable infd [dup [lindex $::argv 1]]
+}
+if {[info tclversion]>=8.1} {
+fconfigure $outfd -buffering none -translation binary -encoding binary
+fconfigure $infd -buffering none -blocking yes -translation binary -encoding binary
+proc get_eventString {infd stringLen} {
+ return [encoding convertfrom [lindex [split [read $infd $stringLen] "\0"] 0]]
+}
+} else {
+fconfigure $outfd -buffering none -translation binary
+fconfigure $infd -buffering none -blocking yes -translation binary
+ proc get_eventString {infd stringLen} {
+ return [lindex [split [read $infd $stringLen] "\0"] 0]
+ }
+}
+variable configFile [lindex $::argv 2]
+variable WindowId [lindex $::argv 3]
+variable Context
+variable Mask $AllEvents
+switch [lindex $::argv 4] {
+0 {set Context NO_CONTEXT}
+1 {set Context WINDOW}
+2 {set Context TITLE}
+4 {set Context ICON}
+8 {set Context ROOT}
+16 {set Context FRAME}
+32 {set Context SIDEBAR}
+64 {set Context LEFT1}
+128 {set Context LEFT2}
+256 {set Context LEFT3}
+512 {set Context LEFT4}
+1024 {set Context LEFT5}
+2048 {set Context RIGHT1}
+4096 {set Context RIGHT2}
+8192 {set Context RIGHT3}
+16384 {set Context RIGHT4}
+32768 {set Context RIGHT5}
+default {set Context Unknown}
+}
+incr ::argc -5
+set ::argv {lrange 5 end $::argv}
+variable handlers
+array set handlers {
+Error Error
+DeadPipe ::fvwm::myExit
+}
+
+proc myExit {args} {
+ exit 1
+}
+#
+# Send message to fvwm
+#
+proc send {message {window 0}} {
+ variable outfd
+ variable intFormat
+ puts -nonewline $outfd [binary format ${intFormat}2 \
+ [list $window [string length $message]]]
+ puts -nonewline $outfd $message
+ puts -nonewline $outfd [binary format $intFormat 1]
+}
+#
+# Used for special event handling during list asquition
+#
+variable internalHandler ""
+variable listToFill
+#
+# Indicates that list is done
+#
+#
+variable listDone 0
+# Fileevent handler for fvwm input pipe
+#
+proc getMessage {} {
+ variable infd
+ variable handlers
+ variable internalHandler
+ if [eof $infd] {
+ set type "DeadPipe"
+ set event {}
+ } else {
+ set event [ReadMessage]
+ set type [lindex $event 0]
+ }
+ #
+ # Process getting list specially
+ #
+ if [string length $internalHandler] {
+ eval $internalHandler $event
+ return
+ }
+ if [info exist handlers($type)] {
+ namespace eval :: "$handlers($type) $event"
+ }
+}
+#
+# Parses fvwm message and converts it to list
+#
+proc ReadMessage {} {
+ variable infd
+ variable msgType
+ variable intFormat
+ variable intSize
+ variable MessagesWithString
+ variable internalHandler
+ binary scan [read $infd $intSize] $intFormat sign
+ binary scan [read $infd $intSize] $intFormat type
+ binary scan [read $infd $intSize] $intFormat len
+ binary scan [read $infd $intSize] $intFormat timestamp
+ if {[eof $infd] && ![ info exist type]} {
+ return "DeadPipe"
+ }
+ set stringLen 0
+ if {![info exist msgType($type)]} {
+ after idle {error "Unknown message type [format %x $type]"\
+ [list FVWM 1 $type "Unknown message"]
+ }
+ }
+ set event $msgType($type)
+ if {($type & $MessagesWithString) !=0} {
+ set stringLen [expr ($len-7)*$intSize]
+ set len 7
+ }
+ for {set i 4} {$i<$len} {incr i} {
+ binary scan [read $infd 4] $intFormat value
+ lappend event $value
+ }
+ if {$stringLen} {
+lappend event [get_eventString $infd $stringLen]
+
+ }
+ return $event
+}
+#
+#
+# setMask - set event mask for fvwm
+#
+proc setMask list {
+ variable msgCodes
+ variable Mask
+ if {[llength $list]==1&&![catch {expr $list+1}]} {
+ #mask is numeric. Suppose user knows what he does
+ send "Set_Mask $list"
+ set Mask $list
+ return
+ }
+ set value 0
+ foreach type $list {
+ if {![info exist msgCodes($type)]} {
+ return -code error -errorcode [list FVWM 3 $type "Invalid event"]\
+ "Invalid event name $type"
+ }
+ set value [expr {$value|$msgCodes($type)}]
+ }
+ send "Set_Mask $value"
+ set Mask $value
+}
+#
+# Binds handler to specific event
+#
+proc bind {args} {
+ variable msgCodes
+ variable handlers
+ if ![llength $args] {
+ return [array names handlers]
+ }
+ set type [lindex $args 0]
+ if ![info exist msgCodes($type)] {
+ return -code error -errorcode [list FVWM 3 $type "Invalid event"]\
+ "Invalid event name $type"
+ }
+ if [llength $args]==1 {
+ if [info exist handlers($type)] {
+ return $handlers($type)
+ } else {
+ return
+ }
+ }
+ if {![llength $args]>2} {
+ return -code error -errorcode NONE "Wrong # args should be \
+ ::fvwm::bind event script"
+ }
+ set handlers($type) [lindex $args 1]
+ return
+}
+
+
+
+#
+# configHandler - internal procedure which handles config
+# messages
+#
+proc configHandler {type args} {
+ variable configPattern
+ variable listToFill
+ variable internalHandler
+ if {$type=="End_ConfigInfo"} {
+ uplevel \#0 set ::fvwm::listDone 1
+ } elseif {$type=="ConfigInfo"} {
+ regsub "\[\t\n\r \]*$" [lindex $args 3] "" line
+ if {[regexp "\\*(\[a-zA-Z0-9_-\]+)\[ \t\]*(.*)\$" $line junk name value]} {
+ if [string match $configPattern $name] {
+ lappend listToFill($name) $value
+ }
+ } elseif {[regexp "(\[a-zA-Z0-9_-\]+)\[ \t\]*(.*)\$" $line junk\
+ name value]} {
+ if [string match *Path $name] {
+ eval lappend listToFill($name) [split $value ":"]
+ } else {
+ lappend listToFill($name) $value
+ }
+ }
+ }
+}
+#
+# getConfig - requests from fvwm configuration info and fills given
+# array
+#
+proc getConfig {array {pattern *}} {
+ variable listToFill
+ variable configPattern
+ variable Mask
+ variable msgCodes
+ variable internalHandler
+ variable IconPath
+ variable PixmapPath
+ upvar $array res
+ set myMask [expr $msgCodes(ConfigInfo)|$msgCodes(End_ConfigInfo)]
+ if {($Mask&$myMask)!=$myMask} {
+ send "Set_Mask $myMask"
+ }
+ set configPattern $pattern
+ set internalHandler configHandler
+ send "Send_ConfigInfo"
+ vwait ::fvwm::listDone
+ set internalHandler ""
+ if [info exists listToFill(PixmapPath)] {
+ set PixmapPath $listToFill(PixmapPath)
+ } else {
+ set PixmapPath ""
+ }
+ if [info exists listToFill(IconPath)] {
+ set IconPath $listToFill(IconPath)
+ } else {
+ set IconPath ""
+ }
+ uplevel array set $array [list [array get listToFill]]
+ #unset listToFill
+ if {($Mask&$myMask)!=$myMask} {
+ send "Set_Mask $Mask"
+ }
+}
+#
+# winListHandler - handles various events which fvwm sends in response
+# to Send_WindowList
+#
+proc winListHandler {type args} {
+ variable listToFill
+ variable listDone
+ variable gravityText
+ switch $type {
+ End_WindowList {uplevel #0 set ::fvwm::listDone 1}
+ NewDesk {set listToFill(Desk) [lindex $args 0]}
+ NewPage {
+ set listToFill(Page) [concat [lrange $args 0 1] [lrange $args 2 3]]
+ }
+ FocusChange {
+ set listToFill(Focus) [lindex $args 0]
+ # Don't know how to convert fvwm color info to something
+ # useful
+ # set listToFill(FocusColors) [list\
+ # [format "#%06x" [lindex $args 1]]\
+ # [format "#%06x" [lindex $args 2]]]
+ }
+ DefaultIcon {set listToFill(DefaultIcon) [lindex $args 3]}
+ ConfigureWindow {
+ set windowId [lindex $args 0]
+ set listToFill($windowId,frame) [concat [lindex $args 1]\
+ [lrange $args 3 6] [lrange $args 9 10]]
+ set listToFill($windowId,desk) [lindex $args 7]
+ set listToFill($windowId,flags) [lindex $args 8]
+ set listToFill($windowId,base) [lrange $args 11 12]
+ set listToFill($windowId,grid) [lrange $args 13 14]
+ set listToFill($windowId,minSize) [lrange $args 15 16]
+ set listToFill($windowId,maxSize) [lrange $args 17 18]
+ set listToFill($windowId,iconIds) [lrange $args 19 20]
+ set listToFill($windowId,gravity) $gravityText([lindex $args 22])
+ # set listToFill($windowId,colors) [list\
+ # [format "#%06x" [lindex $args 22]]\
+ # [format "#%06x" [lindex $args 23]]]
+ }
+ NewConfigureWindow {
+ set windowId [lindex $args 0]
+ set listToFill($windowId,frame) [concat [lindex $args 1]\
+ [lrange $args 3 6] [lrange $args 9 10]]
+ set listToFill($windowId,desk) [lindex $args 7]
+ set listToFill($windowId,flags) [lindex $args 26]
+ set listToFill($windowId,base) [lrange $args 10 11]
+ set listToFill($windowId,grid) [lrange $args 12 13]
+ set listToFill($windowId,minSize) [lrange $args 14 15]
+ set listToFill($windowId,maxSize) [lrange $args 16 17]
+ set listToFill($windowId,iconIds) [lrange $args 18 19]
+# set fd [open $::env(HOME)/tflog a]
+# puts $fd [array get listToFill $windowId,*]
+# close $fd
+ set listToFill($windowId,gravity) $gravityText([lindex $args 22])
+ # set listToFill($windowId,colors) [list\
+ # [format "#%06x" [lindex $args 22]]\
+ # [format "#%06x" [lindex $args 23]]]
+ }
+ WindowName {set listToFill([lindex $args 0],title) [lindex $args 3]}
+ IconName {set listToFill([lindex $args 0],iconName) [lindex $args 3]}
+ ResName {set listToFill([lindex $args 0],resource) [lindex $args 3]}
+ ResClass {set listToFill([lindex $args 0],class) [lindex $args 3]}
+ IconFile {set listToFill([lindex $args 0],icon) [lindex $args 3]}
+ MiniIcon {set listToFill([lindex $args 0],miniIcon) [lindex $args 3]}
+ Iconify {set listToFill([lindex $args 0],iconic) 1}
+ }
+ }
+ #
+ # getWindowList - fills given array with info of current desktop
+ #
+ proc getWindowList {array {pattern *}} {
+ variable listToFill
+ variable listDone
+ variable Mask
+ variable msgCodes
+ variable WindowListMask
+ variable internalHandler
+ set listDone 0
+
+ if {($Mask&$WindowListMask)!=$WindowListMask} {
+ send "Set_Mask $WindowListMask"
+ }
+ catch {unset listToFill}
+ set internalHandler winListHandler
+ send "Send_WindowList"
+ vwait ::fvwm::listDone
+ set internalHandler ""
+ uplevel array set $array [list [array get listToFill]]
+ unset listToFill
+ if {($Mask&$WindowListMask)!=$WindowListMask} {
+ send "Set_Mask $WindowListMask"
+ }
+}
+#
+# searches icon through fvwm PixmapPath or IconPath
+#
+proc iconPath {name {where -pixmap}} {
+ variable PixmapPath
+ variable IconPath
+ if {![info exist PixmapPath]&&![info exist IconPath]} {
+ getConfig
+ }
+ if {$where=="-pixmap"} {
+ set path $PixmapPath
+ } elseif {$where=="-icon"} {
+ set path $IconPath
+ } else {
+ return -code error "Invalid option. Should be -pixmap or -icon"
+ }
+
+ foreach dir $path {
+ if {[lsearch -exact [glob -nocomplain [file join $dir *]]\
+ [file join $dir $name]]!=-1} {
+ return [file join $dir $name]
+ }
+ }
+ return
+}
+
+
+
+fileevent $infd readable [namespace code getMessage]
+}
+# Default handler for fvwm error message. Raises Tcl asynchroneus error
+# after idle to avoid closing pipe. Defined in the global namespace
+#
+
+if {[llength [info command Error]]==0} {
+proc Error {msgtype zero0 zero1 zero2 msg} {
+ after idle "error [list $msg] \{[list FVWM 2 $msg]\}"
+}
+}
+package provide Fvwm 1.3
projects / oss / fvwm-tcl.git / commitdiff