70
|
1 ;;; mule-process.el --- Process functions for XEmacs/Mule.
|
|
2
|
|
3 ;; Copyright (C) 1992,93,94,95 Free Software Foundation, Inc.
|
|
4 ;; Copyright (C) 1995 Amdahl Corporation.
|
|
5 ;; Copyright (C) 1995 Sun Microsystems.
|
|
6
|
|
7 ;; This file is part of XEmacs.
|
|
8
|
|
9 ;; XEmacs is free software; you can redistribute it and/or modify it
|
|
10 ;; under the terms of the GNU General Public License as published by
|
|
11 ;; the Free Software Foundation; either version 2, or (at your option)
|
|
12 ;; any later version.
|
|
13
|
|
14 ;; XEmacs is distributed in the hope that it will be useful, but
|
|
15 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
|
17 ;; General Public License for more details.
|
|
18
|
|
19 ;; You should have received a copy of the GNU General Public License
|
|
20 ;; along with XEmacs; see the file COPYING. If not, write to the
|
|
21 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
|
|
22 ;; Boston, MA 02111-1307, USA.
|
|
23
|
|
24 ;;; Commentary:
|
|
25
|
|
26 ;;; split off of mule.el.
|
|
27
|
|
28 ;;; Code:
|
|
29
|
|
30
|
|
31 (defun set-current-process-coding-system (input output)
|
|
32 (interactive
|
|
33 "zCoding-system for process input: \nzCoding-system for process output: ")
|
|
34 (let ((proc (get-buffer-process (current-buffer))))
|
|
35 (if (null proc)
|
|
36 (error "no process")
|
|
37 (set-process-coding-system proc input output)))
|
|
38 (redraw-modeline t))
|
|
39
|
|
40 (defun code-convert-process-arguments (arguments coding-systems)
|
|
41 "Convert the code of ARGUMENTS passed to the process using
|
|
42 input coding-system of CODINGS-SYSTEMS. If you never wants to convert
|
|
43 code of arguments, define this function just to return ARGUMENTS."
|
|
44 (mapcar (function (lambda (arg)
|
|
45 (or (code-convert-string arg 'internal
|
|
46 (cdr coding-systems))
|
|
47 arg)))
|
|
48 arguments))
|
|
49
|
|
50 (defvar call-process-hook nil
|
|
51 "A hook function to decide coding-systems for calling programs.
|
|
52 Before calling programs, call-process and call-process-region call
|
|
53 this function with arguments PROGRAM, BUFFER, START, END and ARGS,
|
|
54 where START and END are nil when called from call-process.
|
|
55 The return value of this function should be a cons of coding-systems
|
|
56 for input and output of the program. The input coding-system
|
|
57 is also used for converting ARGS.
|
|
58 If the value is not cons object, further calling is suppressed.")
|
|
59
|
|
60 (defun call-process (program &optional infile buffer display &rest args)
|
|
61 "Call PROGRAM synchronously in separate process.
|
|
62 The program's input comes from file INFILE (nil means `/dev/null').
|
|
63 Insert output in BUFFER before point; t means current buffer;
|
|
64 nil for BUFFER means discard it; 0 means discard and don't wait.
|
|
65 Fourth arg DISPLAY non-nil means redisplay buffer as output is inserted.
|
|
66 Remaining arguments are strings passed as command arguments to PROGRAM.
|
|
67 If BUFFER is 0, returns immediately with value nil.
|
|
68 Otherwise waits for PROGRAM to terminate
|
|
69 and returns a numeric exit status or a signal description string.
|
|
70 If you quit, the process is killed with SIGINT, or SIGKILL if you
|
|
71 quit again.
|
|
72 The coding-system used for converting ARGS and receiving the output
|
|
73 of PROGRAM default to car and cdr of default-process-coding-system,
|
|
74 but can be changed by `call-process-hook'.
|
|
75 See also `call-process-hook' and `call-process-internal'."
|
|
76 (let ((coding-systems
|
|
77 (if call-process-hook
|
|
78 (apply call-process-hook program buffer nil nil args)
|
|
79 default-process-coding-system)))
|
|
80 (if (consp coding-systems)
|
|
81 (apply 'call-process-internal
|
|
82 program infile buffer display (car coding-systems)
|
|
83 (code-convert-process-arguments args coding-systems)))))
|
|
84
|
|
85 (defun call-process-region (start end program
|
|
86 &optional delete buffer display &rest args)
|
|
87 "Send text from START to END to a process running PROGRAM.
|
|
88 Delete the text if DELETE is non-nil.
|
|
89 Insert output in BUFFER before point; t means current buffer;
|
|
90 nil for BUFFER means discard it; 0 means discard and don't wait.
|
|
91 Sixth arg DISPLAY non-nil means redisplay buffer as output is inserted.
|
|
92 Remaining args are passed to PROGRAM at startup as command args.
|
|
93 Returns nil if BUFFER is 0; otherwise waits for PROGRAM to terminate
|
|
94 and returns a numeric exit status or a signal description string.
|
|
95 If you quit, the process is killed with SIGKILL.
|
|
96 The coding-system used for receiving from the PROGRAM defaults to
|
|
97 car of default-process-coding-system.
|
|
98 The coding-system used for sending the region to the PROGRAM and converting
|
|
99 ARGS default to cdr of default-process-coding-system.
|
|
100 But these can be changed by `call-process-hook'.
|
|
101 See also `call-process-hook' and `call-process'."
|
|
102 (let ((temp (if (eq system-type 'ms-dos)
|
|
103 (let* ((tem (or (getenv "TMP") (getenv "TEMP") "/"))
|
|
104 (temm (aref tem (1- (length tem)))))
|
|
105 (make-temp-name
|
|
106 (concat tem
|
|
107 (if (or (eq temm ?/) (eq temm ?\\)) "" "/")
|
|
108 "em")))
|
|
109 (make-temp-name "/tmp/emacs")))
|
|
110 (coding-systems (if call-process-hook
|
|
111 (apply call-process-hook
|
|
112 program buffer start end args)
|
|
113 default-process-coding-system))
|
|
114 status)
|
|
115 (if (consp coding-systems)
|
|
116 (unwind-protect
|
|
117 (let ((call-process-hook nil)
|
|
118 (default-process-coding-system coding-systems)
|
|
119 (output-coding-system (cdr coding-systems)))
|
|
120 (write-region start end temp nil 'nomessage)
|
|
121 (if delete (delete-region start end))
|
|
122 (setq status
|
|
123 (apply 'call-process program temp buffer display args)))
|
|
124 (delete-file temp)))
|
|
125 status))
|
|
126
|
|
127 (defvar start-process-hook nil
|
|
128 "A hook function to decide coding-systems of process input and output.
|
|
129 Before starting process, start-process calls it with arguments
|
|
130 NAME, BUFFER, PROGRAM, and ARGS [same as those given to start-process].
|
|
131 The return value of this function should be a cons of coding-systems
|
|
132 used while sending and receiving to/from the started process.
|
|
133 If the value is not cons object, further calling is supressed.")
|
|
134
|
|
135 (if (not (eq system-type 'ms-dos))
|
|
136
|
|
137 (defun start-process (name buf program &rest args)
|
|
138 "Start a program in a subprocess. Return the process object for it.
|
|
139 Args are NAME BUFFER PROGRAM &rest PROGRAM-ARGS.
|
|
140 NAME is name for process. It is modified if necessary to make it unique.
|
|
141 BUFFER is the buffer or (buffer-name) to associate with the process.
|
|
142 Process output goes at end of that buffer, unless you specify
|
|
143 an output stream or filter function to handle the output.
|
|
144 BUFFER may be also nil, meaning that this process is not associated
|
|
145 with any buffer.
|
|
146 Third arg is program file name. It is searched for as in the shell.
|
|
147 Remaining arguments are strings to give program as arguments.
|
|
148 The coding-system used for sending and receiving to/from the process are
|
|
149 the value of default-process-coding-system, but can be changed by
|
|
150 `start-process-hook'.
|
|
151 See also `start-process-hook' and `start-process-internal;."
|
|
152 (let ((coding-systems
|
|
153 (if start-process-hook
|
|
154 (apply start-process-hook name buf program args)
|
|
155 default-process-coding-system)))
|
|
156 (if (consp coding-systems)
|
|
157 (let ((process
|
|
158 (apply 'start-process-internal name buf program
|
|
159 (code-convert-process-arguments args coding-systems))))
|
|
160 (set-process-input-coding-system (car coding-systems))
|
|
161 (set-process-output-coding-system (cdr coding-systems))
|
|
162 process))))
|
|
163
|
|
164 (defvar open-network-stream-hook nil
|
|
165 "A hook function to decide coding-systems of input and output for service.
|
|
166 Before starting service, open-network-stream calls this function with arguments
|
|
167 NAME, BUFFER, PROGRAM, and ARGS [same as those given to open-network-stream].
|
|
168 The return value of this function should be a cons of coding-systems
|
|
169 used while sending and receiving to/from the network service.
|
|
170 If the value is not cons object, further calling is supressed.")
|
|
171
|
|
172 (defun open-network-stream (name buf host service)
|
|
173 "Open a TCP connection for a service to a host.
|
|
174 Returns a subprocess-object to represent the connection.
|
|
175 Input and output work as for subprocesses; `delete-process' closes it.
|
|
176 Args are NAME BUFFER HOST SERVICE.
|
|
177 NAME is name for process. It is modified if necessary to make it unique.
|
|
178 BUFFER is the buffer (or buffer-name) to associate with the process.
|
|
179 Process output goes at end of that buffer, unless you specify
|
|
180 an output stream or filter function to handle the output.
|
|
181 BUFFER may be also nil, meaning that this process is not associated
|
|
182 with any buffer
|
|
183 Third arg is name of the host to connect to.
|
|
184 Fourth arg SERVICE is name of the service desired, or an integer
|
|
185 specifying a port number to connect to.
|
|
186 The coding system used for sending and receiving to/from the SERVICE are
|
|
187 the value of default-process-coding-system, but can be changed by
|
|
188 open-network-stream-hook.
|
|
189 See also `open-network-stream-hook' and `open-network-stream-internal'."
|
|
190 (let ((coding-systems
|
|
191 (if open-network-stream-hook
|
|
192 (funcall open-network-stream-hook name buf host service)
|
|
193 default-process-coding-system)))
|
|
194 (if (consp coding-systems)
|
|
195 (let ((process
|
|
196 (open-network-stream-internal
|
|
197 name buf host service)))
|
|
198 (set-process-input-coding-system
|
|
199 (car coding-systems))
|
|
200 (set-process-output-coding-system
|
|
201 (cdr coding-systems))
|
|
202 process))))
|
|
203
|
|
204 )
|
|
205
|
|
206 ;;;
|
|
207 ;;; For process-coding-system
|
|
208 ;;;
|
|
209
|
|
210 (defun default-start-process-hook (name buf program &rest args)
|
|
211 (apply 'find-process-coding-system buf program nil args))
|
|
212
|
|
213 (defun default-open-network-stream-hook (name buf host service)
|
|
214 (find-process-coding-system buf service t host))
|
|
215
|
|
216 (defun default-call-process-hook (program buffer start end &rest args)
|
|
217 (apply 'find-process-coding-system buffer program nil args))
|
|
218
|
|
219 (defun find-process-coding-system (buffer program
|
|
220 &optional servicep &rest args)
|
|
221 "Arguments are BUFFER, PROGRAM, SERVICEP, and ARGS.
|
|
222 BUFFER is output buffer (or its name) of a process or nil.
|
|
223 If SERVICEP is nil, PROGRAM is a path name of a program to be executed
|
|
224 by start-process and ARGS is a list of the arguments.
|
|
225 If SERVICEP is non-nil, PROGRAM is a name of a service
|
|
226 for open-network-stream and ARGS is a list of a host.
|
|
227 The return value is a cons of coding-systems
|
|
228 for input and output for the process.
|
|
229 Please redefine this function as you wish."
|
|
230 (if (eq buffer t) (setq buffer (buffer-name))
|
|
231 (if (bufferp buffer) (setq buffer (buffer-name buffer))
|
|
232 (if (not (stringp buffer)) (setq buffer ""))))
|
|
233
|
|
234 (let ((place (if servicep
|
|
235 (find-service-coding-system program (car args))
|
|
236 (find-program-coding-system buffer program))))
|
|
237 (if place
|
|
238 (cond( (consp (cdr place)) (cdr place))
|
|
239 ( (null (cdr place)) '(nil nil))
|
|
240 ( t (condition-case ()
|
|
241 (apply (cdr place) buffer program servicep args)
|
|
242 (error default-process-coding-system))))
|
|
243 default-process-coding-system)))
|
|
244
|
|
245 (setq start-process-hook 'default-start-process-hook
|
|
246 open-network-stream-hook 'default-open-network-stream-hook
|
|
247 call-process-hook 'default-call-process-hook)
|
|
248
|
|
249 ;;;
|
|
250 ;;; program --> coding-system translation
|
|
251 ;;;
|
|
252
|
|
253 (defun strict-string-match (regexp string &optional start)
|
|
254 (and (eq 0 (string-match regexp string (or start 0)))
|
|
255 (eq (match-end 0) (length string))))
|
|
256
|
|
257 (defvar program-coding-system-alist nil)
|
|
258
|
|
259 (defun define-program-coding-system (buffer program code)
|
|
260 (let* ((key (cons buffer program))
|
|
261 (place (assoc key program-coding-system-alist)))
|
|
262 (if (coding-system-p code)
|
|
263 (setq code (cons code code)))
|
|
264 (if place
|
|
265 (setcdr place code)
|
|
266 (setq place (cons key code))
|
|
267 (setq program-coding-system-alist
|
|
268 (cons place program-coding-system-alist)))
|
|
269 place))
|
|
270
|
|
271 (defun find-program-coding-system (buffer program)
|
|
272 (let ((alist program-coding-system-alist) (place nil))
|
|
273 (while (and alist (null place))
|
|
274 (if (program-coding-system-match buffer program (car (car alist)))
|
|
275 (setq place (car alist)))
|
|
276 (setq alist (cdr alist)))
|
|
277 place))
|
|
278
|
|
279 (defun program-coding-system-match (buffer program patpair)
|
|
280 (let ((bpat (car patpair)) (ppat (cdr patpair)))
|
|
281 (if (and (symbolp ppat) (boundp ppat)
|
|
282 (stringp (symbol-value ppat)))
|
|
283 (setq ppat (symbol-value ppat)))
|
|
284 (and (or (null bpat)
|
|
285 (and (stringp bpat) (string-match bpat buffer)))
|
|
286 (or (null ppat)
|
|
287 (and (stringp ppat)
|
|
288 (or
|
|
289 (strict-string-match ppat program)
|
|
290 (strict-string-match ppat (file-name-nondirectory program))
|
|
291 ))))))
|
|
292
|
|
293 (define-program-coding-system
|
|
294 nil "rsh" 'find-process-coding-system-rsh)
|
|
295
|
|
296 (defun find-process-coding-system-rsh (buffer rsh &optional servicep host
|
|
297 &rest args)
|
|
298 (if (equal (car args) "-l")
|
|
299 (setq args (cdr (cdr args))))
|
|
300 (if (equal (car args) "-n")
|
|
301 (setq args (cdr args)))
|
|
302 (apply 'find-process-coding-system buffer (car args) nil (cdr args)))
|
|
303
|
|
304
|
|
305 ;;;
|
|
306 ;;;
|
|
307 ;;;
|
|
308 (define-program-coding-system
|
|
309 nil (concat exec-directory "env") 'find-process-coding-system-env)
|
|
310
|
|
311 ;;;(defun find-mc-process-code-env (buffer env &optional servicep &rest args)
|
|
312 ;;; (while (string-match "[-=]" (car args))
|
|
313 ;;; (setq args (cdr args)))
|
|
314 ;;; (find-mc-process-code buffer (car args) nil (cdr args)))
|
|
315
|
|
316 ;;;
|
|
317 ;;; coded by nakagawa@titisa.is.titech.ac.jp 1989
|
|
318 ;;; modified by tomura@etl.go.jp
|
|
319 ;;;
|
|
320 ;;; env command syntax: See etc/env.c
|
|
321 ;;; env [ - ]
|
|
322 ;;; ;;; GNU env only
|
|
323 ;;; { variable=value
|
|
324 ;;; | -u variable
|
|
325 ;;; | -unset variable
|
|
326 ;;; | -s variable value
|
|
327 ;;; | -set variable value }*
|
|
328 ;;; [ - | -- ]
|
|
329 ;;; ;;; end of GNU env only
|
|
330 ;;; <program> <args>
|
|
331 ;;;
|
|
332
|
|
333 (defun find-process-coding-system-env (buffer env &optional servicep
|
|
334 &rest args)
|
|
335 (if (string= (car args) "-") (setq args (cdr args)))
|
|
336 (while (or (string-match "=" (car args))
|
|
337 (string= "-s" (car args))
|
|
338 (string= "-set" (car args))
|
|
339 (string= "-u" (car args))
|
|
340 (string= "-unset" (car args)))
|
|
341 (cond((or (string= "-s" (car args))
|
|
342 (string= "-set" (car args)))
|
|
343 (setq args (cdr(cdr(cdr args)))))
|
|
344 ((or (string= "-u" (car args))
|
|
345 (string= "-unset" (car args)))
|
|
346 (setq args (cdr(cdr args))))
|
|
347 (t
|
|
348 (setq args (cdr args)))))
|
|
349 (if (or (string= (car args) "-")
|
|
350 (string= (car args) "--"))
|
|
351 (setq args (cdr args)))
|
|
352 (apply 'find-process-coding-system buffer (car args) nil (cdr args)))
|
|
353
|
|
354 ;;;
|
|
355 ;;; service --> mc code translation
|
|
356 ;;;
|
|
357
|
|
358 (defvar service-coding-system-alist nil)
|
|
359
|
|
360 (defun define-service-coding-system (service host code)
|
|
361 (let* ((key (cons service host))
|
|
362 (place (assoc key service-coding-system-alist)))
|
|
363 (if (coding-system-p code)
|
|
364 (setq code (cons code code)))
|
|
365 (if place
|
|
366 (setcdr place code)
|
|
367 (setq place (cons key code)
|
|
368 service-coding-system-alist (cons place service-coding-system-alist)))
|
|
369 place))
|
|
370
|
|
371 (defun find-service-coding-system (service host)
|
|
372 (let ((alist service-coding-system-alist) (place nil))
|
|
373 (while (and alist (null place))
|
|
374 (if (service-coding-system-match service host (car (car alist)))
|
|
375 (setq place (car alist)))
|
|
376 (setq alist (cdr alist)))
|
|
377 place))
|
|
378
|
|
379 (defun service-coding-system-match (service host patpair)
|
|
380 (let ((spat (car patpair)) (hpat (cdr patpair)))
|
|
381 (and (or (null spat)
|
|
382 (eq service spat)
|
|
383 (and (stringp spat) (stringp service)
|
|
384 (strict-string-match spat service)))
|
|
385 (or (null hpat)
|
|
386 (strict-string-match hpat host)))))
|
|
387
|
|
388 (defvar default-process-coding-system (cons 'autodetect-unix nil)
|
|
389 "Cons of default values used to receive from and send to process.")
|
|
390
|
|
391 (defun set-default-process-coding-system (input output)
|
|
392 "Set default values of input and output coding-system for process to
|
|
393 INPUT and OUTPUT, which should be symbols referring to coding systems."
|
|
394 (interactive
|
|
395 "zDefault coding-system for process input: \nzDefault coding-system for process output: ")
|
|
396 (setq default-process-coding-system (cons input output))
|
|
397 (redraw-modeline t))
|
|
398
|
|
399 ;; For RMAIL and NEWS
|
|
400 ;; Notice! In Korea for mail, use 'iso-2022-kr instead of 'junet.
|
|
401 (define-program-coding-system nil ".*mail.*" 'junet)
|
|
402 (define-program-coding-system nil ".*inews.*" 'junet)
|
|
403 ;; For GNUS
|
|
404 (define-service-coding-system "nntp" nil 'junet-unix)
|
|
405 ;; For MH
|
|
406 (define-program-coding-system nil ".*scan.*" 'junet)
|
|
407 (define-program-coding-system nil ".*inc.*" 'junet)
|
|
408 (define-program-coding-system nil ".*mhl.*" 'junet)
|
|
409 ;; For MIME
|
|
410 (define-program-coding-system nil ".*anno.*" 'junet)
|
|
411 (define-program-coding-system nil ".*rcvstore.*" 'junet)
|
|
412 (setq mh-before-send-letter-hook
|
110
|
413 '(lambda () (set-buffer-file-coding-system 'junet)))
|
70
|
414 ;; For VM
|
|
415 (add-hook 'vm-mode-hooks
|
|
416 '(lambda ()
|
110
|
417 (set-buffer-file-coding-system 'junet)))
|
70
|
418 ;; For Wnn and cWnn
|
|
419 (define-service-coding-system "wnn" nil 'no-conversion)
|
|
420
|
|
421 ;; For shells -- commented out
|
|
422 ;;(define-program-coding-system nil ".*sh.*" '(nil . nil))
|
|
423
|
|
424 ;; For gnus user only
|
|
425 ;(setq gnus-your-domain "your.domain.address"
|
|
426 ; gnus-your-organization "Your site name"
|
|
427 ; gnus-use-generic-from t)
|
|
428
|
|
429 ;; For rnews user only
|
|
430 (setq news-inews-program "/usr/lib/news/inews")
|