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