fvwm.tcl

   1 package require Tcl 8.0 ;# we need binary command
   2 namespace eval fvwm {
   3 #
   4 # Define fvwm message types of fvwm95-2.0.43
   5 #
   6 variable msgType
   7 array set msgType {
   8 1 NewPage
   9 2 NewDesk
  10 4 AddWindow
  11 8 RaiseWindow
  12 16 LowerWindow
  13 32 ConfigureWindow
  14 64 FocusChange
  15 128 DestroyWindow
  16 256 Iconify
  17 512 Deiconify
  18 1024 WindowName
  19 2048 IconName
  20 4096 ResClass
  21 8192 ResName
  22 16384 End_WindowList
  23 32768 IconLocation
  24 65536 Map
  25 131072 Error
  26 262144 ConfigInfo
  27 524288 End_ConfigInfo
  28 1048576 IconFile
  29 2097152 DefaultIcon
  30 4194304 String
  31 8388608 FunctionEnd
  32 16777216 MiniIcon
  33 33554432 ScrollRegion
  34 67108864 VisibleName
  35 134217728 Unknown2
  36 268435456 Restack
  37 536870912 NewAddWindow
  38 1073741824 NewConfigureWindow
  39 2147483648 UnknownMessage
  40 -2147483647 UnknownMessage1
  41 -2147483646 UnknownMessage2
  42 -2147483645 UnknownMessage3
  43 -2147483644 UnknownMessage4
  44 -2147483640 UnknownMessage8
  45 }
  46
  47 variable gravityText
  48 array set gravityText {
  49 0 ForgetGravity
  50 1 NorthWestGravity
  51 2 NorthGravity
  52 3 NorthEastGravity
  53 4 WestGravity
  54 5 CenterGravity
  55 6 EastGravity
  56 7 SouthWestGravity
  57 8 SouthGravity
  58 9 SouthEastGravity
  59 10 StaticGravity}
  60 variable msgCodes
  61 variable AllEvents 0
  62 foreach {code name} [array get msgType] {
  63     set msgCodes($name) $code
  64     set AllEvents [expr $AllEvents|$code]
  65 }
  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)]
  76 #
  77 # Find out how to format binary integers
  78 # Note, on 64-bit platform there should be 64bit integer
  79 variable intSize 4
  80 variable intFormat
  81 if {$::tcl_platform(byteOrder)=="littleEndian"} {
  82    set intFormat "i"
  83 } else {
  84    set intFormat "I"
  85 }
  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"}
  91 }
  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]
  96     } else {
  97         error "Tclx is required for all systems except Linux"
  98     }
  99 } else {
 100     variable outfd [dup [lindex $::argv 0]]
 101     variable infd [dup [lindex $::argv 1]]
 102 }
 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]]
 108 }
 109 } else {
 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]
 114     }
 115 }
 116 variable configFile [lindex $::argv 2]
 117 variable WindowId [lindex $::argv 3]
 118 variable Context
 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}
 124 4 {set Context ICON}
 125 8 {set Context ROOT}
 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}
 139 }
 140 incr ::argc -5
 141 set ::argv {lrange 5 end $::argv}
 142 variable handlers
 143 array set handlers {
 144 Error Error
 145 DeadPipe ::fvwm::myExit
 146 }
 147
 148 proc myExit {args} {
 149   exit 1
 150 }
 151 #
 152 # Send message to fvwm
 153 #
 154 proc send {message {window 0}} {
 155   variable outfd
 156   variable intFormat
 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]
 161 }
 162 #
 163 # Used for special event handling during list asquition
 164 #
 165 variable internalHandler ""
 166 variable listToFill
 167 #
 168 # Indicates that list is done
 169 #
 170 #
 171 variable listDone 0
 172 # Fileevent handler for fvwm input pipe
 173 #
 174 proc getMessage {} {
 175     variable infd
 176     variable handlers
 177     variable internalHandler
 178     if [eof $infd] {
 179        set type "DeadPipe"
 180        set event {}
 181     } else {
 182        set event [ReadMessage]
 183        set type [lindex $event 0]
 184     }
 185     #
 186     # Process getting list specially
 187     #
 188     if [string length $internalHandler] {
 189          eval $internalHandler $event
 190          return
 191     }
 192     if [info exist handlers($type)] {
 193        namespace eval :: "$handlers($type) $event"
 194     }
 195 }
 196 #
 197 # Parses fvwm message and converts it to list
 198 #
 199 proc ReadMessage {} {
 200      variable infd
 201      variable msgType
 202      variable intFormat
 203      variable intSize
 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]} {
 211         return "DeadPipe"
 212      }
 213      set stringLen 0
 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
 217      }
 218                 set event $msgType($type)
 219      if {($type & $MessagesWithString) !=0} {
 220          set stringLen [expr ($len-7)*$intSize]
 221          set len 7
 222      }
 223      for {set i 4} {$i<$len} {incr i} {
 224         binary scan [read $infd 4] $intFormat value
 225         lappend event $value
 226      }
 227      if {$stringLen} {
 228 lappend event [get_eventString $infd $stringLen]
 229
 230      }
 231      return $event
 232 }
 233 #
 234 #
 235 # setMask - set event mask for fvwm
 236 #
 237 proc setMask list {
 238     variable msgCodes
 239     variable Mask
 240     if {[llength $list]==1&&![catch {expr $list+1}]} {
 241         #mask is numeric. Suppose user knows what he does
 242         send "Set_Mask $list"
 243         set Mask $list
 244         return
 245     }
 246     set value 0
 247     foreach type $list {
 248         if {![info exist msgCodes($type)]} {
 249             return -code error -errorcode [list FVWM 3 $type "Invalid event"]\
 250                 "Invalid event name $type"
 251         }
 252         set value [expr {$value|$msgCodes($type)}]
 253     }
 254     send "Set_Mask $value"
 255     set Mask $value
 256 }
 257 #
 258 # Binds handler to specific event
 259 #
 260 proc bind {args} {
 261     variable msgCodes
 262     variable handlers
 263     if ![llength $args] {
 264         return [array names handlers]
 265     }
 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"
 270     }
 271     if [llength $args]==1 {
 272         if [info exist handlers($type)] {
 273             return $handlers($type)
 274         } else {
 275             return
 276         }
 277     }
 278     if {![llength $args]>2} {
 279         return -code error -errorcode NONE "Wrong # args should be \
 280                 ::fvwm::bind event script"
 281     }
 282     set handlers($type) [lindex $args 1]
 283     return
 284 }
 285
 286
 287
 288 #
 289 # configHandler - internal procedure which handles config
 290 # messages
 291 #
 292 proc configHandler {type args} {
 293     variable configPattern
 294     variable listToFill
 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
 303             }
 304         } elseif {[regexp "(\[a-zA-Z0-9_-\]+)\[ \t\]*(.*)\$" $line junk\
 305                     name value]} {
 306             if [string match *Path $name] {
 307                 eval lappend listToFill($name) [split $value ":"]
 308             } else {
 309                 lappend listToFill($name) $value
 310             }
 311         }
 312     }
 313 }
 314 #
 315 # getConfig - requests from fvwm configuration info and fills given
 316 # array
 317 #
 318 proc getConfig {array {pattern *}} {
 319     variable listToFill
 320     variable configPattern
 321     variable Mask
 322     variable msgCodes
 323     variable internalHandler
 324     variable IconPath
 325     variable PixmapPath
 326     upvar $array res
 327     set myMask [expr $msgCodes(ConfigInfo)|$msgCodes(End_ConfigInfo)]
 328     if {($Mask&$myMask)!=$myMask} {
 329         send "Set_Mask $myMask"
 330     }
 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)
 338     } else {
 339        set PixmapPath ""
 340     }
 341     if [info exists listToFill(IconPath)] {
 342        set IconPath $listToFill(IconPath)
 343     } else {
 344        set IconPath ""
 345     }
 346     uplevel array set $array [list [array get listToFill]]
 347     #unset listToFill
 348     if {($Mask&$myMask)!=$myMask} {
 349         send "Set_Mask $Mask"
 350     }
 351 }
 352 #
 353 # winListHandler - handles various events which fvwm sends in response
 354 # to Send_WindowList
 355 #
 356 proc winListHandler {type args} {
 357     variable listToFill
 358     variable listDone
 359     variable gravityText
 360     switch $type {
 361     End_WindowList {uplevel #0 set ::fvwm::listDone 1}
 362     NewDesk {set listToFill(Desk) [lindex $args 0]}
 363     NewPage {
 364         set listToFill(Page) [concat [lrange $args 0 1] [lrange $args 2 3]]
 365     }
 366     FocusChange {
 367         set listToFill(Focus) [lindex $args 0]
 368            # Don't know how to convert fvwm color info to something
 369            # useful
 370            # set listToFill(FocusColors) [list\
 371            #        [format "#%06x" [lindex $args 1]]\
 372            #        [format "#%06x" [lindex $args 2]]]
 373         }
 374         DefaultIcon {set listToFill(DefaultIcon) [lindex $args 3]}
 375         ConfigureWindow {
 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]]]
 390         }
 391         NewConfigureWindow {
 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,*]
 404 #    close $fd
 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]]]
 409         }
 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}
 417         }
 418     }
 419     #
 420     # getWindowList - fills given array with info of current desktop
 421     #
 422     proc getWindowList {array {pattern *}} {
 423         variable listToFill
 424         variable listDone
 425         variable Mask
 426         variable msgCodes
 427         variable WindowListMask
 428         variable internalHandler
 429         set listDone 0
 430
 431         if {($Mask&$WindowListMask)!=$WindowListMask} {
 432             send "Set_Mask $WindowListMask"
 433         }
 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]]
 440     unset listToFill
 441     if {($Mask&$WindowListMask)!=$WindowListMask} {
 442         send "Set_Mask $WindowListMask"
 443     }
 444 }
 445 #
 446 # searches icon through fvwm PixmapPath or IconPath
 447 #
 448 proc iconPath {name {where -pixmap}} {
 449     variable PixmapPath
 450     variable IconPath
 451     if {![info exist PixmapPath]&&![info exist IconPath]} {
 452        getConfig
 453     }
 454     if {$where=="-pixmap"} {
 455       set path $PixmapPath
 456     } elseif {$where=="-icon"} {
 457       set path $IconPath
 458     } else {
 459       return -code error "Invalid option. Should be -pixmap or -icon"
 460     }
 461
 462     foreach dir $path {
 463        if {[lsearch -exact [glob -nocomplain [file join $dir *]]\
 464                [file join $dir $name]]!=-1} {
 465            return [file join $dir $name]
 466        }
 467     }
 468     return
 469 }
 470
 471
 472
 473 fileevent $infd readable [namespace code getMessage]
 474 }
 475 # Default handler for fvwm error message. Raises Tcl asynchroneus error
 476 # after idle to avoid closing pipe. Defined in the global namespace
 477 #
 478
 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]\}"
 482 }
 483 }
 484 package provide Fvwm 1.3