plugins/irda

   1 #!/usr/bin/wish
   2 # If we are not started from fubar
   3 if {![info exists LIBRARYDIR]} {
   4         set LIBRARYDIR [file dirname [info script]]
   5         set CONFIGDIR ~/.fubar
   6 }
   7 if {[file exists /proc/net/irda/discovery]} {
   8         namespace eval irda {
   9                 #variable discovery "/proc/net/irda/discovery"
  10                 variable discovery "/proc/net/irda/discovery"
  11                 variable config [file join $::CONFIGDIR irda.conf]
  12                 if {![file exists $config]} {
  13                         # create default config
  14                         file copy [file join $::LIBRARYDIR irda.conf] $config
  15                 }
  16                 #update interval in milliseconds
  17                 variable poll 2000
  18                 variable configread 0;#ensure config to be read on first update
  19                 variable canvas .irda
  20                 variable menu $canvas.m
  21                 variable hintBits {0x100 PnP 0x200      PDA 0x400       Computer 0x800  Printer
  22    0x1000       Modem 0x2000    Fax 0x4000      LAN 0x1         Telephony 0x2   FileServer
  23       0x4       Comm 0x8        Message 0x10    Http 0x20       OBEX }
  24            variable stdIcons {computer
  25 {R0lGODlhEAAQAMIAAICAgMDAwAAAAP///wAA/////////////yH5BAEKAAcALAAAAAAQABAA
  26 AANIeLrcDjDGF6qtQDAwuu+QtnBCaQ7hNghE26KZyroELCokXafj92WQkWlYAgREHJ/HGDuE
  27 gAJoyig4WqtYTVLpOSqI4JJj7EgAADs=}
  28                 pda
  29 {R0lGODlhDgAOAMIAANPT02lpaQBkAP///////////////////yH5BAEKAAQALAAAAAAOAA4A
  30 AAMySLrcBDDGwIC4WAC67PjYVmVhwD3ktZ2eMJRsqpmda6u0YqViJUGnhWlIZBCJPYeSkAAA
  31 Ow==}
  32                 modem
  33 {R0lGODlhEAAQAKEAAAAAAKyqrL2+vf///yH+FUNyZWF0ZWQgd2l0aCBUaGUgR0lNUAAh+QQB
  34 CgADACwAAAAAEAAQAAACLZyPCMm3zR40oE4XgoRA5510osZ5nQBSmSagzRig6TCecx3fZl6y
  35 7mSbhYSIAgA7}
  36                 lan
  37 {R0lGODlhEAAQAKEAAI6KjgAAAP///////yH5BAEKAAIALAAAAAAQABAAAAInlI8pwKztmjKS
  38 zgNQuGYff4GCqIjBiaYnN7IJycKcfGUu5biQfU8FADs=}
  39                 printer
  40 {R0lGODlhEAAQAOcAAAAAAAEBAQICAgMDAwQEBAUFBQYGBgcHBwgICAkJCQoKCgsLCwwMDA0N
  41 DQ4ODg8PDxAQEBERERISEhMTExQUFBUVFRYWFhcXFxgYGBkZGRoaGhsbGxwcHB0dHR4eHh8f
  42 HyAgICEhISIiIiMjIyQkJCUlJSYmJicnJygoKCkpKSoqKisrKywsLC0tLS4uLi8vLzAwMDEx
  43 MTIyMjMzMzQ0NDU1NTY2Njc3Nzg4ODk5OTo6Ojs7Ozw8PD09PT4+Pj8/P0BAQEFBQUJCQkND
  44 Q0REREVFRUZGRkdHR0hISElJSUpKSktLS0xMTE1NTU5OTk9PT1BQUFFRUVJSUlNTU1RUVFVV
  45 VVZWVldXV1hYWFlZWVpaWltbW1xcXF1dXV5eXl9fX2BgYGFhYWJiYmNjY2RkZGVlZWZmZmdn
  46 Z2hoaGlpaWpqamtra2xsbG1tbW5ubm9vb3BwcHFxcXJycnNzc3R0dHV1dXZ2dnd3d3h4eHl5
  47 eXp6ent7e3x8fH19fX5+fn9/f4CAgIGBgYKCgoODg4SEhIWFhYaGhoeHh4iIiImJiYqKiouL
  48 i4yMjI2NjY6Ojo+Pj5CQkJGRkZKSkpOTk5SUlJWVlZaWlpeXl5iYmJmZmZqampubm5ycnJ2d
  49 nZ6enp+fn6CgoKGhoaKioqOjo6SkpKWlpaampqenp6ioqKmpqaqqqqurq6ysrK2tra6urq+v
  50 r7CwsLGxsbKysrOzs7S0tLW1tba2tre3t7i4uLm5ubq6uru7u7y8vL29vb6+vr+/v8DAwMHB
  51 wcLCwsPDw8TExMXFxcbGxsfHx8jIyMnJycrKysvLy8zMzM3Nzc7Ozs/Pz9DQ0NHR0dLS0tPT
  52 09TU1NXV1dbW1tfX19jY2NnZ2dra2tvb29zc3N3d3d7e3t/f3+Dg4OHh4eLi4uPj4+Tk5OXl
  53 5ebm5ufn5+jo6Onp6erq6uvr6+zs7O3t7e7u7u/v7/Dw8PHx8fLy8vPz8/T09PX19fb29vf3
  54 9/j4+Pn5+fr6+vv7+/z8/P39/f7+/v///yH5BAEKAP4ALAAAAAAQABAAAAhNAP0JFAigoMGC
  55 AxMC+Mew4T8ACQk+PLgQYsSFDhtaVDjx4MOI/jBm/Hixo0GSHEeiJEixpUWXMAuqHClTZcWH
  56 HWc6RBiTYkqaIHsODAgAOw==}
  57                 fax
  58 {R0lGODlhEAAQAMIAAICAgP///wAAAMDAwP///////////////yH5BAEKAAQALAAAAAAQABAA
  59 AANISLoMznCBQB90juog5Azf1inTMGSiFJylOXAnUc4C4ApmRgO1e9a7Xs4BpJiEGKLQOEx2
  60 cLlVkjciCKAsZcSK024X1+p3vEgAADs=}
  61 }
  62
  63                 variable iconUnknown {
  64 R0lGODlhEAAQAIAAAAAAAP///yH5BAEKAAEALAAAAAAQABAAAAIgjA+px6bbEGAphtownZnb
  65 /oGhNJLl5ZWamp4u+q5vUwAAOw==
  66 }
  67                 variable validFlags
  68                 # óÐÉÓÏË ÄÏÐÕÓÔÉÍÙÈ ÆÌÁÇÏ× ÚÎÁÞÅÎÉÅ 1 ÅÓÌÉ ÄÏÌÖÅÎ ÂÙÔØ ÐÁÒÁÍÅÔÒ
  69                 array set validFlags {
  70                         pidfile 1
  71                         !pidfile 1
  72                         gui 1
  73                         silent 0
  74                         show 0
  75                 }
  76                 proc update {} {
  77                         variable discovery
  78                         variable configread
  79                         variable config
  80                         if {[file mtime $config]>$configread} {
  81                                 readconfig
  82                         }
  83                         set f [open $discovery]
  84                         while {[gets $f line]>=0} {
  85                                 if {[string match "nickname:*" $line]} {
  86                                         found $line
  87                                         close $f
  88                                         return
  89                                 }
  90                         }
  91                         close $f
  92                         not_found
  93                 }
  94                 #
  95                 # schedules next update
  96                 #
  97                 proc reschedule {} {
  98                         variable poll
  99                         after $poll ::irda::update
 100                 }
 101                 #
 102                 # ïÂÒÁÂÏÔËÁ ÐÕÓÔÏÇÏ discovery
 103                 # õÄÁÌÑÅÔ ×ÓÅ ÐÏÚÉÃÉÉ ÉÚ ÍÅÎÀ É ÕÄÁÌÑÅÔ ÉËÏÎËÕ
 104                 #
 105                 proc not_found {} {
 106                         variable hint
 107                         variable canvas
 108                         variable menu
 109                         $canvas delete peer
 110                         $menu delete 1 end
 111                         set hint "No IR device in range"
 112                         proc show_menu {} {}
 113                         reschedule
 114                 }
 115                 #
 116                 # ïÂÒÁÂÏÔËÁ ÎÁÊÄÅÎÎÏÇÏ ÕÓÔÒÏÊÓÔ×Á. ÷ÈÏÄÎÏÊ ÐÁÒÁÍÅÔÒ -
 117                 # ÓÔÒÏÞËÁ ÉÚ discovery
 118                 #
 119                 proc found {line} {
 120                         variable hint
 121                         variable hintBits
 122                         foreach field [split $line ","] {
 123                                 if {[regexp {([a-z]+): +(.*)} $field xx name value]} {
 124                                         set props($name) $value
 125                                 }
 126                         }
 127                         set propList {}
 128                         if {![string match "$props(nickname)*" $hint]} {
 129                                 foreach {bitMask prop} $hintBits {
 130                                         if {$props(hint) & $bitMask} {
 131                                                 lappend propList $prop
 132                                         }
 133                                 }
 134                                 set hint "$props(nickname) [join  $propList ","]"
 135                                 setup_menu $propList
 136                                 setup_icon $props(nickname) $propList
 137                         }
 138                         reschedule
 139                 }
 140                 #
 141                 # ðÒÏ×ÅÒÑÅÔ ËÏÒÒÅËÔÎÏÓÔØ ÆÌÁÇÁ
 142                 #
 143                 proc checkFlag {name value file line} {
 144                         variable validFlags
 145                         if {![info exists validFlags($name)]} {
 146                                 error "Invalid flag `$name' at $file:$line"
 147                         }
 148                         if {$value && !$validFlags($name)} {
 149                                 error "Flag $name shouldn't have a value at $file:$line"
 150                         }
 151                         if {!$value && $validFlags($name)} {
 152                                 error "Flag $name shouldn have a value at $file:$line"
 153                         }
 154                 }
 155                 #
 156                 # þÔÅÎÉÅ ËÏÎÆÉÇÕÒÁÃÉÏÎÎÏÇÏ ÆÁÊÌÁ ÉÚ ÇÌÏÂÁÌØÎÏÊ ÐÅÒÅÍÅÎÎÏÊ
 157                 # config. úÁÐÏÌÎÑÅÔ
 158                 # ÇÌÏÂÁÌØÎÙÊ ÍÁÓÓÉ× confsections
 159                 #
 160             proc readconfig {} {
 161                         variable config
 162                         variable confsections
 163                         variable configread
 164                         set configread [clock seconds]
 165                         set f [open $config]
 166                         set sp "\[ \t\]+"
 167                         set qstr "(\"\[^\"]+\"|\[^ \t\]+)"
 168                         set lineno 0
 169                         array unset confsections {}
 170                         set confsections(devices) {}
 171                         while {[gets $f line]>=0} {
 172                                 incr lineno
 173                                 if {![string length $line]} continue
 174                                 if {[regexp "^\[ \t\]*#" $line]} continue
 175                                 if {[regexp "^(\[A-Za-z\]\+):\[ \t\]*$" $line xx secname]} {
 176                                         set secname [string tolower $secname]
 177                                         set confsections($secname) {}
 178                                 } else {
 179                                         if {![info exists secname]} {
 180                                                 error "Syntax error in $config:$lineno - menu item without sectname"
 181                                         }
 182                                         if {$secname != "devices"} {
 183                                                 if {![regexp "\[ \t\]*$qstr$sp$qstr$sp\(.+)$" $line xx label flags cmd]} {
 184                                                         error "Syntax eror in $config:$lineno"
 185                                                 }
 186                                                 set flagList {}
 187                                                 foreach flag [split [string trim $flags \"] ","] {
 188                                                         if {![string length $flag]} continue
 189                                                         if {[regexp {([^=]+)=(.*)} $flag xx name param]} {
 190                                                                 checkFlag $name 1 $config $lineno
 191                                                                 lappend flagList $name $param
 192                                                         } else {
 193                                                                 checkFlag $flag 0 $config $lineno
 194                                                                 lappend flagList $flag ""
 195                                                         }
 196                                                 }
 197                                                 lappend confsections($secname) [string trim $label \"] $flagList $cmd
 198                                         } else {
 199                                                 if {![regexp "\[ \t\]*$qstr$sp(.*)" $line xx pattern filename]} {
 200                                                         error "Syntax error in $config:$lineno"
 201                                                 }
 202                                                 lappend deviceIcons $pattern filename
 203                                         }
 204                                 }
 205                         }
 206                 }
 207                 #
 208                 # ðÏËÁÚÙ×ÁÅÔ ÉËÏÎËÕ ÕÓÔÒÏÊÓÔ×Á. ðÁÒÁÍÅÔÒÙ nickname ÕÓÔÒÏÊÓÔ×Á
 209                 # É ÓÐÉÓÏË ÅÇÏ ÁÔÒÉÂÕÔÏ×.
 210                 proc setup_icon {name props} {
 211                         variable confsections
 212                         variable stdIcons
 213                         variable iconUnknown
 214                         # óÎÁÞÁÌÁ ÉÝÅÍ ÓÐÅÃÉÆÉÞÅÓËÕÀ ÉËÏÎËÕ × ÓÅËÃÉÉ devices
 215                         foreach {pattern icon} $confsections(devices) {
 216                                 if [string match $pattern $name] {
 217                                         foreach path [list $::CONFIGDIR $::LIBRARYDIR] {
 218                                                 set fn [file join $path "icons" $name]
 219                                                 if [file exists $fn] {
 220                                                         peer_image -file $fn
 221                                                         return
 222                                                 }
 223                                         }
 224                                         # åÓÌÉ ËÁÒÔÉÎËÉ ÎÅ ÎÁÊÄÅÎÏ, ÐÒÅËÒÁÝÁÅÍ ÐÅÒÅÂÏÒ
 225                                         break
 226                                 }
 227                         }
 228                         set searchList [string tolower $props]
 229                         # åÓÌÉ ÎÅ ÎÁÊÄÅÎÏ, ÉÝÅÍ ÓÔÁÎÄÁÒÔÎÕÀ
 230                         foreach {device image} $stdIcons {
 231                                 if {[lsearch -exact $searchList $device]!=-1} {
 232                                         peer_image -data $image
 233                                         return
 234                                 }
 235                         }
 236                         # ÕÓÔÁÎÁ×ÌÉ×ÁÅÍ ÉËÏÎËÕ ÎÅÉÚ×ÅÓÔÎÏÇÏ ÕÓÔÒÏÊÓÔ×Á
 237                         peer_image -data $iconUnknown
 238
 239                 }
 240                 #
 241                 # óÏÚÄÁÅÔ ÉËÏÎËÕ Ó ÔÜÇÏÍ peer ÎÁ ËÁÎ×Å.
 242                 #
 243                 proc peer_image {option value} {
 244                         variable canvas
 245                         $canvas create image 17 8 -anchor w -tag peer \
 246                                                                 -image [image create photo $option $value]
 247                 }
 248                 #
 249                 # äÏÂÁ×ÌÑÅÔ × ÍÅÎÀ ÐÏÚÉÃÉÉ ÓÏÏÔ×ÅÔÓÔ×ÕÀÝÉÅ Ó×ÏÊÓÔ×ÁÍ ÄÁÎÎÏÇÏ
 250                 # ÕÓÔÒÏÊÓÔ×Á É ÚÁÐÏÍÉÎÁÅÔ ÄÅÊÓÔ×ÉÑ, ËÏÔÏÒÙÅ ÓÌÅÄÕÅÔ ×ÙÐÏÌÎÉÔØ
 251                 # ÐÏ postcommand × ÐÒÏÃÅÄÕÒÅ show_menu
 252                 #
 253                 proc setup_menu {props} {
 254                         variable confsections
 255                         variable menu
 256                         set checkCode ""
 257                         foreach prop [string tolower $props] {
 258                                 if [info exists confsections($prop)] {
 259                                         if {[$menu index end] > 0} {
 260                                                 $menu add separator
 261                                         }
 262                                         foreach {name flags command} $confsections($prop) {
 263                                                 array unset flg
 264                                                 array set flg $flags
 265                                                 if {[info exists flg(pidfile)]} {
 266                                                         if {[string length $flg(pidfile)]} {
 267                                                                 append checkCode [list check_pidfile $name $flg(pidfile) disable normal] "\n"
 268                                                         } else {
 269                                                                 append checkCode [list check_process $name $command disable normal] "\n"
 270                                                         }
 271                                                 } elseif {[info exists flg(!pidfile)]} {
 272                                                         if {[string length $flg(!pidfile)]} {
 273                                                                 append checkCode [list check_pidfile $name $flg(!pidfile) normal disable] "\n"
 274                                                         } else {
 275                                                                 append checkCode [list check_process $name $command normal disable] "\n"
 276                                                         }
 277                                                 }
 278                                                 if {[info exists flg(gui)]} {
 279                                                         set cmd [list ::launch_gui $name $flg(gui) $command]
 280                                                 } elseif {[info exist flg(show)]} {
 281                                                         set cmd [list ::irda::launch_log $name $command]
 282                                                 } else {
 283                                                         set cmd [list ::irda::launch_bacground $name $command]
 284                                                 }
 285                                                 $menu add command -label $name -command $cmd
 286                                         }
 287                                 }
 288                         }
 289                         proc show_menu {} "$checkCode"
 290
 291                 }
 292                 #
 293                 # ðÒÏÃÅÄÕÒÙ ÉÓÐÏÌØÚÕÅÍÙÅ × postcommand
 294                 #
 295                 # ðÒÏ×ÅÒÑÅÔ ÓÕÝÅÓÔ×Ï×ÁÎÉÅ ÕËÁÚÁÎÎÏÇÏ ÆÁÊÌÁ. ÅÓÌÉ ÏÎ ÓÕÝÅÓÔ×ÕÅÔ
 296                 # ×ÙÓÔÁ×ÌÑÅÔ ÓÔÁÔÕÓ ÕÇÁÚÁÎÎÙÊ × ifexists ÉÎÁÞÅ - × ifnotexists
 297                 #
 298                 proc check_pidfile {item file ifexists ifnotexists} {
 299                         variable menu
 300                         if {[file exists $file]} {
 301                                 $menu entryconfig $item -state $ifexists
 302                         } else {
 303                                 $menu entryconfig $item -state $ifnotexists
 304                         }
 305                 }
 306                 #
 307                 # ðÒÏ×ÅÒÑÅÔ ÓÕÝÅÓÔ×Ï×ÁÎÉÅ ÐÒÏÃÅÓÓÁ Ó ÕËÁÚÁÎÎÏÊ ËÏÍÁÎÄÏÊ ÓÔÒÏËÏÊ
 308                 #
 309                 proc check_process {item command ifexists ifnotexists} {
 310                         set f [open "|ps auxww" "r"]
 311                         while {[gets $f line]>=0} {
 312                                 if {[string match *$command $line]} {
 313                                         $menu entryconfig $item -state $ifexists
 314                                         close $f
 315                                         return
 316                                 }
 317                         }
 318                         $menu entryconfig $item -state $ifnotexists
 319                 }
 320                 # ðÒÏÃÅÄÕÒÙ, ÉÓÐÏÌØÚÕÅÍÙÅ ÄÌÑ ÚÁÐÕÓËÁ ËÏÍÁÎÄ
 321                 # åÓÌÉ ÓÕÝÅÓÔ×ÕÅÔ ÏËÎÏ ÕËÁÚÁÎÎÏÇÏ ËÌÁÓÓÁ, ÄÅÌÁÅÔ ÅÍÕ raise
 322                 # ÉÎÁÞÅ - ×ÙÐÏÌÎÑÅÔ ËÏÍÁÎÄÕ
 323                 proc launch_gui {name class command} {
 324                         if [catch package require Fvwm] {
 325                                 ::fvwm::getWindowList a
 326                                 foreach {index value} [array get a "*,class"] {
 327                                         if {$value == "$class"} {
 328                                                 set $id [lindex [split $index ","] 0]
 329                                                 ::fvwm::send Raise $id
 330                                                 ::fvwm::send Focus $id
 331                                                 return
 332                                         }
 333                                 }
 334                         }
 335                         launch_background $name $command
 336                 }
 337                 #
 338                 # úÁÐÕÓËÁÅÔ ËÏÍÁÎÄÕ ÎÁÐÒÁ×ÌÑÑ ÅÅ ×Ù×ÏÄ × ÏËÎÏ
 339                 #
 340                 proc launch_log {name command} {
 341                         set w [uniqueWindow .irda.log]
 342                         wm title $w $name
 343                         text $w.t -yscrollcomand "$w.s set" -width 80 -state disabled
 344                         scrollbar $w.s -command "$w.t yview" -orient vert
 345                         pack $w.t -side left -fill both -expand y
 346                         pack $w.s -side right -fill y -expand n
 347                         set f [open "|$command" r]
 348                         fconfigure $f -blocking no -buffering no
 349                         fileevent $f readable [list ::irda::logInput $f $w.t]
 350                 }
 351
 352                 proc logInput {file window} {
 353                         if {[eof $f]} {
 354                                 if [catch {close $f} msg] {
 355                                         set string "\n********** TERMINATED *******\n$msg"
 356                                 } else {
 357                                         set string "\n*********** FINISHED ***************\n"
 358                                 }
 359                         } else {
 360                                 set string [read $f]
 361                         }
 362                         $w configure -state normal
 363                         $w insert end $string
 364                         $w see end
 365                         $w configure -state disabled
 366                 }
 367
 368                 #
 369                 # úÁÐÕÓËÁÅÔ ËÏÍÁÎÄÕ × ÆÏÎÅ
 370                 #
 371                 proc launch_background {name command} {
 372                         set exec [expandFilename $name $command]
 373                         eval exec $command &
 374                 }
 375
 376
 377                 # ðÏÄÓÔÁ×ÌÑÅÔ ÉÍÑ ÆÁÊÌÁ. ÷ÏÚ×ÒÁÝÁÅÔ -code return
 378                 # ÅÓÌÉ ÐÏÌØÚÏ×ÁÔÅÌØ ÏÔËÁÚÁÌÓÑ ÏÔ ×ÙÂÏÒÁ
 379                 #
 380                 proc expandFilename {name command} {
 381                         if {![regexp -indices {%filename%} $command match]} {
 382                                 #nothig to substitute
 383                                 return $command
 384                         }
 385                         if {![string length [set filename [tk_openFile -title $name]][} {
 386                                 #operation cancelled
 387                                 return -code return
 388                         }
 389                         return [eval string replace [list $command] $match [list $filename]]
 390                 }
 391
 392                 #setting up an interface
 393                 canvas $canvas -width 32 -height 16
 394             pack $canvas -side right
 395                 menu $menu -postcommand ::irda::show_menu
 396                 bind $canvas <1> "$menu post \[winfo rootx %W\] \[expr \[winfo rooty .\]+\[winfo height .\]\]"
 397                 $canvas create image 1 8 -anchor w -image [image create photo\
 398                 -data {R0lGODlhEAAQAIAAAAAAAP///yH5BAEKAAEALAAAAAAQABAAQAIojI8AGKr2XluJSskgnVkf
 399 zHnX9lkL2IVptXouM4aOKdOiXbpo/q5gAQA7}]
 400                 #
 401                 # Hint window management
 402                 #
 403                 toplevel $canvas.hint
 404                 wm overrideredirect $canvas.hint y
 405                 wm withdraw $canvas.hint
 406                 label $canvas.hint.l -textvar ::irda::hint -font 6x10 -background yellow
 407                 pack $canvas.hint.l -side left
 408                 bind $canvas <Enter> ::irda::start_hint
 409                 bind $canvas <Leave> ::irda::cancel_hint
 410                 bind $canvas <Motion> ::irda::reset_hint
 411                 proc start_hint {} {
 412                         variable hint_after_id
 413                         set hint_after_id [after 1000 ::irda::show_hint]
 414                 }
 415                 proc cancel_hint {} {
 416                         variable hint_after_id
 417                         variable canvas
 418                         if [info exists hint_after_id] {
 419                                 after cancel $hint_after_id
 420                                 unset hint_after_id
 421                         }
 422                         if {[wm state $canvas.hint]=="normal"} {
 423                                 wm withdraw $canvas.hint
 424                         }
 425                 }
 426                 proc reset_hint {} {
 427                         cancel_hint
 428                         start_hint
 429                 }
 430                 proc show_hint {} {
 431                         variable canvas
 432                         wm geometry $canvas.hint +[expr [winfo pointerx .]+2]+[expr [winfo pointery .]+2]
 433                         wm deiconify $canvas.hint
 434                         raise $canvas.hint
 435                 }
 436
 437         }
 438         irda::update
 439 }