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 }
  40
  41 variable gravityText
  42 array set gravityText {
  43 0 ForgetGravity
  44 1 NorthWestGravity
  45 2 NorthGravity
  46 3 NorthEastGravity
  47 4 WestGravity
  48 5 CenterGravity
  49 6 EastGravity
  50 7 SouthWestGravity
  51 8 SouthGravity
  52 9 SouthEastGravity
  53 10 StaticGravity}
  54 variable msgCodes
  55 variable AllEvents 0
  56 foreach {code name} [array get msgType] {
  57     set msgCodes($name) $code
  58     set AllEvents [expr $AllEvents|$code]
  59 }
  60 set msgCodes(DeadPipe) 0
  61 variable WindowListMask [expr $msgCodes(End_WindowList)|\
  62         $msgCodes(NewDesk)|$msgCodes(NewPage)| $msgCodes(FocusChange)|\
  63         $msgCodes(DefaultIcon)|$msgCodes(ConfigureWindow)|\
  64         $msgCodes(WindowName)|$msgCodes(IconName)| $msgCodes(ResName)|\
  65         $msgCodes(ResClass)|$msgCodes(IconFile)|$msgCodes(MiniIcon)]
  66 variable MessagesWithString [expr $msgCodes(WindowName)|$msgCodes(IconName)|\
  67         $msgCodes(ResClass)|$msgCodes(ResName)|$msgCodes(Error)|\
  68         $msgCodes(ConfigInfo)|$msgCodes(String)|$msgCodes(DefaultIcon)|\
  69         $msgCodes(IconFile)|$msgCodes(MiniIcon)|$msgCodes(VisibleName)]
  70 #
  71 # Find out how to format binary integers
  72 # Note, on 64-bit platform there should be 64bit integer
  73 variable intSize 4
  74 variable intFormat
  75 if {$::tcl_platform(byteOrder)=="littleEndian"} {
  76    set intFormat "i"
  77 } else {
  78    set intFormat "I"
  79 }
  80 if {$::argc<5||![regexp {[0-9]+} [lindex $::argv 0]]||
  81         ![regexp {[0-9]+} [lindex $::argv 1]]||
  82         ! [regexp {[0-9]+} [lindex $::argv 3]]||
  83         ![regexp {[0-9]+} [lindex $::argv 4]]} {
  84     error "Should be started as fvwm module" {FVWM 0 "Invalid invocation"}
  85 }
  86 if {[catch {package require Tclx}]} {
  87     if {[string equal $tcl_platform(os) Linux]} {
  88         variable outfd [open /dev/fd/[lindex $::argv 0] w]
  89         variable infd [open /dev/fd/[lindex $::argv 1] r]
  90     } else {
  91         error "Tclx is required for all systems except Linux"
  92     }
  93 } else {
  94     variable outfd [dup [lindex $::argv 0]]
  95     variable infd [dup [lindex $::argv 1]]
  96 }
  97 if {[info tclversion]>=8.1} {
  98 fconfigure $outfd -buffering none -translation binary -encoding binary
  99 fconfigure $infd -buffering none -blocking yes -translation binary -encoding binary
 100 proc get_eventString {infd stringLen} {
 101     return [encoding convertfrom [lindex [split [read $infd $stringLen] "\0"] 0]]
 102 }
 103 } else {
 104 fconfigure $outfd -buffering none -translation binary
 105 fconfigure $infd -buffering none -blocking yes -translation binary
 106     proc get_eventString {infd stringLen} {
 107         return [lindex [split [read $infd $stringLen] "\0"] 0]
 108     }
 109 }
 110 variable configFile [lindex $::argv 2]
 111 variable WindowId [lindex $::argv 3]
 112 variable Context
 113 variable Mask $AllEvents
 114 switch [lindex $::argv 4] {
 115 0 {set Context NO_CONTEXT}
 116 1 {set Context WINDOW}
 117 2 {set Context TITLE}
 118 4 {set Context ICON}
 119 8 {set Context ROOT}
 120 16 {set Context FRAME}
 121 32 {set Context SIDEBAR}
 122 64 {set Context LEFT1}
 123 128 {set Context LEFT2}
 124 256 {set Context LEFT3}
 125 512 {set Context LEFT4}
 126 1024 {set Context LEFT5}
 127 2048 {set Context RIGHT1}
 128 4096 {set Context RIGHT2}
 129 8192 {set Context RIGHT3}
 130 16384 {set Context RIGHT4}
 131 32768 {set Context RIGHT5}
 132 default {set Context Unknown}
 133 }
 134 incr ::argc -5
 135 set ::argv {lrange 5 end $::argv}
 136 variable handlers
 137 array set handlers {
 138 Error Error
 139 DeadPipe ::fvwm::myExit
 140 }
 141
 142 proc myExit {args} {
 143   exit 1
 144 }
 145 #
 146 # Send message to fvwm
 147 #
 148 proc send {message {window 0}} {
 149   variable outfd
 150   variable intFormat
 151   puts -nonewline $outfd [binary format ${intFormat}2 \
 152     [list $window [string length $message]]]
 153   puts -nonewline $outfd $message
 154   puts -nonewline $outfd [binary format $intFormat 1]
 155 }
 156 #
 157 # Used for special event handling during list asquition
 158 #
 159 variable internalHandler ""
 160 variable listToFill
 161 #
 162 # Indicates that list is done
 163 #
 164 #
 165 variable listDone 0
 166 # Fileevent handler for fvwm input pipe
 167 #
 168 proc getMessage {} {
 169     variable infd
 170     variable handlers
 171     variable internalHandler
 172     if [eof $infd] {
 173        set type "DeadPipe"
 174        set event {}
 175     } else {
 176        set event [ReadMessage]
 177        set type [lindex $event 0]
 178     }
 179     #
 180     # Process getting list specially
 181     #
 182     if [string length $internalHandler] {
 183          eval $internalHandler $event
 184          return
 185     }
 186     if [info exist handlers($type)] {
 187        namespace eval :: "$handlers($type) $event"
 188     }
 189 }
 190 #
 191 # Parses fvwm message and converts it to list
 192 #
 193 proc ReadMessage {} {
 194      variable infd
 195      variable msgType
 196      variable intFormat
 197      variable intSize
 198      variable MessagesWithString
 199      variable internalHandler
 200      binary scan [read $infd $intSize] $intFormat sign
 201      binary scan [read $infd $intSize] $intFormat type
 202      binary scan [read $infd $intSize] $intFormat len
 203      binary scan [read $infd $intSize] $intFormat timestamp
 204      if {[eof $infd] && ![ info exist type]} {
 205         return "DeadPipe"
 206      }
 207      set stringLen 0
 208      if {![info exist msgType($type)]} {
 209          after idle {error "Unknown message type [format %x $type]"\
 210                [list FVWM 1 $type "Unknown message"]
 211          }
 212      }
 213      set event $msgType($type)
 214      if {($type & $MessagesWithString) !=0} {
 215          set stringLen [expr ($len-7)*$intSize]
 216          set len 7
 217      }
 218      for {set i 4} {$i<$len} {incr i} {
 219         binary scan [read $infd 4] $intFormat value
 220         lappend event $value
 221      }
 222      if {$stringLen} {
 223 lappend event [get_eventString $infd $stringLen]
 224
 225      }
 226      return $event
 227 }
 228 #
 229 #
 230 # setMask - set event mask for fvwm
 231 #
 232 proc setMask list {
 233     variable msgCodes
 234     variable Mask
 235     if {[llength $list]==1&&![catch {expr $list+1}]} {
 236         #mask is numeric. Suppose user knows what he does
 237         send "Set_Mask $list"
 238         set Mask $list
 239         return
 240     }
 241     set value 0
 242     foreach type $list {
 243         if {![info exist msgCodes($type)]} {
 244             return -code error -errorcode [list FVWM 3 $type "Invalid event"]\
 245                 "Invalid event name $type"
 246         }
 247         set value [expr {$value|$msgCodes($type)}]
 248     }
 249     send "Set_Mask $value"
 250     set Mask $value
 251 }
 252 #
 253 # Binds handler to specific event
 254 #
 255 proc bind {args} {
 256     variable msgCodes
 257     variable handlers
 258     if ![llength $args] {
 259         return [array names handlers]
 260     }
 261     set type [lindex $args 0]
 262     if ![info exist msgCodes($type)] {
 263         return -code error -errorcode [list FVWM 3 $type "Invalid event"]\
 264                 "Invalid event name $type"
 265     }
 266     if [llength $args]==1 {
 267         if [info exist handlers($type)] {
 268             return $handlers($type)
 269         } else {
 270             return
 271         }
 272     }
 273     if {![llength $args]>2} {
 274         return -code error -errorcode NONE "Wrong # args should be \
 275                 ::fvwm::bind event script"
 276     }
 277     set handlers($type) [lindex $args 1]
 278     return
 279 }
 280
 281
 282
 283 #
 284 # configHandler - internal procedure which handles config
 285 # messages
 286 #
 287 proc configHandler {type args} {
 288     variable configPattern
 289     variable listToFill
 290     variable internalHandler
 291     if {$type=="End_ConfigInfo"} {
 292         uplevel \#0 set ::fvwm::listDone 1
 293     } elseif {$type=="ConfigInfo"} {
 294         regsub "\[\t\n\r \]*$" [lindex $args 3] "" line
 295         if {[regexp "\\*(\[a-zA-Z0-9_-\]+)\[ \t\]*(.*)\$" $line junk name value]} {
 296             if [string match $configPattern $name] {
 297                 lappend listToFill($name) $value
 298             }
 299         } elseif {[regexp "(\[a-zA-Z0-9_-\]+)\[ \t\]*(.*)\$" $line junk\
 300                     name value]} {
 301             if [string match *Path $name] {
 302                 eval lappend listToFill($name) [split $value ":"]
 303             } else {
 304                 lappend listToFill($name) $value
 305             }
 306         }
 307     }
 308 }
 309 #
 310 # getConfig - requests from fvwm configuration info and fills given
 311 # array
 312 #
 313 proc getConfig {array {pattern *}} {
 314     variable listToFill
 315     variable configPattern
 316     variable Mask
 317     variable msgCodes
 318     variable internalHandler
 319     variable IconPath
 320     variable PixmapPath
 321     upvar $array res
 322     set myMask [expr $msgCodes(ConfigInfo)|$msgCodes(End_ConfigInfo)]
 323     if {($Mask&$myMask)!=$myMask} {
 324         send "Set_Mask $myMask"
 325     }
 326     set configPattern $pattern
 327     set internalHandler configHandler
 328     send "Send_ConfigInfo"
 329     vwait ::fvwm::listDone
 330     set internalHandler ""
 331     if [info exists listToFill(PixmapPath)] {
 332        set PixmapPath $listToFill(PixmapPath)
 333     } else {
 334        set PixmapPath ""
 335     }
 336     if [info exists listToFill(IconPath)] {
 337        set IconPath $listToFill(IconPath)
 338     } else {
 339        set IconPath ""
 340     }
 341     uplevel array set $array [list [array get listToFill]]
 342     #unset listToFill
 343     if {($Mask&$myMask)!=$myMask} {
 344         send "Set_Mask $Mask"
 345     }
 346 }
 347 #
 348 # winListHandler - handles various events which fvwm sends in response
 349 # to Send_WindowList
 350 #
 351 proc winListHandler {type args} {
 352     variable listToFill
 353     variable listDone
 354     variable gravityText
 355     switch $type {
 356     End_WindowList {uplevel #0 set ::fvwm::listDone 1}
 357     NewDesk {set listToFill(Desk) [lindex $args 0]}
 358     NewPage {
 359         set listToFill(Page) [concat [lrange $args 0 1] [lrange $args 2 3]]
 360     }
 361     FocusChange {
 362         set listToFill(Focus) [lindex $args 0]
 363            # Don't know how to convert fvwm color info to something
 364            # useful
 365            # set listToFill(FocusColors) [list\
 366            #        [format "#%06x" [lindex $args 1]]\
 367            #        [format "#%06x" [lindex $args 2]]]
 368         }
 369         DefaultIcon {set listToFill(DefaultIcon) [lindex $args 3]}
 370         ConfigureWindow {
 371             set windowId [lindex $args 0]
 372             set listToFill($windowId,frame) [concat [lindex $args 1]\
 373                 [lrange $args 3 6] [lrange $args 9 10]]
 374             set listToFill($windowId,desk) [lindex $args 7]
 375             set listToFill($windowId,flags) [lindex $args 8]
 376             set listToFill($windowId,base) [lrange $args 11 12]
 377             set listToFill($windowId,grid) [lrange $args 13 14]
 378             set listToFill($windowId,minSize) [lrange $args 15 16]
 379             set listToFill($windowId,maxSize) [lrange $args 17 18]
 380             set listToFill($windowId,iconIds) [lrange $args 19 20]
 381             set listToFill($windowId,gravity) $gravityText([lindex $args 22])
 382             #   set listToFill($windowId,colors) [list\
 383             #       [format "#%06x" [lindex $args 22]]\
 384             #       [format "#%06x" [lindex $args 23]]]
 385         }
 386         NewConfigureWindow {
 387             set windowId [lindex $args 0]
 388             set listToFill($windowId,frame) [concat [lindex $args 1]\
 389                 [lrange $args 3 6] [lrange $args 9 10]]
 390             set listToFill($windowId,desk) [lindex $args 7]
 391             set listToFill($windowId,flags) [lindex $args 26]
 392             set listToFill($windowId,base) [lrange $args 10 11]
 393             set listToFill($windowId,grid) [lrange $args 12 13]
 394             set listToFill($windowId,minSize) [lrange $args 14 15]
 395             set listToFill($windowId,maxSize) [lrange $args 16 17]
 396             set listToFill($windowId,iconIds) [lrange $args 18 19]
 397 #    set fd [open $::env(HOME)/tflog a]
 398 #    puts $fd [array get listToFill $windowId,*]
 399 #    close $fd
 400             set listToFill($windowId,gravity) $gravityText([lindex $args 22])
 401             #   set listToFill($windowId,colors) [list\
 402             #       [format "#%06x" [lindex $args 22]]\
 403             #       [format "#%06x" [lindex $args 23]]]
 404         }
 405         WindowName {set listToFill([lindex $args 0],title) [lindex $args 3]}
 406         IconName {set listToFill([lindex $args 0],iconName) [lindex $args 3]}
 407         ResName {set listToFill([lindex $args 0],resource) [lindex $args 3]}
 408         ResClass {set listToFill([lindex $args 0],class) [lindex $args 3]}
 409         IconFile {set listToFill([lindex $args 0],icon) [lindex $args 3]}
 410         MiniIcon {set listToFill([lindex $args 0],miniIcon) [lindex $args 3]}
 411         Iconify {set listToFill([lindex $args 0],iconic) 1}
 412         }
 413     }
 414     #
 415     # getWindowList - fills given array with info of current desktop
 416     #
 417     proc getWindowList {array {pattern *}} {
 418         variable listToFill
 419         variable listDone
 420         variable Mask
 421         variable msgCodes
 422         variable WindowListMask
 423         variable internalHandler
 424         set listDone 0
 425
 426         if {($Mask&$WindowListMask)!=$WindowListMask} {
 427             send "Set_Mask $WindowListMask"
 428         }
 429         catch {unset listToFill}
 430         set internalHandler  winListHandler
 431     send "Send_WindowList"
 432     vwait ::fvwm::listDone
 433     set internalHandler ""
 434     uplevel array set $array [list [array get listToFill]]
 435     unset listToFill
 436     if {($Mask&$WindowListMask)!=$WindowListMask} {
 437         send "Set_Mask $WindowListMask"
 438     }
 439 }
 440 #
 441 # searches icon through fvwm PixmapPath or IconPath
 442 #
 443 proc iconPath {name {where -pixmap}} {
 444     variable PixmapPath
 445     variable IconPath
 446     if {![info exist PixmapPath]&&![info exist IconPath]} {
 447        getConfig
 448     }
 449     if {$where=="-pixmap"} {
 450       set path $PixmapPath
 451     } elseif {$where=="-icon"} {
 452       set path $IconPath
 453     } else {
 454       return -code error "Invalid option. Should be -pixmap or -icon"
 455     }
 456
 457     foreach dir $path {
 458        if {[lsearch -exact [glob -nocomplain [file join $dir *]]\
 459                [file join $dir $name]]!=-1} {
 460            return [file join $dir $name]
 461        }
 462     }
 463     return
 464 }
 465
 466
 467
 468 fileevent $infd readable [namespace code getMessage]
 469 }
 470 # Default handler for fvwm error message. Raises Tcl asynchroneus error
 471 # after idle to avoid closing pipe. Defined in the global namespace
 472 #
 473
 474 if {[llength [info command Error]]==0} {
 475 proc Error {msgtype zero0 zero1 zero2 msg} {
 476         after idle "error [list $msg] \{[list FVWM 2 $msg]\}"
 477 }
 478 }
 479 package provide Fvwm 1.3