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