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