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