File: exmh-bg.MASTER

package info (click to toggle)
exmh 1:2.9.0-1
  • links: PTS
  • area: main
  • in suites: buster
  • size: 4,216 kB
  • sloc: tcl: 38,046; perl: 1,647; makefile: 130; sh: 101; exp: 75; csh: 9; sed: 2
file content (206 lines) | stat: -rwxr-xr-x 5,814 bytes parent folder | download | duplicates (4)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
#!/usr/bin/wish -f
#
# Background processing script for exmh.
# This does stuff and then sends messages to the background module
# in the main exmh application.  In particular, the time-consuming things
# like running inc are done here instead of the main-line.
#
# Copyright (c) 1993-8 Brent Welch
# Copyright (c) 1993 Xerox Corporation.
# Copyright (c) 1996-8 Sun Microsystems
# Use and copying of this software and preparation of derivative works based
# upon this software are permitted. Any distribution of this software or
# derivative works must comply with all applicable United States export
# control laws. This software is made available AS IS, and Xerox Corporation
# and Sun Microsystems
# make no warranty about the software, its performance or its conformity to
# any specification.

#CONFIGURATION
#END CONFIGURATION
# for safety so that old exmh config files don't keep it from starting
set exmh(version) "version 2.8.0 04/21/2012 (/etc/exmh.conf is OLD)"
source /etc/exmh.conf


package require Tk
wm withdraw .

if {$argc < 3} {
    puts stderr "exmh-bg requires some arguments:"
    puts stderr "Usage: exmh-bg interpName libDirectory mh_path"
    exit 1
}

set exmh(interp) [lindex $argv 0]
set exmh(library) [lindex $argv 1]
set mh_path [lindex $argv 2]

proc auto_path_update { path } {
    # Add library directories to the auto_path,
    # ensuring that later paths have precedence
    # and that function override works
    global auto_path
    if [file exists $path/tclIndex] {
	set auto_path "$path $auto_path"
	# auto_reset call eliminated
    }
}
auto_path_update $exmh(library)

# Support per-user directory containing .tcl files.
foreach exmh(userLibrary) [list [glob ~]/.exmh/lib [glob ~]/.tk/exmh] {
    if {[file exists [file join $exmh(userLibrary) tclIndex]]} {
	auto_path_update $exmh(userLibrary)	;# library for new modules
	break
    }
}

# Set up environment variables
Env_Init

proc Exmh_Status { string args } {
    # Just a stub version until we rendez-vous with the front end.
    # If the userLibrary Preferences_Add is done after we define the
    # full blown Exmh_Status, then the auto_path_update and its
    # auto_reset seem to result in the Exmh_Status from main.tcl
    # being faulted in from the library.
    catch {puts stderr "exmh-bg: $string"}
}
# Tk 4.0b3 bogosity
if [catch {tk colormodel .}] {
    rename tk tk-orig
    proc tk { option args } {
	switch -- $option {
	    colormodel {
		if {[winfo depth $args] > 4} {
		    return color
		} else {
		    return monochrome
		}
	    }
	    default {
		return [eval {tk-orig $option} $args]
	    }
	}
    }
}

Preferences_Init ~/.exmh/exmh-defaults $exmh(library)/app-defaults

if [catch {User_Init} err] {
    catch {puts stderr "User_Init: $err"}
}

proc Exmh_Debug { args } {
    global exmh
    if [info exists exmh(pid)] {
	BgRPC Exmh_Debug exmh-bg $args
    } else {
	catch {puts stderr "exmh-bg $args"}
    }
}
# Register ourselves with the UI
proc BgRegister { exmhInterp } {
    global exmh
    set exmh(sendErrors) 0
    if {[catch {
	send $exmhInterp [list Background_Register [winfo name .] [pid]]
    } alist] == 0} {
	# set bg parameters returned as a result of registration
	foreach pair $alist {
	    set _var [lindex $pair 0]
	    set _val [lindex $pair 1]
	    uplevel #0 [list set $_var $_val]
	}
	return 1
    } else {
	if [regexp {no registered interpreter} $alist] {
	    catch {puts stderr "exmh-bg lost UI - exiting."}
	    exit
	}
	catch {puts stderr "BgRegister $alist"}
	return 0
    }
}
set ok 0
foreach try {1 2 3 4 5} {
    set ok [BgRegister $exmh(interp)]
    if {$ok} {
	break
    }
    exec sleep [expr $try*$try]
}
if {! $ok} {
    catch {
	puts stderr \
"exmh-bg cannot rendez-vous with UI - exiting.
  Usually this is because Tk send is not working.
  Check the notes under Frequently Asked Questions #4a and #4b.
  You can find this under the Help menu."
    }
    exit 1
}

proc Exmh_Status { string {color black} } {
    global exmh
    if [info exists exmh(instatus)] {
	catch {puts stderr "exmh-bg: $string"}
	return
    }
    set exmh(instatus) 1
# All this code to evaluate something that should be evaluated in
# the main Exmh interpreter if BgRPC suceeds - and if we call our stub
# Exmh_Status the value is ignored anyhow.
#   if ![info exists exmh(c_st_bg_msgs)] {
#	if {[tk colormodel .] == "color"} {
#	    set exmh(c_st_bg_msgs) [option get . c_st_bg_msgs {}]
#	    if {$exmh(c_st_bg_msgs) == {}} {
#		set exmh(c_st_bg_msgs) [option get . bgMsgColor {}]
#		if {$exmh(c_st_bg_msgs) != {}} {
#		    puts stderr "Warning: old resource bgMsgColor, changed to c_st_bg_msgs"
#		} else {
#		    set exmh(c_st_bg_msgs) "medium sea green"
#		}
#	    }
#	} else {
#	    set exmh(c_st_bg_msgs) [option get . c_st_bg_msgs {}]
#	    if {$exmh(c_st_bg_msgs) == {}} {set exmh(c_st_bg_msgs) black}
#	    if {$exmh(c_st_bg_msgs) != "white" && $exmh(c_st_bg_msgs) != "black"} {
#		set exmh(c_st_bg_msgs) black
#	    }
#	}
#   }
    BgRPC Exmh_Status $string background
    unset exmh(instatus)
}

proc Exmhbg_Done {interp} {
    # Die asynchronously so the front-end gets a response
    # to its send request first.  Set a dead flag so BgRPC
    # doesn't try to talk to the front end
    global exmh
    if {$exmh(interp) == $interp} {
	set exmh(dead) 1
	after 1 {
	    catch {Audit_CheckPoint}
	    destroy .
	}
    }
}

# Now do things periodically.  We fault in routines from
# the regular library of exmh procedures.  The Inc'ing
# routines have been tweaked to understand the (possible)
# split into a separate process, and the above hack to
# Exmh_Status handles the simpler cases.

Mh_Init
Inc_Init
Ftoc_Init		;# Need ftoc(scanWidth)
Flist_Init
Seq_Init                ;# Need seqwin(nevershow)
Post_Init
set busy(style) none
Background_Init
Background_DoPeriodic