|
0
|
1 /* VMS subprocess and command interface.
|
|
|
2 Copyright (C) 1987, 1988, 1992, 1993 Free Software Foundation, Inc.
|
|
|
3
|
|
|
4 This file is part of XEmacs.
|
|
|
5
|
|
|
6 XEmacs is free software; you can redistribute it and/or modify it
|
|
|
7 under the terms of the GNU General Public License as published by the
|
|
|
8 Free Software Foundation; either version 2, or (at your option) any
|
|
|
9 later version.
|
|
|
10
|
|
|
11 XEmacs is distributed in the hope that it will be useful, but WITHOUT
|
|
|
12 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
|
|
|
13 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
|
|
|
14 for more details.
|
|
|
15
|
|
|
16 You should have received a copy of the GNU General Public License
|
|
|
17 along with XEmacs; see the file COPYING. If not, write to
|
|
|
18 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
|
|
|
19 Boston, MA 02111-1307, USA. */
|
|
|
20
|
|
|
21 /* Synched up with: Not synched with FSF. */
|
|
|
22
|
|
|
23 /* Written by Mukesh Prasad. */
|
|
|
24
|
|
|
25 /*
|
|
|
26 * INTERFACE PROVIDED BY EMACS FOR VMS SUBPROCESSES:
|
|
|
27 *
|
|
|
28 * Emacs provides the following functions:
|
|
|
29 *
|
|
|
30 * "spawn-subprocess", which takes as arguments:
|
|
|
31 *
|
|
|
32 * (i) an integer to identify the spawned subprocess in future
|
|
|
33 * operations,
|
|
|
34 * (ii) A function to process input from the subprocess, and
|
|
|
35 * (iii) A function to be called upon subprocess termination.
|
|
|
36 *
|
|
|
37 * First argument is required. If second argument is missing or nil,
|
|
|
38 * the default action is to insert all received messages at the current
|
|
|
39 * location in the current buffer. If third argument is missing or nil,
|
|
|
40 * no action is taken upon subprocess termination.
|
|
|
41 * The input-handler is called as
|
|
|
42 * (input-handler num string)
|
|
|
43 * where num is the identifying integer for the subprocess and string
|
|
|
44 * is a string received from the subprocess. exit-handler is called
|
|
|
45 * with the identifying integer as the argument.
|
|
|
46 *
|
|
|
47 * "send-command-to-subprocess" takes two arguments:
|
|
|
48 *
|
|
|
49 * (i) Subprocess identifying integer.
|
|
|
50 * (ii) String to send as a message to the subprocess.
|
|
|
51 *
|
|
|
52 * "stop-subprocess" takes the subprocess identifying integer as
|
|
|
53 * argument.
|
|
|
54 *
|
|
|
55 * Implementation is done by spawning an asynchronous subprocess, and
|
|
|
56 * communicating to it via mailboxes.
|
|
|
57 */
|
|
|
58
|
|
|
59 #ifdef VMS
|
|
|
60
|
|
|
61 #include <config.h>
|
|
|
62 #include "lisp.h"
|
|
|
63 #include <descrip.h>
|
|
|
64 #include <dvidef.h>
|
|
|
65 #include <prvdef.h>
|
|
|
66 /* #include <clidef.h> */
|
|
|
67 #include <iodef.h>
|
|
|
68 #include <ssdef.h>
|
|
|
69 #include <errno.h>
|
|
|
70
|
|
|
71 #ifdef VMS4_4 /* I am being cautious; perhaps this exists in older versions */
|
|
|
72 #include <jpidef.h>
|
|
|
73 #endif
|
|
|
74
|
|
|
75 /* #include <syidef.h> */
|
|
|
76
|
|
|
77 #define CLI$M_NOWAIT 1 /* clidef.h is missing from C library */
|
|
|
78 #define SYI$_VERSION 4096 /* syidef.h is missing from C library */
|
|
|
79 #define JPI$_CLINAME 522 /* JPI$_CLINAME is missing from jpidef.h */
|
|
|
80 #define JPI$_MASTER_PID 805 /* JPI$_MASTER_PID missing from jpidef.h */
|
|
|
81 #define LIB$_NOSUCHSYM 1409892 /* libclidef.h missing */
|
|
|
82
|
|
|
83 #define MSGSIZE 160 /* Maximum size for mailbox operations */
|
|
|
84
|
|
|
85 #ifndef PRV$V_ACNT
|
|
|
86
|
|
|
87 /* these defines added as hack for VMS 5.1-1. SJones, 8-17-89 */
|
|
|
88 /* this is _really_ nasty and needs to be changed ASAP - should see about
|
|
|
89 using the union defined in SYS$LIBRARY:PRVDEF.H under v5 */
|
|
|
90
|
|
|
91 #define PRV$V_ACNT 0x09
|
|
|
92 #define PRV$V_ALLSPOOL 0x04
|
|
|
93 #define PRV$V_ALTPRI 0x0D
|
|
|
94 #define PRV$V_BUGCHK 0x17
|
|
|
95 #define PRV$V_BYPASS 0x1D
|
|
|
96 #define PRV$V_CMEXEC 0x01
|
|
|
97 #define PRV$V_CMKRNL 0x00
|
|
|
98 #define PRV$V_DETACH 0x05
|
|
|
99 #define PRV$V_DIAGNOSE 0x06
|
|
|
100 #define PRV$V_DOWNGRADE 0x21
|
|
|
101 #define PRV$V_EXQUOTA 0x13
|
|
|
102 #define PRV$V_GROUP 0x08
|
|
|
103 #define PRV$V_GRPNAM 0x03
|
|
|
104 #define PRV$V_GRPPRV 0x22
|
|
|
105 #define PRV$V_LOG_IO 0x07
|
|
|
106 #define PRV$V_MOUNT 0x11
|
|
|
107 #define PRV$V_NETMBX 0x14
|
|
|
108 #define PRV$V_NOACNT 0x09
|
|
|
109 #define PRV$V_OPER 0x12
|
|
|
110 #define PRV$V_PFNMAP 0x1A
|
|
|
111 #define PRV$V_PHY_IO 0x16
|
|
|
112 #define PRV$V_PRMCEB 0x0A
|
|
|
113 #define PRV$V_PRMGBL 0x18
|
|
|
114 #define PRV$V_PRMJNL 0x25
|
|
|
115 #define PRV$V_PRMMBX 0x0B
|
|
|
116 #define PRV$V_PSWAPM 0x0C
|
|
|
117 #define PRV$V_READALL 0x23
|
|
|
118 #define PRV$V_SECURITY 0x26
|
|
|
119 #define PRV$V_SETPRI 0x0D
|
|
|
120 #define PRV$V_SETPRV 0x0E
|
|
|
121 #define PRV$V_SHARE 0x1F
|
|
|
122 #define PRV$V_SHMEM 0x1B
|
|
|
123 #define PRV$V_SYSGBL 0x19
|
|
|
124 #define PRV$V_SYSLCK 0x1E
|
|
|
125 #define PRV$V_SYSNAM 0x02
|
|
|
126 #define PRV$V_SYSPRV 0x1C
|
|
|
127 #define PRV$V_TMPJNL 0x24
|
|
|
128 #define PRV$V_TMPMBX 0x0F
|
|
|
129 #define PRV$V_UPGRADE 0x20
|
|
|
130 #define PRV$V_VOLPRO 0x15
|
|
|
131 #define PRV$V_WORLD 0x10
|
|
|
132 #endif
|
|
|
133
|
|
|
134 /* IO status block for mailbox operations. */
|
|
|
135 struct mbx_iosb
|
|
|
136 {
|
|
|
137 short status;
|
|
|
138 short size;
|
|
|
139 int pid;
|
|
|
140 };
|
|
|
141
|
|
|
142 /* Structure for maintaining linked list of subprocesses. */
|
|
|
143 struct process_list
|
|
|
144 {
|
|
|
145 int name; /* Numeric identifier for subprocess */
|
|
|
146 int process_id; /* VMS process address */
|
|
|
147 int process_active; /* 1 iff process has not exited yet */
|
|
|
148 int mbx_chan; /* Mailbox channel to write to process */
|
|
|
149 struct mbx_iosb iosb; /* IO status block for write operations */
|
|
|
150 Lisp_Object input_handler; /* Input handler for subprocess */
|
|
|
151 Lisp_Object exit_handler; /* Exit handler for subprocess */
|
|
|
152 struct process_list * next; /* Linked list chain */
|
|
|
153 };
|
|
|
154
|
|
|
155 /* Structure for privilege list. */
|
|
|
156 struct privilege_list
|
|
|
157 {
|
|
|
158 char * name;
|
|
|
159 int mask;
|
|
|
160 };
|
|
|
161
|
|
|
162 /* Structure for finding VMS related information. */
|
|
|
163 struct vms_objlist
|
|
|
164 {
|
|
|
165 char * name; /* Name of object */
|
|
|
166 Lisp_Object (* objfn)(); /* Function to retrieve VMS object */
|
|
|
167 };
|
|
|
168
|
|
|
169 static int exit_ast (); /* Called upon subprocess exit */
|
|
|
170 static int create_mbx (); /* Creates mailbox */
|
|
|
171 static void mbx_msg (); /* Writes null terminated string to mbx */
|
|
|
172 static void write_to_mbx (); /* Writes message to string */
|
|
|
173 static void start_mbx_input (); /* Queues I/O request to mailbox */
|
|
|
174
|
|
|
175 static int input_mbx_chan = 0; /* Channel to read subprocess input on */
|
|
|
176 static char input_mbx_name[20];
|
|
|
177 /* Storage for mailbox device name */
|
|
|
178 static struct dsc$descriptor_s input_mbx_dsc;
|
|
|
179 /* Descriptor for mailbox device name */
|
|
|
180 static struct process_list * process_list = 0;
|
|
|
181 /* Linked list of subprocesses */
|
|
|
182 static char mbx_buffer[MSGSIZE];
|
|
|
183 /* Buffer to read from subprocesses */
|
|
|
184 static struct mbx_iosb input_iosb;
|
|
|
185 /* IO status block for mailbox reads */
|
|
|
186
|
|
|
187 int have_process_input, /* Non-zero iff subprocess input pending */
|
|
|
188 process_exited; /* Non-zero iff suprocess exit pending */
|
|
|
189
|
|
|
190 /* List of privilege names and mask offsets */
|
|
|
191 static struct privilege_list priv_list[] = {
|
|
|
192
|
|
|
193 { "ACNT", PRV$V_ACNT },
|
|
|
194 { "ALLSPOOL", PRV$V_ALLSPOOL },
|
|
|
195 { "ALTPRI", PRV$V_ALTPRI },
|
|
|
196 { "BUGCHK", PRV$V_BUGCHK },
|
|
|
197 { "BYPASS", PRV$V_BYPASS },
|
|
|
198 { "CMEXEC", PRV$V_CMEXEC },
|
|
|
199 { "CMKRNL", PRV$V_CMKRNL },
|
|
|
200 { "DETACH", PRV$V_DETACH },
|
|
|
201 { "DIAGNOSE", PRV$V_DIAGNOSE },
|
|
|
202 { "DOWNGRADE", PRV$V_DOWNGRADE }, /* Isn't VMS as low as you can go? */
|
|
|
203 { "EXQUOTA", PRV$V_EXQUOTA },
|
|
|
204 { "GRPPRV", PRV$V_GRPPRV },
|
|
|
205 { "GROUP", PRV$V_GROUP },
|
|
|
206 { "GRPNAM", PRV$V_GRPNAM },
|
|
|
207 { "LOG_IO", PRV$V_LOG_IO },
|
|
|
208 { "MOUNT", PRV$V_MOUNT },
|
|
|
209 { "NETMBX", PRV$V_NETMBX },
|
|
|
210 { "NOACNT", PRV$V_NOACNT },
|
|
|
211 { "OPER", PRV$V_OPER },
|
|
|
212 { "PFNMAP", PRV$V_PFNMAP },
|
|
|
213 { "PHY_IO", PRV$V_PHY_IO },
|
|
|
214 { "PRMCEB", PRV$V_PRMCEB },
|
|
|
215 { "PRMGBL", PRV$V_PRMGBL },
|
|
|
216 { "PRMJNL", PRV$V_PRMJNL },
|
|
|
217 { "PRMMBX", PRV$V_PRMMBX },
|
|
|
218 { "PSWAPM", PRV$V_PSWAPM },
|
|
|
219 { "READALL", PRV$V_READALL },
|
|
|
220 { "SECURITY", PRV$V_SECURITY },
|
|
|
221 { "SETPRI", PRV$V_SETPRI },
|
|
|
222 { "SETPRV", PRV$V_SETPRV },
|
|
|
223 { "SHARE", PRV$V_SHARE },
|
|
|
224 { "SHMEM", PRV$V_SHMEM },
|
|
|
225 { "SYSGBL", PRV$V_SYSGBL },
|
|
|
226 { "SYSLCK", PRV$V_SYSLCK },
|
|
|
227 { "SYSNAM", PRV$V_SYSNAM },
|
|
|
228 { "SYSPRV", PRV$V_SYSPRV },
|
|
|
229 { "TMPJNL", PRV$V_TMPJNL },
|
|
|
230 { "TMPMBX", PRV$V_TMPMBX },
|
|
|
231 { "UPGRADE", PRV$V_UPGRADE },
|
|
|
232 { "VOLPRO", PRV$V_VOLPRO },
|
|
|
233 { "WORLD", PRV$V_WORLD },
|
|
|
234
|
|
|
235 };
|
|
|
236
|
|
|
237 static Lisp_Object
|
|
|
238 vms_account(), vms_cliname(), vms_owner(), vms_grp(), vms_image(),
|
|
|
239 vms_parent(), vms_pid(), vms_prcnam(), vms_terminal(), vms_uic_int(),
|
|
|
240 vms_uic_str(), vms_username(), vms_version_fn(), vms_trnlog(),
|
|
|
241 vms_symbol(), vms_proclist();
|
|
|
242
|
|
|
243 /* Table of arguments to Fvms_object, and the handlers that get the data. */
|
|
|
244
|
|
|
245 static struct vms_objlist vms_object [] = {
|
|
|
246 { "ACCOUNT", vms_account }, /* Returns account name as a string */
|
|
|
247 { "CLINAME", vms_cliname }, /* Returns CLI name (string) */
|
|
|
248 { "OWNER", vms_owner }, /* Returns owner process's PID (int) */
|
|
|
249 { "GRP", vms_grp }, /* Returns group number of UIC (int) */
|
|
|
250 { "IMAGE", vms_image }, /* Returns executing image (string) */
|
|
|
251 { "PARENT", vms_parent }, /* Returns parent proc's PID (int) */
|
|
|
252 { "PID", vms_pid }, /* Returns process's PID (int) */
|
|
|
253 { "PRCNAM", vms_prcnam }, /* Returns process's name (string) */
|
|
|
254 { "TERMINAL", vms_terminal }, /* Returns terminal name (string) */
|
|
|
255 { "UIC", vms_uic_int }, /* Returns UIC as integer */
|
|
|
256 { "UICGRP", vms_uic_str }, /* Returns UIC as string */
|
|
|
257 { "USERNAME", vms_username }, /* Returns username (string) */
|
|
|
258 { "VERSION", vms_version_fn },/* Returns VMS version (string) */
|
|
|
259 { "LOGICAL", vms_trnlog }, /* Translates VMS logical name */
|
|
|
260 { "DCL-SYMBOL", vms_symbol }, /* Translates DCL symbol */
|
|
|
261 { "PROCLIST", vms_proclist }, /* Returns list of all PIDs on system */
|
|
|
262 };
|
|
|
263
|
|
|
264 Lisp_Object Qdefault_subproc_input_handler;
|
|
|
265
|
|
|
266 extern int process_ef; /* Event flag for subprocess operations */
|
|
|
267
|
|
|
268 DEFUN ("default-subprocess-input-handler",
|
|
|
269 Fdefault_subproc_input_handler, Sdefault_subproc_input_handler,
|
|
|
270 2, 2, 0 /*
|
|
|
271 Default input handler for input from spawned subprocesses.
|
|
|
272 */ )
|
|
|
273 (name, input)
|
|
|
274 Lisp_Object name, input;
|
|
|
275 {
|
|
|
276 /* Just insert in current buffer */
|
|
|
277 buffer_insert1 (current_buffer, input);
|
|
|
278 buffer_insert_c_char ('\n');
|
|
|
279 }
|
|
|
280
|
|
|
281 DEFUN ("spawn-subprocess", Fspawn_subprocess, Sspawn_subprocess, 1, 3, 0 /*
|
|
|
282 Spawn an asynchronous VMS suprocess for command processing.
|
|
|
283 */ )
|
|
|
284 (name, input_handler, exit_handler)
|
|
|
285 Lisp_Object name, input_handler, exit_handler;
|
|
|
286 {
|
|
|
287 /* This function can GC */
|
|
|
288 int status;
|
|
|
289 char output_mbx_name[20];
|
|
|
290 struct dsc$descriptor_s output_mbx_dsc;
|
|
|
291 struct process_list *ptr, *p, *prev;
|
|
|
292
|
|
|
293 CHECK_INT (name);
|
|
|
294 if (! input_mbx_chan)
|
|
|
295 {
|
|
|
296 if (! create_mbx (&input_mbx_dsc, input_mbx_name, &input_mbx_chan, 1))
|
|
|
297 return Qnil;
|
|
|
298 start_mbx_input ();
|
|
|
299 }
|
|
|
300 ptr = 0;
|
|
|
301 prev = 0;
|
|
|
302 while (ptr)
|
|
|
303 {
|
|
|
304 struct process_list *next = ptr->next;
|
|
|
305 if (ptr->name == XINT (name))
|
|
|
306 {
|
|
|
307 if (ptr->process_active)
|
|
|
308 return Qt;
|
|
|
309
|
|
|
310 /* Delete this process and run its exit handler. */
|
|
|
311 if (prev)
|
|
|
312 prev->next = next;
|
|
|
313 else
|
|
|
314 process_list = next;
|
|
|
315 if (! NILP (ptr->exit_handler))
|
|
|
316 Feval (Fcons (ptr->exit_handler, Fcons (make_int (ptr->name),
|
|
|
317 Qnil)));
|
|
|
318 sys$dassgn (ptr->mbx_chan);
|
|
|
319 break;
|
|
|
320 }
|
|
|
321 else
|
|
|
322 prev = ptr;
|
|
|
323 ptr = next;
|
|
|
324 }
|
|
|
325 if (! ptr)
|
|
|
326 ptr = xmalloc (sizeof (struct process_list));
|
|
|
327 if (! create_mbx (&output_mbx_dsc, output_mbx_name, &ptr->mbx_chan, 2))
|
|
|
328 {
|
|
|
329 xfree (ptr);
|
|
|
330 return Qnil;
|
|
|
331 }
|
|
|
332 if (NILP (input_handler))
|
|
|
333 input_handler = Qdefault_subproc_input_handler;
|
|
|
334 ptr->input_handler = input_handler;
|
|
|
335 ptr->exit_handler = exit_handler;
|
|
|
336 message ("Creating subprocess...");
|
|
|
337 status = lib$spawn (0, &output_mbx_dsc, &input_mbx_dsc, &CLI$M_NOWAIT, 0,
|
|
|
338 &ptr->process_id, 0, 0, exit_ast, &ptr->process_active);
|
|
|
339 if (! (status & 1))
|
|
|
340 {
|
|
|
341 sys$dassgn (ptr->mbx_chan);
|
|
|
342 xfree (ptr);
|
|
|
343 error ("Unable to spawn subprocess");
|
|
|
344 return Qnil;
|
|
|
345 }
|
|
|
346 ptr->name = XINT (name);
|
|
|
347 ptr->next = process_list;
|
|
|
348 ptr->process_active = 1;
|
|
|
349 process_list = ptr;
|
|
|
350 message ("Creating subprocess...done");
|
|
|
351 return Qt;
|
|
|
352 }
|
|
|
353
|
|
|
354 static void
|
|
|
355 mbx_msg (ptr, msg)
|
|
|
356 struct process_list *ptr;
|
|
|
357 char *msg;
|
|
|
358 {
|
|
|
359 write_to_mbx (ptr, msg, strlen (msg));
|
|
|
360 }
|
|
|
361
|
|
|
362 DEFUN ("send-command-to-subprocess",
|
|
|
363 Fsend_command_to_subprocess, Ssend_command_to_subprocess, 2, 2,
|
|
|
364 "sSend command to subprocess: \nsSend subprocess %s command: " /*
|
|
|
365 Send to VMS subprocess named NAME the string COMMAND.
|
|
|
366 */ )
|
|
|
367 (name, command)
|
|
|
368 Lisp_Object name, command;
|
|
|
369 {
|
|
|
370 struct process_list * ptr;
|
|
|
371
|
|
|
372 CHECK_INT (name);
|
|
|
373 CHECK_STRING (command);
|
|
|
374 for (ptr = process_list; ptr; ptr = ptr->next)
|
|
|
375 if (XINT (name) == ptr->name)
|
|
|
376 {
|
|
|
377 write_to_mbx (ptr, string_data (XSTRING (command)),
|
|
|
378 string_length (XSTRING (command)));
|
|
|
379 return Qt;
|
|
|
380 }
|
|
|
381 return Qnil;
|
|
|
382 }
|
|
|
383
|
|
|
384 DEFUN ("stop-subprocess", Fstop_subprocess, Sstop_subprocess, 1, 1,
|
|
|
385 "sStop subprocess: " /*
|
|
|
386 Stop VMS subprocess named NAME.
|
|
|
387 */ )
|
|
|
388 (name)
|
|
|
389 Lisp_Object name;
|
|
|
390 {
|
|
|
391 struct process_list * ptr;
|
|
|
392
|
|
|
393 CHECK_INT (name);
|
|
|
394 for (ptr = process_list; ptr; ptr = ptr->next)
|
|
|
395 if (XINT (name) == ptr->name)
|
|
|
396 {
|
|
|
397 ptr->exit_handler = Qnil;
|
|
|
398 if (sys$delprc (&ptr->process_id, 0) & 1)
|
|
|
399 ptr->process_active = 0;
|
|
|
400 return Qt;
|
|
|
401 }
|
|
|
402 return Qnil;
|
|
|
403 }
|
|
|
404
|
|
|
405 static int
|
|
|
406 exit_ast (active)
|
|
|
407 int * active;
|
|
|
408 {
|
|
|
409 process_exited = 1;
|
|
|
410 *active = 0;
|
|
|
411 sys$setef (process_ef);
|
|
|
412 }
|
|
|
413
|
|
|
414 /* Process to handle input on the input mailbox.
|
|
|
415 * Searches through the list of processes until the matching PID is found,
|
|
|
416 * then calls its input handler.
|
|
|
417 */
|
|
|
418
|
|
|
419 process_command_input ()
|
|
|
420 {
|
|
|
421 /* This function can GC */
|
|
|
422 struct process_list * ptr;
|
|
|
423 char * msg;
|
|
|
424 int msglen;
|
|
|
425 Lisp_Object expr;
|
|
|
426
|
|
|
427 msg = mbx_buffer;
|
|
|
428 msglen = input_iosb.size;
|
|
|
429 /* Hack around VMS oddity of sending extraneous CR/LF characters for
|
|
|
430 * some of the commands (but not most).
|
|
|
431 */
|
|
|
432 if (msglen > 0 && *msg == '\r')
|
|
|
433 {
|
|
|
434 msg++;
|
|
|
435 msglen--;
|
|
|
436 }
|
|
|
437 if (msglen > 0 && msg[msglen - 1] == '\n')
|
|
|
438 msglen--;
|
|
|
439 if (msglen > 0 && msg[msglen - 1] == '\r')
|
|
|
440 msglen--;
|
|
|
441 /* Search for the subprocess in the linked list.
|
|
|
442 */
|
|
|
443 expr = Qnil;
|
|
|
444 for (ptr = process_list; ptr; ptr = ptr->next)
|
|
|
445 if (ptr->process_id == input_iosb.pid)
|
|
|
446 {
|
|
|
447 expr = Fcons (ptr->input_handler,
|
|
|
448 Fcons (make_int (ptr->name),
|
|
|
449 Fcons (make_string (msg, msglen),
|
|
|
450 Qnil)));
|
|
|
451 break;
|
|
|
452 }
|
|
|
453 have_process_input = 0;
|
|
|
454 start_mbx_input ();
|
|
|
455 clear_waiting_for_input (); /* Otherwise Ctl-g will cause crash. JCB */
|
|
|
456 if (! NILP (expr))
|
|
|
457 Feval (expr);
|
|
|
458 }
|
|
|
459
|
|
|
460 /* Searches process list for any processes which have exited. Calls their
|
|
|
461 * exit handlers and removes them from the process list.
|
|
|
462 */
|
|
|
463
|
|
|
464 process_exit ()
|
|
|
465 {
|
|
|
466 /* This function can GC */
|
|
|
467 struct process_list * ptr, * prev, * next;
|
|
|
468
|
|
|
469 process_exited = 0;
|
|
|
470 prev = 0;
|
|
|
471 ptr = process_list;
|
|
|
472 while (ptr)
|
|
|
473 {
|
|
|
474 next = ptr->next;
|
|
|
475 if (! ptr->process_active)
|
|
|
476 {
|
|
|
477 if (prev)
|
|
|
478 prev->next = next;
|
|
|
479 else
|
|
|
480 process_list = next;
|
|
|
481 if (! NILP (ptr->exit_handler))
|
|
|
482 Feval (Fcons (ptr->exit_handler, Fcons (make_int (ptr->name),
|
|
|
483 Qnil)));
|
|
|
484 sys$dassgn (ptr->mbx_chan);
|
|
|
485 xfree (ptr);
|
|
|
486 }
|
|
|
487 else
|
|
|
488 prev = ptr;
|
|
|
489 ptr = next;
|
|
|
490 }
|
|
|
491 }
|
|
|
492
|
|
|
493 /* Called at emacs exit.
|
|
|
494 */
|
|
|
495
|
|
|
496 kill_vms_processes ()
|
|
|
497 {
|
|
|
498 struct process_list * ptr;
|
|
|
499
|
|
|
500 for (ptr = process_list; ptr; ptr = ptr->next)
|
|
|
501 if (ptr->process_active)
|
|
|
502 {
|
|
|
503 sys$dassgn (ptr->mbx_chan);
|
|
|
504 sys$delprc (&ptr->process_id, 0);
|
|
|
505 }
|
|
|
506 sys$dassgn (input_mbx_chan);
|
|
|
507 process_list = 0;
|
|
|
508 input_mbx_chan = 0;
|
|
|
509 }
|
|
|
510
|
|
|
511 /* Creates a temporary mailbox and retrieves its device name in 'buf'.
|
|
|
512 * Makes the descriptor pointed to by 'dsc' refer to this device.
|
|
|
513 * 'buffer_factor' is used to allow sending messages asynchronously
|
|
|
514 * till some point.
|
|
|
515 */
|
|
|
516
|
|
|
517 static int
|
|
|
518 create_mbx (dsc, buf, chan, buffer_factor)
|
|
|
519 struct dsc$descriptor_s *dsc;
|
|
|
520 char *buf;
|
|
|
521 int *chan;
|
|
|
522 int buffer_factor;
|
|
|
523 {
|
|
|
524 int strval[2];
|
|
|
525 int status;
|
|
|
526
|
|
|
527 status = sys$crembx (0, chan, MSGSIZE, MSGSIZE * buffer_factor, 0, 0, 0);
|
|
|
528 if (! (status & 1))
|
|
|
529 {
|
|
|
530 message ("Unable to create mailbox. Need TMPMBX privilege.");
|
|
|
531 return 0;
|
|
|
532 }
|
|
|
533 strval[0] = 16;
|
|
|
534 strval[1] = buf;
|
|
|
535 status = lib$getdvi (&DVI$_DEVNAM, chan, 0, 0, strval,
|
|
|
536 &dsc->dsc$w_length);
|
|
|
537 if (! (status & 1))
|
|
|
538 return 0;
|
|
|
539 dsc->dsc$b_dtype = DSC$K_DTYPE_T;
|
|
|
540 dsc->dsc$b_class = DSC$K_CLASS_S;
|
|
|
541 dsc->dsc$a_pointer = buf;
|
|
|
542 return 1;
|
|
|
543 } /* create_mbx */
|
|
|
544
|
|
|
545 /* AST routine to be called upon receiving mailbox input.
|
|
|
546 * Sets flag telling keyboard routines that input is available.
|
|
|
547 */
|
|
|
548
|
|
|
549 static int
|
|
|
550 mbx_input_ast ()
|
|
|
551 {
|
|
|
552 have_process_input = 1;
|
|
|
553 }
|
|
|
554
|
|
|
555 /* Issue a QIO request on the input mailbox.
|
|
|
556 */
|
|
|
557 static void
|
|
|
558 start_mbx_input ()
|
|
|
559 {
|
|
|
560 sys$qio (process_ef, input_mbx_chan, IO$_READVBLK, &input_iosb,
|
|
|
561 mbx_input_ast, 0, mbx_buffer, sizeof (mbx_buffer),
|
|
|
562 0, 0, 0, 0);
|
|
|
563 }
|
|
|
564
|
|
|
565 /* Send a message to the subprocess input mailbox, without blocking if
|
|
|
566 * possible.
|
|
|
567 */
|
|
|
568 static void
|
|
|
569 write_to_mbx (ptr, buf, len)
|
|
|
570 struct process_list *ptr;
|
|
|
571 char *buf;
|
|
|
572 int len;
|
|
|
573 {
|
|
|
574 sys$qiow (0, ptr->mbx_chan, IO$_WRITEVBLK | IO$M_NOW, &ptr->iosb,
|
|
|
575 0, 0, buf, len, 0, 0, 0, 0);
|
|
|
576 }
|
|
|
577
|
|
|
578 DEFUN ("setprv", Fsetprv, Ssetprv, 1, 3, 0 /*
|
|
|
579 Set or reset a VMS privilege. First arg is privilege name.
|
|
|
580 Second arg is t or nil, indicating whether the privilege is to be
|
|
|
581 set or reset. Default is nil. Returns t if success, nil if not.
|
|
|
582 If third arg is non-nil, does not change privilege, but returns t
|
|
|
583 or nil depending upon whether the privilege is already enabled.
|
|
|
584 */ )
|
|
|
585 (priv, value, getprv)
|
|
|
586 Lisp_Object priv, value, getprv;
|
|
|
587 {
|
|
|
588 int prvmask[2], prvlen, newmask[2];
|
|
|
589 char * prvname;
|
|
|
590 int found, i;
|
|
|
591 struct privilege_list * ptr;
|
|
|
592
|
|
|
593 CHECK_STRING (priv);
|
|
|
594 priv = Fupcase (priv, Fcurrent_buffer ());
|
|
|
595 prvname = string_data (XSTRING (priv));
|
|
|
596 prvlen = string_length (XSTRING (priv));
|
|
|
597 found = 0;
|
|
|
598 prvmask[0] = 0;
|
|
|
599 prvmask[1] = 0;
|
|
|
600 for (i = 0; i < sizeof (priv_list) / sizeof (priv_list[0]); i++)
|
|
|
601 {
|
|
|
602 ptr = &priv_list[i];
|
|
|
603 if (prvlen == strlen (ptr->name) &&
|
|
|
604 memcmp (prvname, ptr->name, prvlen) == 0)
|
|
|
605 {
|
|
|
606 if (ptr->mask >= 32)
|
|
|
607 prvmask[1] = 1 << (ptr->mask % 32);
|
|
|
608 else
|
|
|
609 prvmask[0] = 1 << ptr->mask;
|
|
|
610 found = 1;
|
|
|
611 break;
|
|
|
612 }
|
|
|
613 }
|
|
|
614 if (! found)
|
|
|
615 error ("Unknown privilege name %s", string_data (XSTRING (priv)));
|
|
|
616 if (NILP (getprv))
|
|
|
617 {
|
|
|
618 if (sys$setprv (NILP (value) ? 0 : 1, prvmask, 0, 0) == SS$_NORMAL)
|
|
|
619 return Qt;
|
|
|
620 return Qnil;
|
|
|
621 }
|
|
|
622 /* Get old priv value */
|
|
|
623 if (sys$setprv (0, 0, 0, newmask) != SS$_NORMAL)
|
|
|
624 return Qnil;
|
|
|
625 if ((newmask[0] & prvmask[0])
|
|
|
626 || (newmask[1] & prvmask[1]))
|
|
|
627 return Qt;
|
|
|
628 return Qnil;
|
|
|
629 }
|
|
|
630
|
|
|
631 /* Retrieves VMS system information. */
|
|
|
632
|
|
|
633 #ifdef VMS4_4 /* I don't know whether these functions work in old versions */
|
|
|
634
|
|
|
635 DEFUN ("vms-system-info", Fvms_system_info, Svms_system_info, 1, 3, 0 /*
|
|
|
636 Retrieve VMS process and system information.
|
|
|
637 The first argument (a string) specifies the type of information desired.
|
|
|
638 The other arguments depend on the type you select.
|
|
|
639 For information about a process, the second argument is a process ID
|
|
|
640 or a process name, with the current process as a default.
|
|
|
641 These are the possibilities for the first arg (upper or lower case ok):
|
|
|
642 account Returns account name
|
|
|
643 cliname Returns CLI name
|
|
|
644 owner Returns owner process's PID
|
|
|
645 grp Returns group number
|
|
|
646 parent Returns parent process's PID
|
|
|
647 pid Returns process's PID
|
|
|
648 prcnam Returns process's name
|
|
|
649 terminal Returns terminal name
|
|
|
650 uic Returns UIC number
|
|
|
651 uicgrp Returns formatted [UIC,GRP]
|
|
|
652 username Returns username
|
|
|
653 version Returns VMS version
|
|
|
654 logical Translates VMS logical name (second argument)
|
|
|
655 dcl-symbol Translates DCL symbol (second argument)
|
|
|
656 proclist Returns list of all PIDs on system (needs WORLD privilege).
|
|
|
657 */ )
|
|
|
658 (type, arg1, arg2)
|
|
|
659 Lisp_Object type, arg1, arg2;
|
|
|
660 {
|
|
|
661 int i, typelen;
|
|
|
662 char * typename;
|
|
|
663 struct vms_objlist * ptr;
|
|
|
664
|
|
|
665 CHECK_STRING (type);
|
|
|
666 type = Fupcase (type, Fcurrent_buffer ());
|
|
|
667 typename = string_data (XSTRING (type));
|
|
|
668 typelen = string_length (XSTRING (type));
|
|
|
669 for (i = 0; i < sizeof (vms_object) / sizeof (vms_object[0]); i++)
|
|
|
670 {
|
|
|
671 ptr = &vms_object[i];
|
|
|
672 if (typelen == strlen (ptr->name)
|
|
|
673 && memcpy (typename, ptr->name, typelen) == 0)
|
|
|
674 return (* ptr->objfn)(arg1, arg2);
|
|
|
675 }
|
|
|
676 error ("Unknown object type %s", typename);
|
|
|
677 }
|
|
|
678
|
|
|
679 /* Given a reference to a VMS process, returns its process id. */
|
|
|
680
|
|
|
681 static int
|
|
|
682 translate_id (Lisp_Object pid, int owner)
|
|
|
683 /* if pid is null/0, return owner. If this
|
|
|
684 * flag is 0, return self. */
|
|
|
685 {
|
|
|
686 int status, code, id, i, numeric, size;
|
|
|
687 Bufbyte *p;
|
|
|
688 int prcnam[2];
|
|
|
689
|
|
|
690 if (NILP (pid)
|
|
|
691 || STRINGP (pid) && string_length (XSTRING (pid)) == 0
|
|
|
692 || ZEROP (pid))
|
|
|
693 {
|
|
|
694 code = owner ? JPI$_OWNER : JPI$_PID;
|
|
|
695 status = lib$getjpi (&code, 0, 0, &id);
|
|
|
696 if (! (status & 1))
|
|
|
697 error ("Cannot find %s: %s",
|
|
|
698 owner ? "owner process" : "process id",
|
|
|
699 vmserrstr (status));
|
|
|
700 return (id);
|
|
|
701 }
|
|
|
702 if (INTP (pid))
|
|
|
703 return (XINT (pid));
|
|
|
704 CHECK_STRING (pid);
|
|
|
705 pid = Fupcase (pid, Fcurrent_buffer ());
|
|
|
706 size = string_length (XSTRING (pid));
|
|
|
707 p = string_data (XSTRING (pid));
|
|
|
708 numeric = 1;
|
|
|
709 id = 0;
|
|
|
710 for (i = 0; i < size; i++, p++)
|
|
|
711 if (isxdigit (*p))
|
|
|
712 {
|
|
|
713 id *= 16;
|
|
|
714 if (isdigit (*p))
|
|
|
715 id += *p - '0';
|
|
|
716 else
|
|
|
717 id += *p - 'A' + 10;
|
|
|
718 }
|
|
|
719 else
|
|
|
720 {
|
|
|
721 numeric = 0;
|
|
|
722 break;
|
|
|
723 }
|
|
|
724 if (numeric)
|
|
|
725 return (id);
|
|
|
726 prcnam[0] = string_length (XSTRING (pid));
|
|
|
727 prcnam[1] = string_data (XSTRING (pid));
|
|
|
728 status = lib$getjpi (&JPI$_PID, 0, prcnam, &id);
|
|
|
729 if (! (status & 1))
|
|
|
730 error ("Cannot find process id: %s",
|
|
|
731 vmserrstr (status));
|
|
|
732 return (id);
|
|
|
733 } /* translate_id */
|
|
|
734
|
|
|
735 /* VMS object retrieval functions. */
|
|
|
736
|
|
|
737 static Lisp_Object
|
|
|
738 getjpi (jpicode, arg, numeric)
|
|
|
739 int jpicode; /* Type of GETJPI information */
|
|
|
740 Lisp_Object arg;
|
|
|
741 int numeric; /* 1 if numeric value expected */
|
|
|
742 {
|
|
|
743 int id, status, numval;
|
|
|
744 char str[128];
|
|
|
745 int strdsc[2] = { sizeof (str), str };
|
|
|
746 short strlen;
|
|
|
747
|
|
|
748 id = translate_id (arg, 0);
|
|
|
749 status = lib$getjpi (&jpicode, &id, 0, &numval, strdsc, &strlen);
|
|
|
750 if (! (status & 1))
|
|
|
751 error ("Unable to retrieve information: %s",
|
|
|
752 vmserrstr (status));
|
|
|
753 if (numeric)
|
|
|
754 return (make_int (numval));
|
|
|
755 return (make_string (str, strlen));
|
|
|
756 }
|
|
|
757
|
|
|
758 static Lisp_Object
|
|
|
759 vms_account (arg1, arg2)
|
|
|
760 Lisp_Object arg1, arg2;
|
|
|
761 {
|
|
|
762 return getjpi (JPI$_ACCOUNT, arg1, 0);
|
|
|
763 }
|
|
|
764
|
|
|
765 static Lisp_Object
|
|
|
766 vms_cliname (arg1, arg2)
|
|
|
767 Lisp_Object arg1, arg2;
|
|
|
768 {
|
|
|
769 return getjpi (JPI$_CLINAME, arg1, 0);
|
|
|
770 }
|
|
|
771
|
|
|
772 static Lisp_Object
|
|
|
773 vms_grp (arg1, arg2)
|
|
|
774 Lisp_Object arg1, arg2;
|
|
|
775 {
|
|
|
776 return getjpi (JPI$_GRP, arg1, 1);
|
|
|
777 }
|
|
|
778
|
|
|
779 static Lisp_Object
|
|
|
780 vms_image (arg1, arg2)
|
|
|
781 Lisp_Object arg1, arg2;
|
|
|
782 {
|
|
|
783 return getjpi (JPI$_IMAGNAME, arg1, 0);
|
|
|
784 }
|
|
|
785
|
|
|
786 static Lisp_Object
|
|
|
787 vms_owner (arg1, arg2)
|
|
|
788 Lisp_Object arg1, arg2;
|
|
|
789 {
|
|
|
790 return getjpi (JPI$_OWNER, arg1, 1);
|
|
|
791 }
|
|
|
792
|
|
|
793 static Lisp_Object
|
|
|
794 vms_parent (arg1, arg2)
|
|
|
795 Lisp_Object arg1, arg2;
|
|
|
796 {
|
|
|
797 return getjpi (JPI$_MASTER_PID, arg1, 1);
|
|
|
798 }
|
|
|
799
|
|
|
800 static Lisp_Object
|
|
|
801 vms_pid (arg1, arg2)
|
|
|
802 Lisp_Object arg1, arg2;
|
|
|
803 {
|
|
|
804 return getjpi (JPI$_PID, arg1, 1);
|
|
|
805 }
|
|
|
806
|
|
|
807 static Lisp_Object
|
|
|
808 vms_prcnam (arg1, arg2)
|
|
|
809 Lisp_Object arg1, arg2;
|
|
|
810 {
|
|
|
811 return getjpi (JPI$_PRCNAM, arg1, 0);
|
|
|
812 }
|
|
|
813
|
|
|
814 static Lisp_Object
|
|
|
815 vms_terminal (arg1, arg2)
|
|
|
816 Lisp_Object arg1, arg2;
|
|
|
817 {
|
|
|
818 return getjpi (JPI$_TERMINAL, arg1, 0);
|
|
|
819 }
|
|
|
820
|
|
|
821 static Lisp_Object
|
|
|
822 vms_uic_int (arg1, arg2)
|
|
|
823 Lisp_Object arg1, arg2;
|
|
|
824 {
|
|
|
825 return getjpi (JPI$_UIC, arg1, 1);
|
|
|
826 }
|
|
|
827
|
|
|
828 static Lisp_Object
|
|
|
829 vms_uic_str (arg1, arg2)
|
|
|
830 Lisp_Object arg1, arg2;
|
|
|
831 {
|
|
|
832 return getjpi (JPI$_UIC, arg1, 0);
|
|
|
833 }
|
|
|
834
|
|
|
835 static Lisp_Object
|
|
|
836 vms_username (arg1, arg2)
|
|
|
837 Lisp_Object arg1, arg2;
|
|
|
838 {
|
|
|
839 return getjpi (JPI$_USERNAME, arg1, 0);
|
|
|
840 }
|
|
|
841
|
|
|
842 static Lisp_Object
|
|
|
843 vms_version_fn (arg1, arg2)
|
|
|
844 Lisp_Object arg1, arg2;
|
|
|
845 {
|
|
|
846 char str[40];
|
|
|
847 int status;
|
|
|
848 int strdsc[2] = { sizeof (str), str };
|
|
|
849 short strlen;
|
|
|
850
|
|
|
851 status = lib$getsyi (&SYI$_VERSION, 0, strdsc, &strlen, 0, 0);
|
|
|
852 if (! (status & 1))
|
|
|
853 error ("Unable to obtain version: %s", vmserrstr (status));
|
|
|
854 return (make_string (str, strlen));
|
|
|
855 }
|
|
|
856
|
|
|
857 static Lisp_Object
|
|
|
858 vms_trnlog (arg1, arg2)
|
|
|
859 Lisp_Object arg1, arg2;
|
|
|
860 {
|
|
|
861 char str[100];
|
|
|
862 int status, symdsc[2];
|
|
|
863 int strdsc[2] = { sizeof (str), str };
|
|
|
864 short length, level;
|
|
|
865
|
|
|
866 CHECK_STRING (arg1);
|
|
|
867 symdsc[0] = string_length (XSTRING (arg1));
|
|
|
868 symdsc[1] = string_data (XSTRING (arg1));
|
|
|
869 status = lib$sys_trnlog (symdsc, &length, strdsc);
|
|
|
870 if (! (status & 1))
|
|
|
871 error ("Unable to translate logical name: %s", vmserrstr (status));
|
|
|
872 if (status == SS$_NOTRAN)
|
|
|
873 return (Qnil);
|
|
|
874 return (make_string (str, length));
|
|
|
875 }
|
|
|
876
|
|
|
877 static Lisp_Object
|
|
|
878 vms_symbol (arg1, arg2)
|
|
|
879 Lisp_Object arg1, arg2;
|
|
|
880 {
|
|
|
881 char str[100];
|
|
|
882 int status, symdsc[2];
|
|
|
883 int strdsc[2] = { sizeof (str), str };
|
|
|
884 short length, level;
|
|
|
885
|
|
|
886 CHECK_STRING (arg1);
|
|
|
887 symdsc[0] = string_length (XSTRING (arg1));
|
|
|
888 symdsc[1] = string_data (XSTRING (arg1));
|
|
|
889 status = lib$get_symbol (symdsc, strdsc, &length, &level);
|
|
|
890 if (! (status & 1)) {
|
|
|
891 if (status == LIB$_NOSUCHSYM)
|
|
|
892 return (Qnil);
|
|
|
893 else
|
|
|
894 error ("Unable to translate symbol: %s", vmserrstr (status));
|
|
|
895 }
|
|
|
896 return (make_string (str, length));
|
|
|
897 }
|
|
|
898
|
|
|
899 static Lisp_Object
|
|
|
900 vms_proclist (arg1, arg2)
|
|
|
901 Lisp_Object arg1, arg2;
|
|
|
902 {
|
|
|
903 Lisp_Object retval;
|
|
|
904 int id, status, pid;
|
|
|
905
|
|
|
906 retval = Qnil;
|
|
|
907 pid = -1;
|
|
|
908 for (;;)
|
|
|
909 {
|
|
|
910 status = lib$getjpi (&JPI$_PID, &pid, 0, &id);
|
|
|
911 if (status == SS$_NOMOREPROC)
|
|
|
912 break;
|
|
|
913 if (! (status & 1))
|
|
|
914 error ("Unable to get process ID: %s", vmserrstr (status));
|
|
|
915 retval = Fcons (make_int (id), retval);
|
|
|
916 }
|
|
|
917 return (Fsort (retval, intern ("<")));
|
|
|
918 }
|
|
|
919
|
|
|
920 DEFUN ("shrink-to-icon", Fshrink_to_icon, Sshrink_to_icon, 0, 0, 0 /*
|
|
|
921 If emacs is running in a workstation window, shrink to an icon.
|
|
|
922 */ )
|
|
|
923 ()
|
|
|
924 {
|
|
|
925 static char result[128];
|
|
|
926 static $DESCRIPTOR (result_descriptor, result);
|
|
|
927 static $DESCRIPTOR (tt_name, "TT:");
|
|
|
928 static int chan = 0;
|
|
|
929 static int buf = 0x9d + ('2'<<8) + ('2'<<16) + (0x9c<<24);
|
|
|
930 int status;
|
|
|
931 static int temp = JPI$_TERMINAL;
|
|
|
932
|
|
|
933 status = lib$getjpi (&temp, 0, 0, 0, &result_descriptor, 0);
|
|
|
934 if (status != SS$_NORMAL)
|
|
|
935 error ("Unable to determine terminal type.");
|
|
|
936 if (result[0] != 'W' || result[1] != 'T') /* see if workstation */
|
|
|
937 error ("Can't shrink-to-icon on a non workstation terminal");
|
|
|
938 if (!chan) /* assign channel if not assigned */
|
|
|
939 if ((status = sys$assign (&tt_name, &chan, 0, 0)) != SS$_NORMAL)
|
|
|
940 error ("Can't assign terminal, %d", status);
|
|
|
941 status = sys$qiow (0, chan, IO$_WRITEVBLK+IO$M_BREAKTHRU, 0, 0, 0,
|
|
|
942 &buf, 4, 0, 0, 0, 0);
|
|
|
943 if (status != SS$_NORMAL)
|
|
|
944 error ("Can't shrink-to-icon, %d", status);
|
|
|
945 }
|
|
|
946
|
|
|
947 #endif /* VMS4_4 */
|
|
|
948
|
|
|
949 init_vmsfns (void)
|
|
|
950 {
|
|
|
951 process_list = 0;
|
|
|
952 input_mbx_chan = 0;
|
|
|
953 }
|
|
|
954
|
|
|
955 syms_of_vmsfns (void)
|
|
|
956 {
|
|
|
957 defsubr (&Sdefault_subproc_input_handler);
|
|
|
958 defsubr (&Sspawn_subprocess);
|
|
|
959 defsubr (&Ssend_command_to_subprocess);
|
|
|
960 defsubr (&Sstop_subprocess);
|
|
|
961 defsubr (&Ssetprv);
|
|
|
962 #ifdef VMS4_4
|
|
|
963 defsubr (&Svms_system_info);
|
|
|
964 defsubr (&Sshrink_to_icon);
|
|
|
965 #endif /* VMS4_4 */
|
|
|
966 defsymbol (&Qdefault_subproc_input_handler,
|
|
|
967 "default-subprocess-input-handler");
|
|
|
968 }
|
|
|
969 #endif /* VMS */
|
