Mercurial > hg > xemacs-beta

comparison src/vmsfns.c @ 0:376386a54a3c r19-14

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