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