Mercurial > hg > xemacs-beta

comparison src/vmsproc.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 /* Interfaces to subprocesses on VMS.
2 Copyright (C) 1988 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
24 /*
25 Event flag and `select' emulation
26
27 0 is never used
28 1 is the terminal
29 23 is the timer event flag
30 24-31 are reserved by VMS
31 */
32 #include <ssdef.h>
33 #include <iodef.h>
34 #include <dvidef.h>
35 #include <clidef.h>
36 #include "vmsproc.h"
37
38 #define KEYBOARD_EVENT_FLAG 1
39 #define TIMER_EVENT_FLAG 23
40
41 static VMS_PROC_STUFF procList[MAX_EVENT_FLAGS+1];
42
43 get_kbd_event_flag ()
44 {
45 /*
46 Return the first event flag for keyboard input.
47 */
48 VMS_PROC_STUFF *vs = &procList[KEYBOARD_EVENT_FLAG];
49
50 vs->busy = 1;
51 vs->pid = 0;
52 return (vs->eventFlag);
53 }
54
55 get_timer_event_flag ()
56 {
57 /*
58 Return the last event flag for use by timeouts
59 */
60 VMS_PROC_STUFF *vs = &procList[TIMER_EVENT_FLAG];
61
62 vs->busy = 1;
63 vs->pid = 0;
64 return (vs->eventFlag);
65 }
66
67 VMS_PROC_STUFF *
68 get_vms_process_stuff ()
69 {
70 /*
71 Return a process_stuff structure
72
73 We use 1-23 as our event flags to simplify implementing
74 a VMS `select' call.
75 */
76 int i;
77 VMS_PROC_STUFF *vs;
78
79 for (i=1, vs = procList; i<MAX_EVENT_FLAGS; i++, vs++)
80 {
81 if (!vs->busy)
82 {
83 vs->busy = 1;
84 vs->inputChan = 0;
85 vs->pid = 0;
86 sys$clref (vs->eventFlag);
87 return (vs);
88 }
89 }
90 return ((VMS_PROC_STUFF *)0);
91 }
92
93 give_back_vms_process_stuff (vs)
94 VMS_PROC_STUFF *vs;
95 {
96 /*
97 Return an event flag to our pool
98 */
99 vs->busy = 0;
100 vs->inputChan = 0;
101 vs->pid = 0;
102 }
103
104 VMS_PROC_STUFF *
105 get_vms_process_pointer (pid)
106 int pid;
107 {
108 /*
109 Given a pid, return the VMS_STUFF pointer
110 */
111 int i;
112 VMS_PROC_STUFF *vs;
113
114 /* Don't search the last one */
115 for (i=0, vs=procList; i<MAX_EVENT_FLAGS; i++, vs++)
116 {
117 if (vs->busy && vs->pid == pid)
118 return (vs);
119 }
120 return ((VMS_PROC_STUFF *)0);
121 }
122
123 start_vms_process_read (vs)
124 VMS_PROC_STUFF *vs;
125 {
126 /*
127 Start an asynchronous read on a VMS process
128 We will catch up with the output sooner or later
129 */
130 int status;
131 int ProcAst ();
132
133 status = sys$qio (vs->eventFlag, vs->outputChan, IO$_READVBLK,
134 vs->iosb, 0, vs,
135 vs->inputBuffer, sizeof (vs->inputBuffer), 0, 0, 0, 0);
136 if (status != SS$_NORMAL)
137 return (0);
138 else
139 return (1);
140 }
141
142 extern int waiting_for_ast; /* in sysdep.c */
143 extern int timer_ef;
144 extern int input_ef;
145
146 select (nDesc, rdsc, wdsc, edsc, timeOut)
147 int nDesc;
148 int *rdsc;
149 int *wdsc;
150 int *edsc;
151 int *timeOut;
152 {
153 /* Emulate a select call
154
155 We know that we only use event flags 1-23
156
157 timeout == 100000 & bit 0 set means wait on keyboard input until
158 something shows up. If timeout == 0, we just read the event
159 flags and return what we find. */
160
161 int nfds = 0;
162 int status;
163 int time[2];
164 int delta = -10000000;
165 int zero = 0;
166 int timeout = *timeOut;
167 unsigned long mask, readMask, waitMask;
168
169 if (rdsc)
170 readMask = *rdsc << 1; /* Unix mask is shifted over 1 */
171 else
172 readMask = 0; /* Must be a wait call */
173
174 sys$clref (KEYBOARD_EVENT_FLAG);
175 sys$setast (0); /* Block interrupts */
176 sys$readef (KEYBOARD_EVENT_FLAG, &mask); /* See what is set */
177 mask &= readMask; /* Just examine what we need */
178 if (mask == 0)
179 { /* Nothing set, we must wait */
180 if (timeout != 0)
181 { /* Not just inspecting... */
182 if (!(timeout == 100000 &&
183 readMask == (1 << KEYBOARD_EVENT_FLAG)))
184 {
185 lib$emul (&timeout, &delta, &zero, time);
186 sys$setimr (TIMER_EVENT_FLAG, time, 0, 1);
187 waitMask = readMask | (1 << TIMER_EVENT_FLAG);
188 }
189 else
190 waitMask = readMask;
191 if (waitMask & (1 << KEYBOARD_EVENT_FLAG))
192 {
193 sys$clref (KEYBOARD_EVENT_FLAG);
194 waiting_for_ast = 1; /* Only if reading from 0 */
195 }
196 sys$setast (1);
197 sys$wflor (KEYBOARD_EVENT_FLAG, waitMask);
198 sys$cantim (1, 0);
199 sys$readef (KEYBOARD_EVENT_FLAG, &mask);
200 if (readMask & (1 << KEYBOARD_EVENT_FLAG))
201 waiting_for_ast = 0;
202 }
203 }
204 sys$setast (1);
205
206 /*
207 Count number of descriptors that are ready
208 */
209 mask &= readMask;
210 if (rdsc)
211 *rdsc = (mask >> 1); /* Back to Unix format */
212 for (nfds = 0; mask; mask >>= 1)
213 {
214 if (mask & 1)
215 nfds++;
216 }
217 return (nfds);
218 }
219
220 #define MAX_BUFF 1024
221
222 write_to_vms_process (vs, buf, len)
223 VMS_PROC_STUFF *vs;
224 char *buf;
225 int len;
226 {
227 /*
228 Write something to a VMS process.
229
230 We have to map newlines to carriage returns for VMS.
231 */
232 char ourBuff[MAX_BUFF];
233 short iosb[4];
234 int status;
235 int in, out;
236
237 while (len > 0)
238 {
239 out = map_nl_to_cr (buf, ourBuff, len, MAX_BUFF);
240 status = sys$qiow (0, vs->inputChan, IO$_WRITEVBLK|IO$M_NOFORMAT,
241 iosb, 0, 0, ourBuff, out, 0, 0, 0, 0);
242 if (status != SS$_NORMAL || (status = iosb[0]) != SS$_NORMAL)
243 {
244 error ("Could not write to subprocess: %x", status);
245 return (0);
246 }
247 len =- out;
248 }
249 return (1);
250 }
251
252 static
253 map_nl_to_cr (in, out, maxIn, maxOut)
254 char *in;
255 char *out;
256 int maxIn;
257 int maxOut;
258 {
259 /*
260 Copy `in' to `out' remapping `\n' to `\r'
261 */
262 int c;
263 int o;
264
265 for (o=0; maxIn-- > 0 && o < maxOut; o++)
266 {
267 c = *in++;
268 *out++ = (c == '\n') ? '\r' : c;
269 }
270 return (o);
271 }
272
273 clean_vms_buffer (buf, len)
274 char *buf;
275 int len;
276 {
277 /*
278 Sanitize output from a VMS subprocess
279 Strip CR's and NULLs
280 */
281 char *oBuf = buf;
282 char c;
283 int l = 0;
284
285 while (len-- > 0)
286 {
287 c = *buf++;
288 if (c == '\r' || c == '\0')
289 ;
290 else
291 {
292 *oBuf++ = c;
293 l++;
294 }
295 }
296 return (l);
297 }
298
299 /*
300 For the CMU PTY driver
301 */
302 #define PTYNAME "PYA0:"
303
304 get_pty_channel (inDevName, outDevName, inChannel, outChannel)
305 char *inDevName;
306 char *outDevName;
307 int *inChannel;
308 int *outChannel;
309 {
310 int PartnerUnitNumber;
311 int status;
312 struct {
313 int l;
314 char *a;
315 } d;
316 struct {
317 short BufLen;
318 short ItemCode;
319 int *BufAddress;
320 int *ItemLength;
321 } g[2];
322
323 d.l = strlen (PTYNAME);
324 d.a = PTYNAME;
325 *inChannel = 0; /* Should be `short' on VMS */
326 *outChannel = 0;
327 *inDevName = *outDevName = '\0';
328 status = sys$assign (&d, inChannel, 0, 0);
329 if (status == SS$_NORMAL)
330 {
331 *outChannel = *inChannel;
332 g[0].BufLen = sizeof (PartnerUnitNumber);
333 g[0].ItemCode = DVI$_UNIT;
334 g[0].BufAddress = &PartnerUnitNumber;
335 g[0].ItemLength = (int *)0;
336 g[1].BufLen = g[1].ItemCode = 0;
337 status = sys$getdviw (0, *inChannel, 0, &g, 0, 0, 0, 0);
338 if (status == SS$_NORMAL)
339 {
340 sprintf (inDevName, "_TPA%d:", PartnerUnitNumber);
341 strcpy (outDevName, inDevName);
342 }
343 }
344 return (status);
345 }
346
347 VMSgetwd (buf)
348 char *buf;
349 {
350 /*
351 Return the current directory
352 */
353 char curdir[256];
354 char *getenv ();
355 char *s;
356 short len;
357 int status;
358 struct
359 {
360 int l;
361 char *a;
362 } d;
363
364 s = getenv ("SYS$DISK");
365 if (s)
366 strcpy (buf, s);
367 else
368 *buf = '\0';
369
370 d.l = 255;
371 d.a = curdir;
372 status = sys$setddir (0, &len, &d);
373 if (status & 1)
374 {
375 curdir[len] = '\0';
376 strcat (buf, curdir);
377 }
378 }
379
380 static
381 call_process_ast (vs)
382 VMS_PROC_STUFF *vs;
383 {
384 sys$setef (vs->eventFlag);
385 }
386
387 void
388 child_setup (in, out, err, new_argv, env)
389 int in, out, err;
390 char **new_argv;
391 char **env;
392 {
393 /* ??? I suspect that maybe this shouldn't be done on VMS. */
394 /* Close Emacs's descriptors that this process should not have. */
395 close_process_descs ();
396
397 if (STRINGP (current_buffer->directory))
398 chdir (string_data (XSTRING (current_buffer->directory)));
399 }
400
401 DEFUN ("call-process-internal", Fcall_process_internal,
402 Scall_process_internal, 1, MANY, 0 /*
403 Call PROGRAM synchronously in a separate process.
404 Program's input comes from file INFILE (nil means null device, `NLA0:').
405 Insert output in BUFFER before point; t means current buffer;
406 nil for BUFFER means discard it; 0 means discard and don't wait.
407 Fourth arg DISPLAY non-nil means redisplay buffer as output is inserted.
408 Remaining arguments are strings passed as command arguments to PROGRAM.
409 This function waits for PROGRAM to terminate, unless BUFFER is 0;
410 if you quit, the process is killed.
411 */ )
412 (nargs, args)
413 int nargs;
414 Lisp_Object *args;
415 {
416 /* This function can GC */
417 Lisp_Object display, buffer, path;
418 char oldDir[512];
419 int inchannel, outchannel;
420 int len;
421 int call_process_ast ();
422 struct
423 {
424 int l;
425 char *a;
426 } dcmd, din, dout;
427 char inDevName[65];
428 char outDevName[65];
429 short iosb[4];
430 int status;
431 int SpawnFlags = CLI$M_NOWAIT;
432 VMS_PROC_STUFF *vs;
433 VMS_PROC_STUFF *get_vms_process_stuff ();
434 int fd[2];
435 int filefd;
436 int pid;
437 char buf[1024];
438 int speccount = specpdl_depth ();
439 unsigned char **new_argv;
440 struct buffer *old = current_buffer;
441
442 CHECK_STRING (args[0]);
443
444 if (nargs <= 1 || NILP (args[1]))
445 args[1] = build_string ("NLA0:");
446 else
447 args[1] = Fexpand_file_name (args[1],
448 current_buffer->directory);
449
450 CHECK_STRING (args[1]);
451
452 {
453 Lisp_Object tem;
454 buffer = tem = args[2];
455 if (nargs <= 2)
456 buffer = Qnil;
457 else if (!(ZEROP (tem, Qnil) || EQ (tem, Qt) || EQ (tem))
458 {
459 buffer = Fget_buffer (tem);
460 CHECK_BUFFER (buffer);
461 }
462 }
463
464 display = nargs >= 3 ? args[3] : Qnil;
465
466 {
467 /*
468 if (args[0] == "*dcl*" then we need to skip pas the "-c",
469 else args[0] is the program to run.
470 */
471 int i;
472 int arg0;
473 int firstArg;
474
475 if (strcmp (string_data (XSTRING (args[0])), "*dcl*") == 0)
476 {
477 arg0 = 5;
478 firstArg = 6;
479 }
480 else
481 {
482 arg0 = 0;
483 firstArg = 4;
484 }
485 len = string_length (XSTRING (args[arg0])) + 1;
486 for (i = firstArg; i < nargs; i++)
487 {
488 CHECK_STRING (args[i]);
489 len += string_length (XSTRING (args[i])) + 1;
490 }
491 new_argv = alloca (len);
492 strcpy (new_argv, string_data (XSTRING (args[arg0])));
493 for (i = firstArg; i < nargs; i++)
494 {
495 strcat (new_argv, " ");
496 strcat (new_argv, string_data (XSTRING (args[i])));
497 }
498 dcmd.l = len-1;
499 dcmd.a = new_argv;
500
501 status = get_pty_channel (inDevName, outDevName, &inchannel, &outchannel);
502 if (!(status & 1))
503 error ("Error getting PTY channel: %x", status);
504 if (INTP (buffer))
505 {
506 dout.l = strlen ("NLA0:");
507 dout.a = "NLA0:";
508 }
509 else
510 {
511 dout.l = strlen (outDevName);
512 dout.a = outDevName;
513 }
514
515 vs = get_vms_process_stuff ();
516 if (!vs)
517 {
518 sys$dassgn (inchannel);
519 sys$dassgn (outchannel);
520 error ("Too many VMS processes");
521 }
522 vs->inputChan = inchannel;
523 vs->outputChan = outchannel;
524 }
525
526 filefd = open (string_data (XSTRING (args[1])), O_RDONLY, 0);
527 if (filefd < 0)
528 {
529 sys$dassgn (inchannel);
530 sys$dassgn (outchannel);
531 give_back_vms_process_stuff (vs);
532 report_file_error ("Opening process input file", Fcons (args[1], Qnil));
533 }
534 else
535 close (filefd);
536
537 din.l = string_length (XSTRING (args[1]));
538 din.a = string_data (XSTRING (args[1]));
539
540 /*
541 Start a read on the process channel
542 */
543 if (!INTP (buffer))
544 {
545 start_vms_process_read (vs);
546 SpawnFlags = CLI$M_NOWAIT;
547 }
548 else
549 SpawnFlags = 0;
550
551 /*
552 On VMS we need to change the current directory
553 of the parent process before forking so that
554 the child inherit that directory. We remember
555 where we were before changing.
556 */
557 VMSgetwd (oldDir);
558 child_setup (0, 0, 0, 0, 0);
559 status = lib$spawn (&dcmd, &din, &dout, &SpawnFlags, 0, &vs->pid,
560 &vs->exitStatus, 0, call_process_ast, vs);
561 chdir (oldDir);
562
563 if (status != SS$_NORMAL)
564 {
565 sys$dassgn (inchannel);
566 sys$dassgn (outchannel);
567 give_back_vms_process_stuff (vs);
568 error ("Error calling LIB$SPAWN: %x", status);
569 }
570 pid = vs->pid;
571
572 if (INTP (buffer))
573 {
574 #if defined (NO_SUBPROCESSES)
575 wait_without_blocking ();
576 #endif
577 return Qnil;
578 }
579
580 record_unwind_protect (call_process_cleanup,
581 Fcons (make_int (fd[0]), make_int (pid)));
582
583
584 if (BUFFERP (buffer))
585 Fset_buffer (buffer);
586
587 while (1)
588 {
589 QUIT;
590
591 sys$waitfr (vs->eventFlag);
592 if (vs->iosb[0] & 1)
593 {
594 if (!NILP (buffer))
595 {
596 vs->iosb[1] = clean_vms_buffer (vs->inputBuffer, vs->iosb[1]);
597 InsCStr (vs->inputBuffer, vs->iosb[1]);
598 }
599 if (!NILP (display) && INTERACTIVE)
600 redisplay ();
601 QUIT;
602 if (!start_vms_process_read (vs))
603 break; /* The other side went away */
604 }
605 else
606 break;
607 }
608 sys$dassgn (inchannel);
609 sys$dassgn (outchannel);
610 give_back_vms_process_stuff (vs);
611
612 /* Wait for it to terminate, unless it already has. */
613 wait_for_termination (pid);
614
615 set_current_buffer (old);
616
617 return unbind_to (speccount, Qnil);
618 }
619
620 create_process (process, new_argv)
621 Lisp_Object process;
622 char *new_argv;
623 {
624 int pid, inchannel, outchannel, forkin, forkout;
625 char old_dir[512];
626 char in_dev_name[65];
627 char out_dev_name[65];
628 short iosb[4];
629 int status;
630 int spawn_flags = CLI$M_NOWAIT;
631 int child_sig ();
632 struct {
633 int l;
634 char *a;
635 } din, dout, dprompt, dcmd;
636 VMS_PROC_STUFF *vs;
637 VMS_PROC_STUFF *get_vms_process_stuff ();
638
639 status = get_pty_channel (in_dev_name, out_dev_name, &inchannel, &outchannel);
640 if (!(status & 1))
641 {
642 remove_process (process);
643 error ("Error getting PTY channel: %x", status);
644 }
645 dout.l = strlen (out_dev_name);
646 dout.a = out_dev_name;
647 dprompt.l = strlen (DCL_PROMPT);
648 dprompt.a = DCL_PROMPT;
649
650 if (strcmp (new_argv, "*dcl*") == 0)
651 {
652 din.l = strlen (in_dev_name);
653 din.a = in_dev_name;
654 dcmd.l = 0;
655 dcmd.a = (char *)0;
656 }
657 else
658 {
659 din.l = strlen ("NLA0:");
660 din.a = "NLA0:";
661 dcmd.l = strlen (new_argv);
662 dcmd.a = new_argv;
663 }
664
665 /* Delay interrupts until we have a chance to store
666 the new fork's pid in its process structure */
667 sys$setast (0);
668
669 vs = get_vms_process_stuff ();
670 if (vs == 0)
671 {
672 sys$setast (1);
673 remove_process (process);
674 error ("Too many VMS processes");
675 }
676 vs->inputChan = inchannel;
677 vs->outputChan = outchannel;
678
679 /* Start a read on the process channel */
680 start_vms_process_read (vs);
681
682 /* Switch current directory so that the child inherits it. */
683 VMSgetwd (old_dir);
684 child_setup (0, 0, 0, 0, 0);
685
686 status = lib$spawn (&dcmd, &din, &dout, &spawn_flags, 0, &vs->pid,
687 &vs->exitStatus, 0, child_sig, vs, &dprompt);
688 chdir (old_dir);
689
690 if (status != SS$_NORMAL)
691 {
692 sys$setast (1);
693 remove_process (process);
694 error ("Error calling LIB$SPAWN: %x", status);
695 }
696 vs->pid &= 0xffff; /* It needs to fit in a FASTINT,
697 we don't need the rest of the bits */
698 pid = vs->pid;
699
700 /*
701 ON VMS process->infd holds the (event flag-1)
702 that we use for doing I/O on that process.
703 `input_wait_mask' is the cluster of event flags
704 we can wait on.
705
706 Event flags returned start at 1 for the keyboard.
707 Since Unix expects descriptor 0 for the keyboard,
708 we substract one from the event flag.
709 */
710 inchannel = vs->eventFlag-1;
711
712 /* Record this as an active process, with its channels.
713 As a result, child_setup will close Emacs's side of the pipes. */
714 chan_process[inchannel] = process;
715 XPROCESS (process)->infd = make_int (inchannel);
716 XPROCESS (process)->outfd = make_int (outchannel);
717 XPROCESS (process)->flags = make_int (RUNNING);
718
719 /* Delay interrupts until we have a chance to store
720 the new fork's pid in its process structure */
721
722 #define NO_ECHO "set term/noecho\r"
723 sys$setast (0);
724 /*
725 Send a command to the process to not echo input
726
727 The CMU PTY driver does not support SETMODEs.
728 */
729 write_to_vms_process (vs, NO_ECHO, strlen (NO_ECHO));
730
731 XPROCESS (process)->pid = make_int (pid);
732 sys$setast (1);
733 }
734
735 child_sig (VMS_PROC_STUFF *vs)
736 {
737 int pid;
738 Lisp_Object tail, proc;
739 struct Lisp_Process *p;
740 int old_errno = errno;
741
742 pid = vs->pid;
743 sys$setef (vs->eventFlag);
744
745 for (tail = Vprocess_alist; XSYMBOL (tail) != XSYMBOL (Qnil); tail = XCDR (tail))
746 {
747 proc = XCDR (XCAR (tail));
748 p = XPROCESS (proc);
749 if (EQ (p->childp, Qt) && XINT (p->pid) == pid)
750 break;
751 }
752
753 if (XSYMBOL (tail) == XSYMBOL (Qnil))
754 return;
755
756 child_changed++;
757 p->flags = make_int (EXITED | CHANGED);
758 /* Truncate the exit status to 24 bits so that it fits in a FASTINT */
759 p->reason = make_int ((vs->exitStatus) & 0xffffff);
760 }
761
762 void
763 syms_of_vmsproc (void)
764 {
765 defsubr (&Scall_process_internal);
766 }
767
768 void
769 init_vmsproc (void)
770 {
771 char *malloc ();
772 int i;
773 VMS_PROC_STUFF *vs;
774
775 for (vs=procList, i=0; i<MAX_EVENT_FLAGS+1; i++, vs++)
776 {
777 vs->busy = 0;
778 vs->eventFlag = i;
779 sys$clref (i);
780 vs->inputChan = 0;
781 vs->pid = 0;
782 }
783 procList[0].busy = 1; /* Zero is reserved */
784 }