1# 2# faces.tcl 3# 4# facesaver support (bitmap display of who sent a message). 5# 6# Copyright (c) 1993 Xerox Corporation. 7# Use and copying of this software and preparation of derivative works based 8# upon this software are permitted. Any distribution of this software or 9# derivative works must comply with all applicable United States export 10# control laws. This software is made available AS IS, and Xerox Corporation 11# makes no warranty about the software, its performance or its conformity to 12# any specification. 13 14#### Faces support 15 16set faces(debug) 0 17proc Dputs args { global faces; if $faces(debug) {puts $args} } 18set faces(timing) 0 19proc Tputs args { global faces; if $faces(timing) {puts $args} } 20 21# Compute faces search path 22proc Face_SetPath {} { 23 global faces env faceCache 24 25 catch {unset faceCache} 26 27 if ![info exists faces(sets)] { 28 if [info exists faces(set)] { 29 # backwards compatibility with old "exmh" script 30 set faces(set,user) $faces(set) 31 set faces(set,unknown) $faces(set) 32 set faces(set,news) $faces(set) 33 } 34 set faces(sets) {user unknown} 35 } 36 37 # tail component for each set 38 set faces(name,user) {$user} 39 set faces(name,unknown) unknown 40 set faces(name,news) unknown 41 42 set faces(defaultDomain) [string tolower \ 43 [string trim $faces(defaultDomain) ". "]] 44 # Build search path 45 foreach set $faces(sets) { 46 set faces(path,$set) {} 47 } 48 set faces(path,news) {} 49 if [info exists env(FACEPATH)] { 50 set faces(base) "" 51 foreach dir [split $env(FACEPATH) :] { 52 foreach set $faces(sets) { 53 if ![file isdirectory $dir] continue 54 if {[lsearch -exact $faces(set,$set) [file tail $dir]] >= 0} { 55 FaceAddPath $set $dir 56 } else { 57 FaceAddPath user $dir 58 FaceAddPath unknown $dir 59 FaceAddPath news $dir 60 } 61 } 62 } 63 } else { 64 set faces(base) $faces(dir)/ 65 foreach set $faces(sets) { 66 foreach dir $faces(set,$set) { 67 if ![file isdirectory $faces(base)$dir] continue 68 FaceAddPath $set $dir 69 } 70 } 71 if [info exists faces(set,news)] { 72 foreach dir $faces(set,news) { 73 if ![file isdirectory $faces(base)$dir] continue 74 FaceAddPath news $dir 75 } 76 } 77 } 78} 79proc FaceAddPath {set dir} { 80 global faces 81 lappend faces(path,$set) $dir 82 set mmap [file exists $faces(base)$dir/machine.tab] 83 set pmap [file exists $faces(base)$dir/people.tab] 84 set faces(map,$dir) [expr ($mmap<<1) + $pmap] 85 if [file isdirectory $faces(base)$dir/MISC] { 86 lappend faces(path,$set) $dir/MISC 87 set faces(map,$dir/MISC) 0 88 } 89} 90 91 92proc Face_Show { fromwho {xface {}} {ximageurl {}} {newsgrps {}} } { 93 global faces faceCache failedURLs exmh 94 95 set xfaceAvail 0 96 set ximageurlAvail 0 97 98 # Don't do any of this if we're on a slow display 99 if {!$exmh(slowDispShowFaces)} { 100 return 0 101 } 102 103 Face_Delete 104 105 # Honor X-Face even if faces is disabled 106 if {$faces(xFaceEnabled) && \ 107 [string compare "" $xface] && \ 108 [string compare "" $faces(xfaceProg)]} { 109 110 if {$faces(rowEnabled) && $faces(defer)} { 111 DeferWork faces(work) [list FaceXFace $xface [FaceAlloc]] 112 } elseif {[FaceXFace $xface] && !$faces(rowEnabled)} { 113 set xfaceAvail 1 114 } 115 } 116 117 # Honor X-Image-URL even if X-Face was displayed or the faces are 118 # disabled 119 if {$faces(xImageUrl) && [string compare "" $ximageurl]} { 120 if {![info exists failedURLs] 121 || ([info exists failedURLs] 122 && [lsearch $failedURLs $ximageurl] == -1)} { 123 if {$faces(rowEnabled) && $faces(defer)} { 124 DeferWork faces(work) \ 125 [list UrlDisplayFace $ximageurl [FaceAlloc]] 126 } elseif {[UrlDisplayFace $ximageurl [FaceAlloc]] 127 && !$faces(rowEnabled)} { 128 set ximageurlAvail 1 129 } 130 } 131 } 132 133 if {$xfaceAvail || $ximageurlAvail} { 134 return 1 135 } 136 137 if {$faces(enabled!) || !$faces(enabled)} { 138 return 0 139 } 140 141 # Check for cached lookup result 142 if [info exists faceCache($fromwho,$newsgrps)] { 143 if [Face_ShowFace $faceCache($fromwho,$newsgrps)] { 144 return 1 145 } 146 unset faceCache($fromwho,$newsgrps) 147 Face_Delete 148 } 149 150 set msg [Exmh_OldStatus] 151 Exmh_Status "Looking up face of $fromwho ..." 152 153 set parts [string tolower [split $fromwho @]] 154 set user [lindex $parts 0] 155 set machine [lindex $parts 1] 156 if {[string length $machine] == 0} { 157 set machine [string tolower $faces(defaultDomain)] 158 } elseif {[string first . $machine] == -1} { 159 append machine . $faces(defaultDomain) 160 } 161 162 set from [split $machine .] 163 set pathlist [FacePathlist $from] 164 165#Exmh_Debug \n$user ==> $pathlist 166 167 set pathlistngfull {} 168 if {[string compare "" $newsgrps]} { 169 set newsgrplist [string tolower [split $newsgrps ,]] 170 foreach ng $newsgrplist { 171 set ngparts [split $ng .] 172 set pathlistng [FacePathNGlist $ngparts] 173 set pathlistngfull [concat $pathlistng $pathlistngfull] 174 } 175 } 176 177 # Loop through Face path 178#Tputs lookup: [time { 179 set matches {} 180 foreach set $faces(sets) { 181 eval set tail $faces(name,$set) 182 foreach dir $faces(path,$set) { 183 set name $tail 184 set map {} 185 if $faces(map,$dir) { 186 if {$faces(map,$dir) & 2} { 187 set map [FacePathlist [split \ 188 [FaceMap $dir/machine.tab $machine] .]] 189# Exmh_Debug $machine => $map 190 } 191 if {$faces(map,$dir) & 1} { 192 set x [FaceMap $dir/people.tab $machine/$name] 193# Exmh_Debug $machine/$name => $x 194 if [string compare "" $x] { 195 set name $x 196 } 197 } 198 } 199 foreach part [concat $map $pathlist] { 200 if {([string match unknown* $dir] || [string match misc* $dir]) 201 && [llength $matches]} { 202 break 203 } 204 set path $dir/$part/$name 205# Exmh_Debug $path 206 # skip non-existent directories 207 if ![file exists $faces(base)$path] continue 208 209 foreach suf $faces(suffix) { 210 if [file exists $faces(base)$path/face.$suf] { 211 lappend matches $path/face.$suf 212 break 213 } 214 } 215 } 216 } 217 } 218# }] 219 eval set tail $faces(name,news) 220 foreach dir $faces(path,news) { 221 set name $tail 222 set map {} 223 foreach part [concat $map $pathlistngfull] { 224# if {([string match unknown* $dir] || [string match misc* $dir]) 225# && [llength $matches]} { 226# break 227# } 228 set path $dir/$part/$name 229# Exmh_Debug $path 230 # skip non-existent directories 231 if ![file exists $faces(base)$path] continue 232 233 foreach suf $faces(suffix) { 234 if [file exists $faces(base)$path/face.$suf] { 235 lappend matches $path/face.$suf 236 break 237 } 238 } 239 } 240 } 241 242# Exmh_Debug Faces matches $matches 243 244 if !$faces(rowEnabled) { 245 foreach face $matches { 246 if [Face_ShowFile $face] { 247 set faceCache($fromwho,$newsgrps) $face 248 Exmh_Status $msg 249 return 1 250 } 251 } 252 # braces around cmdsubst NECESSARY! 253 } elseif {[Face_ShowFace $matches]} { 254 set faceCache($fromwho,$newsgrps) $matches 255 Exmh_Status $msg 256 return 1 257 } 258 259 if [llength $matches] { 260 Exmh_Status "(no working face found)" 261 } else { 262 Exmh_Status "(no face found)" 263 } 264 return 0 265} 266 267proc FacePathlist { from } { 268 set path {} 269 set prefix {} 270 set pathlist {} 271 for {set i [expr [llength $from]-1]} {$i>=0} {incr i -1} { 272 append path $prefix [lindex $from $i] 273 set prefix / 274 set pathlist [linsert $pathlist 0 $path] 275 } 276 lappend pathlist {} 277 return $pathlist 278} 279 280proc FacePathNGlist { ng } { 281 set path {} 282 set prefix {} 283 set pathlist {} 284 for {set i 0} {$i <= [expr [llength $ng]-1]} {incr i 1} { 285 append path $prefix [lindex $ng $i] 286 set prefix / 287 set pathlist [concat $path $pathlist] 288 } 289 lappend pathlist {} 290 return $pathlist 291} 292 293proc Face_Delete {} { 294 global faces 295 296 if [info exists faces(work)] { 297 DeferWorkCancel faces(work) 298 } 299 300 for {set f $faces(avail)} {$f > 0} {incr f -1} { 301 catch { 302 set image [$faces(frame).l$f cget -image] 303 if [string compare "" $image] { 304 $faces(frame).l$f config -image {} 305 image delete $image 306 } 307 } 308 $faces(frame).l$f config -bitmap {} 309 if {$faces(rowEnabled) && [info exists faces(rowbg)]} { 310 $faces(frame).l$f config -bg $faces(rowbg) 311 } 312 } 313 set faces(avail) 0 314 315 if !$faces(rowEnabled) { 316 raise $faces(default) 317 } 318} 319 320proc FaceAlloc {} { 321 global faces 322 323 set new 0 324 if {!$faces(rowEnabled) && $faces(avail)} { 325 catch { 326 set image [$faces(frame).l$faces(avail) cget -image] 327 if [string compare "" $image] { 328 $faces(frame).l$faces(avail) config -image {} 329 image delete $image 330 } 331 } 332 incr faces(avail) -1 ;# make us alloc same label 333 } 334 if {$faces(avail) == $faces(alloc)} { 335 Widget_Label $faces(frame) l[incr faces(alloc)] {left fill} 336 set new 1 337 } 338 set label $faces(frame).l[incr faces(avail)] 339 340 if !$faces(rowEnabled) { 341 if $new { ;# once ever 342 pack forget $label 343 place $label -in $faces(default) 344 } 345 } elseif !$new { 346 $label config -bg $faces(facebg) 347 } 348 349 return $label 350} 351proc Face_BusyParent {} { 352 global faces 353 return $faces(frame) 354} 355proc Face_BusyPlace {busy} { 356 global faces 357 place $busy -in $faces(frame) -anchor c -relx 0.5 -rely 0.5 358 raise $busy 359 update idletasks 360} 361proc Face_BusyDestroy {busy} { 362 global faces 363 catch { 364 destroy $busy 365 # This hack forces the underlying labels to redisplay immediatly 366 $faces(default) config -fg [lindex [$faces(default) config -fg] 4] 367 $faces(frame).l1 config -fg [lindex [$faces(frame).l1 config -fg] 4] 368 } 369} 370proc Face_ShowFace facelist { 371 foreach face $facelist { 372 if ![FaceShowFile $face [FaceAlloc]] { 373 return 0 374 } 375 } 376 return 1 377} 378proc Face_ShowFile facefile { 379 set pane [FaceAlloc] 380 if ![FaceShowFile $facefile $pane] { 381 $pane config -bitmap error 382 return 0 383 } 384 return 1 385} 386proc FaceShowFile {facefile pane} { 387 global faces 388 389 if ![string match /* $facefile] { 390 set facefile $faces(base)$facefile 391 } 392 switch -- [file extension $facefile] { 393 .ppm - .pgm - .pbm - .gif - .xpm { 394 if [catch { 395# Tputs image create: [time { 396 set image [image create photo -file $facefile -palette $faces(palette)] 397# }] 398 if $faces(defer) { 399 DeferWork faces(work) [list $pane config -image $image] \ 400 [list image delete $image] 401 402 } else { 403# Tputs image display: [time { 404 $pane config -image $image 405# }] 406 } 407 } id] { 408 Exmh_Debug FaceShowFile $id 409 return 0 410 } 411 } 412 .xbm { 413 if [catch { 414 $pane config -bitmap @$facefile 415 } id] { 416 Exmh_Debug FaceShowFile $id 417 return 0 418 } 419 } 420 } 421 if !$faces(rowEnabled) { 422 raise $pane 423 } 424 return 1 425} 426 427proc FaceXFace { xface {pane {}}} { 428 global faces 429 Exmh_Status "$faces(xfaceProg)" warning 430# Tputs decode x-face: [time { 431 if [catch {open "| $faces(xfaceProg) > [Env_Tmp]/FACE.[pid].xbm" w} fid] { 432 Exmh_Status $fid error 433 return 0 434 } else { 435 Exmh_Status "$faces(xfaceProg)" 436 } 437 puts $fid $xface 438 if [catch {close $fid} err] { 439 Exmh_Status $err error 440 return 0 441 } 442# }] 443 if [string match "" $pane] { 444 set pane [FaceAlloc] 445 } 446# Tputs show x-face: [time { 447 set ret [FaceShowFile [Env_Tmp]/FACE.[pid].xbm $pane] 448# }] 449 File_Delete [Env_Tmp]/FACE.[pid].xbm 450 Exmh_Status ok 451 return $ret 452} 453 454# 455# Hook for button in faces area 456# 457proc Faces_Button {{cmd ""} {label ""} {pack {left fill}}} { 458 global faces 459 catch {destroy $faces(button)} 460 set faces(button) [Widget_AddBut $faces(frame) b $label $cmd $pack] 461 $faces(button) config -padx 0 -pady 0 462 pack $faces(button) -after $faces(default) 463 return $faces(button) 464} 465proc Faces_ClearButton {} { 466 global faces 467 catch {destroy $faces(button)} 468} 469 470 471# Faces information used to be administered by a pair of ASCII files 472# in the faces directory that associate related machines and faces. 473# EXMH still supports this mechanism, although it's use is discouraged. 474# The machine table machine.tab attaches machines to communities; the line 475# stard=sunaus 476# puts the machine stard in community sunaus. The machine 477# table may be used to alias entire communities; the line 478# wseng.sun.com=eng.sun.com 479# will cause the wseng.sun.com domain to be mapped to the 480# eng.sun.com community. The people table associates a 481# community/alias pair, with a real username. 482# sunaus/rburridge=richb 483# causes the alias rburridge to be translated into the real 484# username richb for the community sunaus 485 486proc FaceMachine {dir machine} { 487 global faces 488 if $faces(mapsEnabled) { 489 set map [FaceMap $dir/machine.tab $machine] 490 if [string compare "" $map] { 491 return $map 492 } 493 } 494 return $machine 495} 496proc FacePeople {dir machine people} { 497 global faces 498 if $faces(mapsEnabled) { 499 set map [FaceMap $dir/people.tab $machine/$people] 500 switch -- [llength $map] { 501 0 {} 502 1 {return [list $machine $map]} 503 default {return $map} 504 } 505 } 506 return [list $machine $people] 507} 508proc FaceMap {file item} { 509 global faceMap faces 510 if [info exists faceMap($file,$item)] { 511 return $faceMap($file,$item) 512 } 513 if { [info exists faceMap(modtime,$file)] && 514 ([file mtime $faces(base)$file] <= $faceMap(modtime,$file)) } { 515 return {} 516 } 517# Exmh_Debug FaceMap $file $item 518 if ![catch {open $faces(base)$file} in] { 519 set faceMap(modtime,$file) [file mtime $faces(base)$file] 520 while {[gets $in input] >= 0} { 521 set parts [string tolower [split $input =]] 522 set lhs [string trim [lindex $parts 0]] 523 set rhs [split [string trim [lindex $parts 1]] /] 524 set faceMap($file,$lhs) $rhs 525 } 526 close $in 527 if [info exists faceMap($file,$item)] { 528 return $faceMap($file,$item) 529 } 530 } 531 return {} 532} 533 534proc Face_FlushCache {} { 535 global faceMap faceCache 536 catch {unset faceMap} 537 catch {unset faceCache} 538} 539 540# 541# Defer work to an after handler [this code should be elsewhere] 542# 543 544proc DeferWork {name work {cancel {}}} { 545 upvar #0 $name queue 546 547 lappend queue [list $work $cancel] 548 if {[llength $queue] == 1} { 549 after 50 DeferWorkProc $name 550 } 551} 552proc DeferWorkCancel name { 553 upvar #0 $name queue 554 555 if [info exists queue] { 556 after cancel [list DeferWorkProc $name] 557 foreach w $queue { 558 catch [lindex $w 1] 559 } 560 unset queue 561 } 562} 563proc DeferWorkProc name { 564 upvar #0 $name queue 565 566 set this [lindex $queue 0] 567 set queue [lrange $queue 1 end] 568 catch [lindex $this 0] 569 if [llength $queue] { 570 after 20 DeferWorkProc $name 571 } 572} 573