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