|
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
|
|
20
|
268 DEFUN ("default-subprocess-input-handler", Fdefault_subproc_input_handler, 2, 2, 0, /*
|
|
0
|
269 Default input handler for input from spawned subprocesses.
|
|
20
|
270 */
|
|
|
271 (name, input))
|
|
0
|
272 {
|
|
|
273 /* Just insert in current buffer */
|
|
|
274 buffer_insert1 (current_buffer, input);
|
|
|
275 buffer_insert_c_char ('\n');
|
|
|
276 }
|
|
|
277
|
|
20
|
278 DEFUN ("spawn-subprocess", Fspawn_subprocess, 1, 3, 0, /*
|
|
0
|
279 Spawn an asynchronous VMS suprocess for command processing.
|
|
20
|
280 */
|
|
|
281 (name, input_handler, exit_handler))
|
|
0
|
282 {
|
|
|
283 /* This function can GC */
|
|
|
284 int status;
|
|
|
285 char output_mbx_name[20];
|
|
|
286 struct dsc$descriptor_s output_mbx_dsc;
|
|
|
287 struct process_list *ptr, *p, *prev;
|
|
|
288
|
|
|
289 CHECK_INT (name);
|
|
|
290 if (! input_mbx_chan)
|
|
|
291 {
|
|
|
292 if (! create_mbx (&input_mbx_dsc, input_mbx_name, &input_mbx_chan, 1))
|
|
|
293 return Qnil;
|
|
|
294 start_mbx_input ();
|
|
|
295 }
|
|
|
296 ptr = 0;
|
|
|
297 prev = 0;
|
|
|
298 while (ptr)
|
|
|
299 {
|
|
|
300 struct process_list *next = ptr->next;
|
|
|
301 if (ptr->name == XINT (name))
|
|
|
302 {
|
|
|
303 if (ptr->process_active)
|
|
|
304 return Qt;
|
|
|
305
|
|
|
306 /* Delete this process and run its exit handler. */
|
|
|
307 if (prev)
|
|
|
308 prev->next = next;
|
|
|
309 else
|
|
|
310 process_list = next;
|
|
|
311 if (! NILP (ptr->exit_handler))
|
|
|
312 Feval (Fcons (ptr->exit_handler, Fcons (make_int (ptr->name),
|
|
|
313 Qnil)));
|
|
|
314 sys$dassgn (ptr->mbx_chan);
|
|
|
315 break;
|
|
|
316 }
|
|
|
317 else
|
|
|
318 prev = ptr;
|
|
|
319 ptr = next;
|
|
|
320 }
|
|
|
321 if (! ptr)
|
|
|
322 ptr = xmalloc (sizeof (struct process_list));
|
|
|
323 if (! create_mbx (&output_mbx_dsc, output_mbx_name, &ptr->mbx_chan, 2))
|
|
|
324 {
|
|
|
325 xfree (ptr);
|
|
|
326 return Qnil;
|
|
|
327 }
|
|
|
328 if (NILP (input_handler))
|
|
|
329 input_handler = Qdefault_subproc_input_handler;
|
|
|
330 ptr->input_handler = input_handler;
|
|
|
331 ptr->exit_handler = exit_handler;
|
|
|
332 message ("Creating subprocess...");
|
|
|
333 status = lib$spawn (0, &output_mbx_dsc, &input_mbx_dsc, &CLI$M_NOWAIT, 0,
|
|
|
334 &ptr->process_id, 0, 0, exit_ast, &ptr->process_active);
|
|
|
335 if (! (status & 1))
|
|
|
336 {
|
|
|
337 sys$dassgn (ptr->mbx_chan);
|
|
|
338 xfree (ptr);
|
|
|
339 error ("Unable to spawn subprocess");
|
|
|
340 return Qnil;
|
|
|
341 }
|
|
|
342 ptr->name = XINT (name);
|
|
|
343 ptr->next = process_list;
|
|
|
344 ptr->process_active = 1;
|
|
|
345 process_list = ptr;
|
|
|
346 message ("Creating subprocess...done");
|
|
|
347 return Qt;
|
|
|
348 }
|
|
|
349
|
|
|
350 static void
|
|
|
351 mbx_msg (ptr, msg)
|
|
|
352 struct process_list *ptr;
|
|
|
353 char *msg;
|
|
|
354 {
|
|
|
355 write_to_mbx (ptr, msg, strlen (msg));
|
|
|
356 }
|
|
|
357
|
|
20
|
358 DEFUN ("send-command-to-subprocess", Fsend_command_to_subprocess, 2, 2,
|
|
70
|
359 "sSend command to subprocess: \nsSend subprocess %s command: ", /*
|
|
0
|
360 Send to VMS subprocess named NAME the string COMMAND.
|
|
20
|
361 */
|
|
|
362 (name, command))
|
|
0
|
363 {
|
|
|
364 struct process_list * ptr;
|
|
|
365
|
|
|
366 CHECK_INT (name);
|
|
|
367 CHECK_STRING (command);
|
|
|
368 for (ptr = process_list; ptr; ptr = ptr->next)
|
|
|
369 if (XINT (name) == ptr->name)
|
|
|
370 {
|
|
70
|
371 write_to_mbx (ptr, string_data (XSTRING (command)),
|
|
|
372 string_length (XSTRING (command)));
|
|
0
|
373 return Qt;
|
|
|
374 }
|
|
|
375 return Qnil;
|
|
|
376 }
|
|
|
377
|
|
20
|
378 DEFUN ("stop-subprocess", Fstop_subprocess, 1, 1, "sStop subprocess: ", /*
|
|
0
|
379 Stop VMS subprocess named NAME.
|
|
20
|
380 */
|
|
|
381 (name))
|
|
0
|
382 {
|
|
|
383 struct process_list * ptr;
|
|
|
384
|
|
|
385 CHECK_INT (name);
|
|
|
386 for (ptr = process_list; ptr; ptr = ptr->next)
|
|
|
387 if (XINT (name) == ptr->name)
|
|
|
388 {
|
|
|
389 ptr->exit_handler = Qnil;
|
|
|
390 if (sys$delprc (&ptr->process_id, 0) & 1)
|
|
|
391 ptr->process_active = 0;
|
|
|
392 return Qt;
|
|
|
393 }
|
|
|
394 return Qnil;
|
|
|
395 }
|
|
|
396
|
|
|
397 static int
|
|
|
398 exit_ast (active)
|
|
|
399 int * active;
|
|
|
400 {
|
|
|
401 process_exited = 1;
|
|
|
402 *active = 0;
|
|
|
403 sys$setef (process_ef);
|
|
|
404 }
|
|
|
405
|
|
|
406 /* Process to handle input on the input mailbox.
|
|
|
407 * Searches through the list of processes until the matching PID is found,
|
|
|
408 * then calls its input handler.
|
|
|
409 */
|
|
|
410
|
|
|
411 process_command_input ()
|
|
|
412 {
|
|
|
413 /* This function can GC */
|
|
|
414 struct process_list * ptr;
|
|
|
415 char * msg;
|
|
|
416 int msglen;
|
|
|
417 Lisp_Object expr;
|
|
|
418
|
|
|
419 msg = mbx_buffer;
|
|
|
420 msglen = input_iosb.size;
|
|
|
421 /* Hack around VMS oddity of sending extraneous CR/LF characters for
|
|
|
422 * some of the commands (but not most).
|
|
|
423 */
|
|
|
424 if (msglen > 0 && *msg == '\r')
|
|
|
425 {
|
|
|
426 msg++;
|
|
|
427 msglen--;
|
|
|
428 }
|
|
|
429 if (msglen > 0 && msg[msglen - 1] == '\n')
|
|
|
430 msglen--;
|
|
|
431 if (msglen > 0 && msg[msglen - 1] == '\r')
|
|
|
432 msglen--;
|
|
|
433 /* Search for the subprocess in the linked list.
|
|
|
434 */
|
|
|
435 expr = Qnil;
|
|
|
436 for (ptr = process_list; ptr; ptr = ptr->next)
|
|
|
437 if (ptr->process_id == input_iosb.pid)
|
|
|
438 {
|
|
|
439 expr = Fcons (ptr->input_handler,
|
|
|
440 Fcons (make_int (ptr->name),
|
|
|
441 Fcons (make_string (msg, msglen),
|
|
|
442 Qnil)));
|
|
|
443 break;
|
|
|
444 }
|
|
|
445 have_process_input = 0;
|
|
|
446 start_mbx_input ();
|
|
|
447 clear_waiting_for_input (); /* Otherwise Ctl-g will cause crash. JCB */
|
|
|
448 if (! NILP (expr))
|
|
|
449 Feval (expr);
|
|
|
450 }
|
|
|
451
|
|
|
452 /* Searches process list for any processes which have exited. Calls their
|
|
|
453 * exit handlers and removes them from the process list.
|
|
|
454 */
|
|
|
455
|
|
|
456 process_exit ()
|
|
|
457 {
|
|
|
458 /* This function can GC */
|
|
|
459 struct process_list * ptr, * prev, * next;
|
|
|
460
|
|
|
461 process_exited = 0;
|
|
|
462 prev = 0;
|
|
|
463 ptr = process_list;
|
|
|
464 while (ptr)
|
|
|
465 {
|
|
|
466 next = ptr->next;
|
|
|
467 if (! ptr->process_active)
|
|
|
468 {
|
|
|
469 if (prev)
|
|
|
470 prev->next = next;
|
|
|
471 else
|
|
|
472 process_list = next;
|
|
|
473 if (! NILP (ptr->exit_handler))
|
|
|
474 Feval (Fcons (ptr->exit_handler, Fcons (make_int (ptr->name),
|
|
|
475 Qnil)));
|
|
|
476 sys$dassgn (ptr->mbx_chan);
|
|
|
477 xfree (ptr);
|
|
|
478 }
|
|
|
479 else
|
|
|
480 prev = ptr;
|
|
|
481 ptr = next;
|
|
|
482 }
|
|
|
483 }
|
|
|
484
|
|
|
485 /* Called at emacs exit.
|
|
|
486 */
|
|
|
487
|
|
|
488 kill_vms_processes ()
|
|
|
489 {
|
|
|
490 struct process_list * ptr;
|
|
|
491
|
|
|
492 for (ptr = process_list; ptr; ptr = ptr->next)
|
|
|
493 if (ptr->process_active)
|
|
|
494 {
|
|
|
495 sys$dassgn (ptr->mbx_chan);
|
|
|
496 sys$delprc (&ptr->process_id, 0);
|
|
|
497 }
|
|
|
498 sys$dassgn (input_mbx_chan);
|
|
|
499 process_list = 0;
|
|
|
500 input_mbx_chan = 0;
|
|
|
501 }
|
|
|
502
|
|
|
503 /* Creates a temporary mailbox and retrieves its device name in 'buf'.
|
|
|
504 * Makes the descriptor pointed to by 'dsc' refer to this device.
|
|
|
505 * 'buffer_factor' is used to allow sending messages asynchronously
|
|
|
506 * till some point.
|
|
|
507 */
|
|
|
508
|
|
|
509 static int
|
|
|
510 create_mbx (dsc, buf, chan, buffer_factor)
|
|
|
511 struct dsc$descriptor_s *dsc;
|
|
|
512 char *buf;
|
|
|
513 int *chan;
|
|
|
514 int buffer_factor;
|
|
|
515 {
|
|
|
516 int strval[2];
|
|
|
517 int status;
|
|
|
518
|
|
|
519 status = sys$crembx (0, chan, MSGSIZE, MSGSIZE * buffer_factor, 0, 0, 0);
|
|
|
520 if (! (status & 1))
|
|
|
521 {
|
|
|
522 message ("Unable to create mailbox. Need TMPMBX privilege.");
|
|
|
523 return 0;
|
|
|
524 }
|
|
|
525 strval[0] = 16;
|
|
|
526 strval[1] = buf;
|
|
|
527 status = lib$getdvi (&DVI$_DEVNAM, chan, 0, 0, strval,
|
|
|
528 &dsc->dsc$w_length);
|
|
|
529 if (! (status & 1))
|
|
|
530 return 0;
|
|
|
531 dsc->dsc$b_dtype = DSC$K_DTYPE_T;
|
|
|
532 dsc->dsc$b_class = DSC$K_CLASS_S;
|
|
|
533 dsc->dsc$a_pointer = buf;
|
|
|
534 return 1;
|
|
|
535 } /* create_mbx */
|
|
|
536
|
|
|
537 /* AST routine to be called upon receiving mailbox input.
|
|
|
538 * Sets flag telling keyboard routines that input is available.
|
|
|
539 */
|
|
|
540
|
|
|
541 static int
|
|
|
542 mbx_input_ast ()
|
|
|
543 {
|
|
|
544 have_process_input = 1;
|
|
|
545 }
|
|
|
546
|
|
|
547 /* Issue a QIO request on the input mailbox.
|
|
|
548 */
|
|
|
549 static void
|
|
|
550 start_mbx_input ()
|
|
|
551 {
|
|
|
552 sys$qio (process_ef, input_mbx_chan, IO$_READVBLK, &input_iosb,
|
|
|
553 mbx_input_ast, 0, mbx_buffer, sizeof (mbx_buffer),
|
|
|
554 0, 0, 0, 0);
|
|
|
555 }
|
|
|
556
|
|
|
557 /* Send a message to the subprocess input mailbox, without blocking if
|
|
|
558 * possible.
|
|
|
559 */
|
|
|
560 static void
|
|
|
561 write_to_mbx (ptr, buf, len)
|
|
|
562 struct process_list *ptr;
|
|
|
563 char *buf;
|
|
|
564 int len;
|
|
|
565 {
|
|
|
566 sys$qiow (0, ptr->mbx_chan, IO$_WRITEVBLK | IO$M_NOW, &ptr->iosb,
|
|
|
567 0, 0, buf, len, 0, 0, 0, 0);
|
|
|
568 }
|
|
|
569
|
|
20
|
570 DEFUN ("setprv", Fsetprv, 1, 3, 0, /*
|
|
0
|
571 Set or reset a VMS privilege. First arg is privilege name.
|
|
|
572 Second arg is t or nil, indicating whether the privilege is to be
|
|
|
573 set or reset. Default is nil. Returns t if success, nil if not.
|
|
|
574 If third arg is non-nil, does not change privilege, but returns t
|
|
|
575 or nil depending upon whether the privilege is already enabled.
|
|
20
|
576 */
|
|
|
577 (priv, value, getprv))
|
|
0
|
578 {
|
|
|
579 int prvmask[2], prvlen, newmask[2];
|
|
|
580 char * prvname;
|
|
|
581 int found, i;
|
|
|
582 struct privilege_list * ptr;
|
|
|
583
|
|
|
584 CHECK_STRING (priv);
|
|
|
585 priv = Fupcase (priv, Fcurrent_buffer ());
|
|
70
|
586 prvname = string_data (XSTRING (priv));
|
|
|
587 prvlen = string_length (XSTRING (priv));
|
|
0
|
588 found = 0;
|
|
|
589 prvmask[0] = 0;
|
|
|
590 prvmask[1] = 0;
|
|
|
591 for (i = 0; i < sizeof (priv_list) / sizeof (priv_list[0]); i++)
|
|
|
592 {
|
|
|
593 ptr = &priv_list[i];
|
|
|
594 if (prvlen == strlen (ptr->name) &&
|
|
|
595 memcmp (prvname, ptr->name, prvlen) == 0)
|
|
|
596 {
|
|
|
597 if (ptr->mask >= 32)
|
|
|
598 prvmask[1] = 1 << (ptr->mask % 32);
|
|
|
599 else
|
|
|
600 prvmask[0] = 1 << ptr->mask;
|
|
|
601 found = 1;
|
|
|
602 break;
|
|
|
603 }
|
|
|
604 }
|
|
|
605 if (! found)
|
|
70
|
606 error ("Unknown privilege name %s", string_data (XSTRING (priv)));
|
|
0
|
607 if (NILP (getprv))
|
|
|
608 {
|
|
|
609 if (sys$setprv (NILP (value) ? 0 : 1, prvmask, 0, 0) == SS$_NORMAL)
|
|
|
610 return Qt;
|
|
|
611 return Qnil;
|
|
|
612 }
|
|
|
613 /* Get old priv value */
|
|
|
614 if (sys$setprv (0, 0, 0, newmask) != SS$_NORMAL)
|
|
|
615 return Qnil;
|
|
|
616 if ((newmask[0] & prvmask[0])
|
|
|
617 || (newmask[1] & prvmask[1]))
|
|
|
618 return Qt;
|
|
|
619 return Qnil;
|
|
|
620 }
|
|
|
621
|
|
|
622 /* Retrieves VMS system information. */
|
|
|
623
|
|
|
624 #ifdef VMS4_4 /* I don't know whether these functions work in old versions */
|
|
|
625
|
|
20
|
626 DEFUN ("vms-system-info", Fvms_system_info, 1, 3, 0, /*
|
|
0
|
627 Retrieve VMS process and system information.
|
|
|
628 The first argument (a string) specifies the type of information desired.
|
|
|
629 The other arguments depend on the type you select.
|
|
|
630 For information about a process, the second argument is a process ID
|
|
|
631 or a process name, with the current process as a default.
|
|
|
632 These are the possibilities for the first arg (upper or lower case ok):
|
|
|
633 account Returns account name
|
|
|
634 cliname Returns CLI name
|
|
|
635 owner Returns owner process's PID
|
|
|
636 grp Returns group number
|
|
|
637 parent Returns parent process's PID
|
|
|
638 pid Returns process's PID
|
|
|
639 prcnam Returns process's name
|
|
|
640 terminal Returns terminal name
|
|
|
641 uic Returns UIC number
|
|
|
642 uicgrp Returns formatted [UIC,GRP]
|
|
|
643 username Returns username
|
|
|
644 version Returns VMS version
|
|
|
645 logical Translates VMS logical name (second argument)
|
|
|
646 dcl-symbol Translates DCL symbol (second argument)
|
|
|
647 proclist Returns list of all PIDs on system (needs WORLD privilege).
|
|
20
|
648 */
|
|
|
649 (type, arg1, arg2))
|
|
0
|
650 {
|
|
|
651 int i, typelen;
|
|
|
652 char * typename;
|
|
|
653 struct vms_objlist * ptr;
|
|
|
654
|
|
|
655 CHECK_STRING (type);
|
|
|
656 type = Fupcase (type, Fcurrent_buffer ());
|
|
70
|
657 typename = string_data (XSTRING (type));
|
|
|
658 typelen = string_length (XSTRING (type));
|
|
0
|
659 for (i = 0; i < sizeof (vms_object) / sizeof (vms_object[0]); i++)
|
|
|
660 {
|
|
|
661 ptr = &vms_object[i];
|
|
|
662 if (typelen == strlen (ptr->name)
|
|
|
663 && memcpy (typename, ptr->name, typelen) == 0)
|
|
|
664 return (* ptr->objfn)(arg1, arg2);
|
|
|
665 }
|
|
|
666 error ("Unknown object type %s", typename);
|
|
|
667 }
|
|
|
668
|
|
|
669 /* Given a reference to a VMS process, returns its process id. */
|
|
|
670
|
|
|
671 static int
|
|
|
672 translate_id (Lisp_Object pid, int owner)
|
|
|
673 /* if pid is null/0, return owner. If this
|
|
|
674 * flag is 0, return self. */
|
|
|
675 {
|
|
|
676 int status, code, id, i, numeric, size;
|
|
|
677 Bufbyte *p;
|
|
|
678 int prcnam[2];
|
|
|
679
|
|
|
680 if (NILP (pid)
|
|
70
|
681 || STRINGP (pid) && string_length (XSTRING (pid)) == 0
|
|
0
|
682 || ZEROP (pid))
|
|
|
683 {
|
|
|
684 code = owner ? JPI$_OWNER : JPI$_PID;
|
|
|
685 status = lib$getjpi (&code, 0, 0, &id);
|
|
|
686 if (! (status & 1))
|
|
|
687 error ("Cannot find %s: %s",
|
|
|
688 owner ? "owner process" : "process id",
|
|
|
689 vmserrstr (status));
|
|
|
690 return (id);
|
|
|
691 }
|
|
|
692 if (INTP (pid))
|
|
|
693 return (XINT (pid));
|
|
|
694 CHECK_STRING (pid);
|
|
|
695 pid = Fupcase (pid, Fcurrent_buffer ());
|
|
70
|
696 size = string_length (XSTRING (pid));
|
|
|
697 p = string_data (XSTRING (pid));
|
|
0
|
698 numeric = 1;
|
|
|
699 id = 0;
|
|
|
700 for (i = 0; i < size; i++, p++)
|
|
|
701 if (isxdigit (*p))
|
|
|
702 {
|
|
|
703 id *= 16;
|
|
|
704 if (isdigit (*p))
|
|
|
705 id += *p - '0';
|
|
|
706 else
|
|
|
707 id += *p - 'A' + 10;
|
|
|
708 }
|
|
|
709 else
|
|
|
710 {
|
|
|
711 numeric = 0;
|
|
|
712 break;
|
|
|
713 }
|
|
|
714 if (numeric)
|
|
|
715 return (id);
|
|
70
|
716 prcnam[0] = string_length (XSTRING (pid));
|
|
|
717 prcnam[1] = string_data (XSTRING (pid));
|
|
0
|
718 status = lib$getjpi (&JPI$_PID, 0, prcnam, &id);
|
|
|
719 if (! (status & 1))
|
|
|
720 error ("Cannot find process id: %s",
|
|
|
721 vmserrstr (status));
|
|
|
722 return (id);
|
|
|
723 } /* translate_id */
|
|
|
724
|
|
|
725 /* VMS object retrieval functions. */
|
|
|
726
|
|
|
727 static Lisp_Object
|
|
|
728 getjpi (jpicode, arg, numeric)
|
|
|
729 int jpicode; /* Type of GETJPI information */
|
|
|
730 Lisp_Object arg;
|
|
|
731 int numeric; /* 1 if numeric value expected */
|
|
|
732 {
|
|
|
733 int id, status, numval;
|
|
|
734 char str[128];
|
|
|
735 int strdsc[2] = { sizeof (str), str };
|
|
|
736 short strlen;
|
|
|
737
|
|
|
738 id = translate_id (arg, 0);
|
|
|
739 status = lib$getjpi (&jpicode, &id, 0, &numval, strdsc, &strlen);
|
|
|
740 if (! (status & 1))
|
|
|
741 error ("Unable to retrieve information: %s",
|
|
|
742 vmserrstr (status));
|
|
|
743 if (numeric)
|
|
|
744 return (make_int (numval));
|
|
|
745 return (make_string (str, strlen));
|
|
|
746 }
|
|
|
747
|
|
|
748 static Lisp_Object
|
|
|
749 vms_account (arg1, arg2)
|
|
|
750 Lisp_Object arg1, arg2;
|
|
|
751 {
|
|
|
752 return getjpi (JPI$_ACCOUNT, arg1, 0);
|
|
|
753 }
|
|
|
754
|
|
|
755 static Lisp_Object
|
|
|
756 vms_cliname (arg1, arg2)
|
|
|
757 Lisp_Object arg1, arg2;
|
|
|
758 {
|
|
|
759 return getjpi (JPI$_CLINAME, arg1, 0);
|
|
|
760 }
|
|
|
761
|
|
|
762 static Lisp_Object
|
|
|
763 vms_grp (arg1, arg2)
|
|
|
764 Lisp_Object arg1, arg2;
|
|
|
765 {
|
|
|
766 return getjpi (JPI$_GRP, arg1, 1);
|
|
|
767 }
|
|
|
768
|
|
|
769 static Lisp_Object
|
|
|
770 vms_image (arg1, arg2)
|
|
|
771 Lisp_Object arg1, arg2;
|
|
|
772 {
|
|
|
773 return getjpi (JPI$_IMAGNAME, arg1, 0);
|
|
|
774 }
|
|
|
775
|
|
|
776 static Lisp_Object
|
|
|
777 vms_owner (arg1, arg2)
|
|
|
778 Lisp_Object arg1, arg2;
|
|
|
779 {
|
|
|
780 return getjpi (JPI$_OWNER, arg1, 1);
|
|
|
781 }
|
|
|
782
|
|
|
783 static Lisp_Object
|
|
|
784 vms_parent (arg1, arg2)
|
|
|
785 Lisp_Object arg1, arg2;
|
|
|
786 {
|
|
|
787 return getjpi (JPI$_MASTER_PID, arg1, 1);
|
|
|
788 }
|
|
|
789
|
|
|
790 static Lisp_Object
|
|
|
791 vms_pid (arg1, arg2)
|
|
|
792 Lisp_Object arg1, arg2;
|
|
|
793 {
|
|
|
794 return getjpi (JPI$_PID, arg1, 1);
|
|
|
795 }
|
|
|
796
|
|
|
797 static Lisp_Object
|
|
|
798 vms_prcnam (arg1, arg2)
|
|
|
799 Lisp_Object arg1, arg2;
|
|
|
800 {
|
|
|
801 return getjpi (JPI$_PRCNAM, arg1, 0);
|
|
|
802 }
|
|
|
803
|
|
|
804 static Lisp_Object
|
|
|
805 vms_terminal (arg1, arg2)
|
|
|
806 Lisp_Object arg1, arg2;
|
|
|
807 {
|
|
|
808 return getjpi (JPI$_TERMINAL, arg1, 0);
|
|
|
809 }
|
|
|
810
|
|
|
811 static Lisp_Object
|
|
|
812 vms_uic_int (arg1, arg2)
|
|
|
813 Lisp_Object arg1, arg2;
|
|
|
814 {
|
|
|
815 return getjpi (JPI$_UIC, arg1, 1);
|
|
|
816 }
|
|
|
817
|
|
|
818 static Lisp_Object
|
|
|
819 vms_uic_str (arg1, arg2)
|
|
|
820 Lisp_Object arg1, arg2;
|
|
|
821 {
|
|
|
822 return getjpi (JPI$_UIC, arg1, 0);
|
|
|
823 }
|
|
|
824
|
|
|
825 static Lisp_Object
|
|
|
826 vms_username (arg1, arg2)
|
|
|
827 Lisp_Object arg1, arg2;
|
|
|
828 {
|
|
|
829 return getjpi (JPI$_USERNAME, arg1, 0);
|
|
|
830 }
|
|
|
831
|
|
|
832 static Lisp_Object
|
|
|
833 vms_version_fn (arg1, arg2)
|
|
|
834 Lisp_Object arg1, arg2;
|
|
|
835 {
|
|
|
836 char str[40];
|
|
|
837 int status;
|
|
|
838 int strdsc[2] = { sizeof (str), str };
|
|
|
839 short strlen;
|
|
|
840
|
|
|
841 status = lib$getsyi (&SYI$_VERSION, 0, strdsc, &strlen, 0, 0);
|
|
|
842 if (! (status & 1))
|
|
|
843 error ("Unable to obtain version: %s", vmserrstr (status));
|
|
|
844 return (make_string (str, strlen));
|
|
|
845 }
|
|
|
846
|
|
|
847 static Lisp_Object
|
|
|
848 vms_trnlog (arg1, arg2)
|
|
|
849 Lisp_Object arg1, arg2;
|
|
|
850 {
|
|
|
851 char str[100];
|
|
|
852 int status, symdsc[2];
|
|
|
853 int strdsc[2] = { sizeof (str), str };
|
|
|
854 short length, level;
|
|
|
855
|
|
|
856 CHECK_STRING (arg1);
|
|
70
|
857 symdsc[0] = string_length (XSTRING (arg1));
|
|
|
858 symdsc[1] = string_data (XSTRING (arg1));
|
|
0
|
859 status = lib$sys_trnlog (symdsc, &length, strdsc);
|
|
|
860 if (! (status & 1))
|
|
|
861 error ("Unable to translate logical name: %s", vmserrstr (status));
|
|
|
862 if (status == SS$_NOTRAN)
|
|
|
863 return (Qnil);
|
|
|
864 return (make_string (str, length));
|
|
|
865 }
|
|
|
866
|
|
|
867 static Lisp_Object
|
|
|
868 vms_symbol (arg1, arg2)
|
|
|
869 Lisp_Object arg1, arg2;
|
|
|
870 {
|
|
|
871 char str[100];
|
|
|
872 int status, symdsc[2];
|
|
|
873 int strdsc[2] = { sizeof (str), str };
|
|
|
874 short length, level;
|
|
|
875
|
|
|
876 CHECK_STRING (arg1);
|
|
70
|
877 symdsc[0] = string_length (XSTRING (arg1));
|
|
|
878 symdsc[1] = string_data (XSTRING (arg1));
|
|
0
|
879 status = lib$get_symbol (symdsc, strdsc, &length, &level);
|
|
|
880 if (! (status & 1)) {
|
|
|
881 if (status == LIB$_NOSUCHSYM)
|
|
|
882 return (Qnil);
|
|
|
883 else
|
|
|
884 error ("Unable to translate symbol: %s", vmserrstr (status));
|
|
|
885 }
|
|
|
886 return (make_string (str, length));
|
|
|
887 }
|
|
|
888
|
|
|
889 static Lisp_Object
|
|
|
890 vms_proclist (arg1, arg2)
|
|
|
891 Lisp_Object arg1, arg2;
|
|
|
892 {
|
|
|
893 Lisp_Object retval;
|
|
|
894 int id, status, pid;
|
|
|
895
|
|
|
896 retval = Qnil;
|
|
|
897 pid = -1;
|
|
|
898 for (;;)
|
|
|
899 {
|
|
|
900 status = lib$getjpi (&JPI$_PID, &pid, 0, &id);
|
|
|
901 if (status == SS$_NOMOREPROC)
|
|
|
902 break;
|
|
|
903 if (! (status & 1))
|
|
|
904 error ("Unable to get process ID: %s", vmserrstr (status));
|
|
|
905 retval = Fcons (make_int (id), retval);
|
|
|
906 }
|
|
|
907 return (Fsort (retval, intern ("<")));
|
|
|
908 }
|
|
|
909
|
|
20
|
910 DEFUN ("shrink-to-icon", Fshrink_to_icon, 0, 0, 0, /*
|
|
0
|
911 If emacs is running in a workstation window, shrink to an icon.
|
|
20
|
912 */
|
|
|
913 ())
|
|
0
|
914 {
|
|
|
915 static char result[128];
|
|
|
916 static $DESCRIPTOR (result_descriptor, result);
|
|
|
917 static $DESCRIPTOR (tt_name, "TT:");
|
|
|
918 static int chan = 0;
|
|
|
919 static int buf = 0x9d + ('2'<<8) + ('2'<<16) + (0x9c<<24);
|
|
|
920 int status;
|
|
|
921 static int temp = JPI$_TERMINAL;
|
|
|
922
|
|
|
923 status = lib$getjpi (&temp, 0, 0, 0, &result_descriptor, 0);
|
|
|
924 if (status != SS$_NORMAL)
|
|
|
925 error ("Unable to determine terminal type.");
|
|
|
926 if (result[0] != 'W' || result[1] != 'T') /* see if workstation */
|
|
|
927 error ("Can't shrink-to-icon on a non workstation terminal");
|
|
|
928 if (!chan) /* assign channel if not assigned */
|
|
|
929 if ((status = sys$assign (&tt_name, &chan, 0, 0)) != SS$_NORMAL)
|
|
|
930 error ("Can't assign terminal, %d", status);
|
|
|
931 status = sys$qiow (0, chan, IO$_WRITEVBLK+IO$M_BREAKTHRU, 0, 0, 0,
|
|
|
932 &buf, 4, 0, 0, 0, 0);
|
|
|
933 if (status != SS$_NORMAL)
|
|
|
934 error ("Can't shrink-to-icon, %d", status);
|
|
|
935 }
|
|
|
936
|
|
|
937 #endif /* VMS4_4 */
|
|
|
938
|
|
|
939 init_vmsfns (void)
|
|
|
940 {
|
|
|
941 process_list = 0;
|
|
|
942 input_mbx_chan = 0;
|
|
|
943 }
|
|
|
944
|
|
|
945 syms_of_vmsfns (void)
|
|
|
946 {
|
|
20
|
947 DEFSUBR (Fdefault_subproc_input_handler);
|
|
|
948 DEFSUBR (Fspawn_subprocess);
|
|
|
949 DEFSUBR (Fsend_command_to_subprocess);
|
|
|
950 DEFSUBR (Fstop_subprocess);
|
|
|
951 DEFSUBR (Fsetprv);
|
|
0
|
952 #ifdef VMS4_4
|
|
20
|
953 DEFSUBR (Fvms_system_info);
|
|
|
954 DEFSUBR (Fshrink_to_icon);
|
|
0
|
955 #endif /* VMS4_4 */
|
|
|
956 defsymbol (&Qdefault_subproc_input_handler,
|
|
|
957 "default-subprocess-input-handler");
|
|
|
958 }
|
|
|
959 #endif /* VMS */
|
