Mercurial > hg > xemacs-beta

comparison lisp/mule/mule-process.el @ 70:131b0175ea99 r20-0b30

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-0b30
author cvs
date Mon, 13 Aug 2007 09:02:59 +0200
parents
children fe104dbd9147
comparison
equal deleted inserted replaced
69:804d1389bcd6 70:131b0175ea99
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
413 '(lambda () (set-file-coding-system 'junet)))
414 ;; For VM
415 (add-hook 'vm-mode-hooks
416 '(lambda ()
417 (set-file-coding-system 'junet)))
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")