/* Interfaces to system-dependent kernel and library entries.
Copyright (C) 1985, 1986, 1987, 1988, 1993, 1994, 1995, 1999, 2000, 2001,
- 2002, 2003, 2004, 2005, 2006, 2007, 2008
+ 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009
Free Software Foundation, Inc.
This file is part of GNU Emacs.
#include <config.h>
#endif
+#include <ctype.h>
#include <signal.h>
#include <stdio.h>
#include <setjmp.h>
+#ifdef HAVE_PWD_H
+#include <pwd.h>
+#include <grp.h>
+#endif /* HAVE_PWD_H */
+#ifdef HAVE_LIMITS_H
+#include <limits.h>
+#endif /* HAVE_LIMITS_H */
#ifdef HAVE_UNISTD_H
#include <unistd.h>
#endif
+#ifdef HAVE_ALLOCA_H
+#include <alloca.h>
+#endif /* HAVE_ALLOCA_H */
+
#include "lisp.h"
/* Including stdlib.h isn't necessarily enough to get srandom
declared, e.g. without __USE_XOPEN_EXTENDED with glibc 2. */
#endif
#endif
-#ifdef VMS
-#include <rms.h>
-#include <ttdef.h>
-#include <tt2def.h>
-#include <iodef.h>
-#include <ssdef.h>
-#include <descrip.h>
-#include <fibdef.h>
-#include <atrdef.h>
-#include <ctype.h>
-#include <string.h>
-#ifdef __GNUC__
-#include <sys/file.h>
-#else
-#include <file.h>
-#endif
-#undef F_SETFL
-#ifndef RAB$C_BID
-#include <rab.h>
-#endif
-#define MAXIOSIZE (32 * PAGESIZE) /* Don't I/O more than 32 blocks at a time */
-#endif /* VMS */
-
-#ifndef VMS
#include <sys/file.h>
-#endif /* not VMS */
#ifdef HAVE_FCNTL_H
#include <fcntl.h>
extern char *getwd (char *);
#endif
-#ifdef NONSYSTEM_DIR_LIBRARY
-#include "ndir.h"
-#endif /* NONSYSTEM_DIR_LIBRARY */
-
#include "syssignal.h"
#include "systime.h"
#ifdef HAVE_UTIME_H
if (noninteractive)
return;
-#ifdef VMS
- end_kbd_input ();
- SYS$QIOW (0, fileno (CURTTY()->input), IO$_READVBLK|IO$M_PURGE, input_iosb, 0, 0,
- &buf.main, 0, 0, terminator_mask, 0, 0);
- queue_kbd_input ();
-#else /* not VMS */
#ifdef MSDOS /* Demacs 1.1.1 91/10/16 HIRANO Satoshi */
while (dos_keyread () != -1)
;
}
}
#endif /* not MSDOS */
-#endif /* not VMS */
#endif /* not WINDOWSNT */
}
#ifdef DOS_NT
emacs_ospeed = 15;
#else /* not DOS_NT */
-#ifdef VMS
- struct sensemode sg;
-
- SYS$QIOW (0, fd, IO$_SENSEMODE, &sg, 0, 0,
- &sg.class, 12, 0, 0, 0, 0 );
- emacs_ospeed = sg.xmit_baud;
-#else /* not VMS */
#ifdef HAVE_TERMIOS
struct termios sg;
sg.c_cflag = B9600;
tcgetattr (fd, &sg);
emacs_ospeed = cfgetospeed (&sg);
-#else /* neither VMS nor TERMIOS */
+#else /* not TERMIOS */
#ifdef HAVE_TERMIO
struct termio sg;
ioctl (fd, TCGETA, &sg);
#endif
emacs_ospeed = sg.c_cflag & CBAUD;
-#else /* neither VMS nor TERMIOS nor TERMIO */
+#else /* neither TERMIOS nor TERMIO */
struct sgttyb sg;
sg.sg_ospeed = B9600;
emacs_ospeed = sg.sg_ospeed;
#endif /* not HAVE_TERMIO */
#endif /* not HAVE_TERMIOS */
-#endif /* not VMS */
#endif /* not DOS_NT */
}
while (1)
{
#ifdef subprocesses
-#ifdef VMS
- int status;
-
- status = SYS$FORCEX (&pid, 0, 0);
- break;
-#else /* not VMS */
#if defined (BSD_SYSTEM) || defined (HPUX)
/* Note that kill returns -1 even if the process is just a zombie now.
But inevitably a SIGCHLD interrupt should be generated
#endif /* not HAVE_SYSV_SIGPAUSE */
#endif /* not POSIX_SIGNALS */
#endif /* not BSD_SYSTEM, and not HPUX version >= 6 */
-#endif /* not VMS */
#else /* not subprocesses */
#if __DJGPP__ > 1
break;
#endif
}
\f
-#ifndef VMS
/* Set up the terminal at the other end of a pseudo-terminal that
we will be controlling an inferior through.
It should not echo or do line-editing, since that is done
/* rms: Formerly it set s.main.c_cc[VINTR] to 0377 here
unconditionally. Then a SIGNALS_VIA_CHARACTERS conditional
would force it to 0377. That looks like duplicated code. */
-#ifndef SIGNALS_VIA_CHARACTERS
- /* QUIT and INTR work better as signals, so disable character forms */
- s.main.c_cc[VQUIT] = CDISABLE;
- s.main.c_cc[VINTR] = CDISABLE;
- s.main.c_lflag &= ~ISIG;
-#endif /* no TIOCGPGRP or no TIOCGLTC or no TIOCGETC */
s.main.c_cc[VEOL] = CDISABLE;
s.main.c_cflag = (s.main.c_cflag & ~CBAUD) | B9600; /* baud rate sanity */
#endif /* AIX */
#endif /* not DOS_NT */
}
-#endif /* not VMS */
#endif /* subprocesses */
\f
void
sys_suspend ()
{
-#ifdef VMS
- /* "Foster" parentage allows emacs to return to a subprocess that attached
- to the current emacs as a cheaper than starting a whole new process. This
- is set up by KEPTEDITOR.COM. */
- unsigned long parent_id, foster_parent_id;
- char *fpid_string;
-
- fpid_string = getenv ("EMACS_PARENT_PID");
- if (fpid_string != NULL)
- {
- sscanf (fpid_string, "%x", &foster_parent_id);
- if (foster_parent_id != 0)
- parent_id = foster_parent_id;
- else
- parent_id = getppid ();
- }
- else
- parent_id = getppid ();
-
- xfree (fpid_string); /* On VMS, this was malloc'd */
-
- if (parent_id && parent_id != 0xffffffff)
- {
- SIGTYPE (*oldsig)() = (int) signal (SIGINT, SIG_IGN);
- int status = LIB$ATTACH (&parent_id) & 1;
- signal (SIGINT, oldsig);
- return status;
- }
- else
- {
- struct {
- int l;
- char *a;
- } d_prompt;
- d_prompt.l = sizeof ("Emacs: "); /* Our special prompt */
- d_prompt.a = "Emacs: "; /* Just a reminder */
- LIB$SPAWN (0, 0, 0, 0, 0, 0, 0, 0, 0, 0, &d_prompt, 0);
- return 1;
- }
- return -1;
-#else
#if defined (SIGTSTP) && !defined (MSDOS)
{
}
#else /* No SIGTSTP */
-#ifdef USG_JOBCTRL /* If you don't know what this is don't mess with it */
- ptrace (0, 0, 0, 0); /* set for ptrace - caught by csh */
- kill (getpid (), SIGQUIT);
-
-#else /* No SIGTSTP or USG_JOBCTRL */
-
/* On a system where suspending is not implemented,
instead fork a subshell and let it talk directly to the terminal
while we wait. */
sys_subshell ();
-#endif /* no USG_JOBCTRL */
#endif /* no SIGTSTP */
-#endif /* not VMS */
}
/* Fork a subshell. */
void
sys_subshell ()
{
-#ifndef VMS
#ifdef DOS_NT /* Demacs 1.1.2 91/10/20 Manabu Higashida */
int st;
char oldwd[MAXPATHLEN+1]; /* Fixed length is safe on MSDOS. */
#endif
restore_signal_handlers (saved_handlers);
synch_process_alive = 0;
-#endif /* !VMS */
}
static void
if (ioctl (fd, TCGETA, &settings->main) < 0)
return -1;
-#else
-#ifdef VMS
- /* Vehemently Monstrous System? :-) */
- if (! (SYS$QIOW (0, fd, IO$_SENSEMODE, settings, 0, 0,
- &settings->main.class, 12, 0, 0, 0, 0)
- & 1))
- return -1;
-
#else
#ifndef DOS_NT
/* I give up - I hope you have the BSD ioctls. */
return -1;
#endif /* not DOS_NT */
#endif
-#endif
#endif
/* Suivant - Do we have to get struct ltchars data? */
if (ioctl (fd, flushp ? TCSETAF : TCSETAW, &settings->main) < 0)
return -1;
-#else
-#ifdef VMS
- /* Vehemently Monstrous System? :-) */
- if (! (SYS$QIOW (0, fd, IO$_SETMODE, &input_iosb, 0, 0,
- &settings->main.class, 12, 0, 0, 0, 0)
- & 1))
- return -1;
-
#else
#ifndef DOS_NT
/* I give up - I hope you have the BSD ioctls. */
return -1;
#endif /* not DOS_NT */
-#endif
#endif
#endif
if (!tty_out->output)
return; /* The tty is suspended. */
-#ifdef VMS
- if (!input_ef)
- input_ef = get_kbd_event_flag ();
- /* LIB$GET_EF (&input_ef); */
- SYS$CLREF (input_ef);
- waiting_for_ast = 0;
- if (!timer_ef)
- timer_ef = get_timer_event_flag ();
- /* LIB$GET_EF (&timer_ef); */
- SYS$CLREF (timer_ef);
- if (input_ef / 32 != timer_ef / 32)
- croak ("Input and timer event flags in different clusters.");
- timer_eflist = ((unsigned) 1 << (input_ef % 32)) |
- ((unsigned) 1 << (timer_ef % 32));
-#ifndef VMS4_4
- sys_access_reinit ();
-#endif
-#endif /* VMS */
-
#ifdef BSD_PGRPS
#if 0
/* read_socket_hook is not global anymore. I think doing this
tty.main.c_iflag &= ~BRKINT;
#endif
#else /* if not HAVE_TERMIO */
-#ifdef VMS
- tty.main.tt_char |= TT$M_NOECHO;
- if (meta_key)
- tty.main.tt_char |= TT$M_EIGHTBIT;
- if (tty_out->flow_control)
- tty.main.tt_char |= TT$M_TTSYNC;
- else
- tty.main.tt_char &= ~TT$M_TTSYNC;
- tty.main.tt2_char |= TT2$M_PASTHRU | TT2$M_XON;
-#else /* not VMS (BSD, that is) */
#ifndef DOS_NT
XSETINT (Vtty_erase_char, tty.main.sg_erase);
tty.main.sg_flags &= ~(ECHO | CRMOD | XTABS);
tty.main.sg_flags |= ANYP;
tty.main.sg_flags |= interrupt_input ? RAW : CBREAK;
#endif /* not DOS_NT */
-#endif /* not VMS (BSD, that is) */
#endif /* not HAVE_TERMIO */
/* If going to use CBREAK mode, we must request C-g to interrupt
#ifdef MSDOS /* Demacs 1.1.2 91/10/20 Manabu Higashida, MW Aug 1993 */
if (!tty_out->term_initted)
internal_terminal_init ();
- dos_ttraw ();
+ dos_ttraw (tty_out);
#endif
EMACS_SET_TTY (fileno (tty_out->input), &tty, 0);
#endif
#endif
-#ifdef VMS
-/* Appears to do nothing when in PASTHRU mode.
- SYS$QIOW (0, fileno (tty_out->input), IO$_SETMODE|IO$M_OUTBAND, 0, 0, 0,
- interrupt_signal, oob_chars, 0, 0, 0, 0);
-*/
- queue_kbd_input (0);
-#endif /* VMS */
-
#ifdef F_SETFL
#ifdef F_GETOWN /* F_SETFL does not imply existence of F_GETOWN */
if (interrupt_input)
#endif /* F_GETOWN */
#endif /* F_SETFL */
-#ifdef VMS /* VMS sometimes has this symbol but lacks setvbuf. */
-#undef _IOFBF
-#endif
#ifdef _IOFBF
/* This symbol is defined on recent USG systems.
Someone says without this call USG won't really buffer the file
frame_garbaged = 1;
FOR_EACH_FRAME (tail, frame)
{
- if (FRAME_TERMCAP_P (XFRAME (frame))
+ if ((FRAME_TERMCAP_P (XFRAME (frame))
+ || FRAME_MSDOS_P (XFRAME (frame)))
&& FRAME_TTY (XFRAME (frame)) == tty_out)
FRAME_GARBAGED_P (XFRAME (frame)) = 1;
}
*heightp = size.ts_lines;
}
-#else
-#ifdef VMS
-
- /* Use a fresh channel since the current one may have stale info
- (for example, from prior to a suspend); and to avoid a dependency
- in the init sequence. */
- int chan;
- struct sensemode tty;
-
- SYS$ASSIGN (&input_dsc, &chan, 0, 0);
- SYS$QIOW (0, chan, IO$_SENSEMODE, &tty, 0, 0,
- &tty.class, 12, 0, 0, 0, 0);
- SYS$DASSGN (chan);
- *widthp = tty.scr_wid;
- *heightp = tty.scr_len;
-
#else
#ifdef MSDOS
*widthp = ScreenCols ();
*widthp = 0;
*heightp = 0;
#endif
-#endif /* not VMS */
#endif /* not SunOS-style */
#endif /* not BSD-style */
}
}
#endif /* HAVE_PTYS */
\f
-#ifdef VMS
-
-/* Assigning an input channel is done at the start of Emacs execution.
- This is called each time Emacs is resumed, also, but does nothing
- because input_chain is no longer zero. */
-
-void
-init_vms_input ()
-{
- int status;
-
- if (fileno (CURTTY ()->input)) == 0)
- {
- status = SYS$ASSIGN (&input_dsc, &fileno (CURTTY ()->input)), 0, 0);
- if (! (status & 1))
- LIB$STOP (status);
- }
-}
-
-/* Deassigning the input channel is done before exiting. */
-
-void
-stop_vms_input ()
-{
- return SYS$DASSGN (fileno (CURTTY ()->input)));
-}
-
-short input_buffer;
-
-/* Request reading one character into the keyboard buffer.
- This is done as soon as the buffer becomes empty. */
-
-void
-queue_kbd_input ()
-{
- int status;
- extern kbd_input_ast ();
-
- waiting_for_ast = 0;
- stop_input = 0;
- status = SYS$QIO (0, fileno (CURTTY()->input), IO$_READVBLK,
- &input_iosb, kbd_input_ast, 1,
- &input_buffer, 1, 0, terminator_mask, 0, 0);
-}
-
-int input_count;
-
-/* Ast routine that is called when keyboard input comes in
- in accord with the SYS$QIO above. */
-
-void
-kbd_input_ast ()
-{
- register int c = -1;
- int old_errno = errno;
- extern EMACS_TIME *input_available_clear_time;
-
- if (waiting_for_ast)
- SYS$SETEF (input_ef);
- waiting_for_ast = 0;
- input_count++;
-#ifdef ASTDEBUG
- if (input_count == 25)
- exit (1);
- printf ("Ast # %d,", input_count);
- printf (" iosb = %x, %x, %x, %x",
- input_iosb.offset, input_iosb.status, input_iosb.termlen,
- input_iosb.term);
-#endif
- if (input_iosb.offset)
- {
- c = input_buffer;
-#ifdef ASTDEBUG
- printf (", char = 0%o", c);
-#endif
- }
-#ifdef ASTDEBUG
- printf ("\n");
- fflush (stdout);
- sleep (1);
-#endif
- if (! stop_input)
- queue_kbd_input ();
- if (c >= 0)
- {
- struct input_event e;
- EVENT_INIT (e);
-
- e.kind = ASCII_KEYSTROKE_EVENT;
- XSETINT (e.code, c);
- e.frame_or_window = selected_frame;
- kbd_buffer_store_event (&e);
- }
- if (input_available_clear_time)
- EMACS_SET_SECS_USECS (*input_available_clear_time, 0, 0);
- errno = old_errno;
-}
-
-/* Wait until there is something in kbd_buffer. */
-
-void
-wait_for_kbd_input ()
-{
- extern int have_process_input, process_exited;
-
- /* If already something, avoid doing system calls. */
- if (detect_input_pending ())
- {
- return;
- }
- /* Clear a flag, and tell ast routine above to set it. */
- SYS$CLREF (input_ef);
- waiting_for_ast = 1;
- /* Check for timing error: ast happened while we were doing that. */
- if (!detect_input_pending ())
- {
- /* No timing error: wait for flag to be set. */
- set_waiting_for_input (0);
- SYS$WFLOR (input_ef, input_eflist);
- clear_waiting_for_input ();
- if (!detect_input_pending ())
- /* Check for subprocess input availability */
- {
- int dsp = have_process_input || process_exited;
-
- SYS$CLREF (process_ef);
- if (have_process_input)
- process_command_input ();
- if (process_exited)
- process_exit ();
- if (dsp)
- {
- update_mode_lines++;
- prepare_menu_bars ();
- redisplay_preserve_echo_area (18);
- }
- }
- }
- waiting_for_ast = 0;
-}
-
-/* Get rid of any pending QIO, when we are about to suspend
- or when we want to throw away pending input.
- We wait for a positive sign that the AST routine has run
- and therefore there is no I/O request queued when we return.
- SYS$SETAST is used to avoid a timing error. */
-
-void
-end_kbd_input ()
-{
-#ifdef ASTDEBUG
- printf ("At end_kbd_input.\n");
- fflush (stdout);
- sleep (1);
-#endif
- if (LIB$AST_IN_PROG ()) /* Don't wait if suspending from kbd_buffer_store_event! */
- {
- SYS$CANCEL (fileno (CURTTY()->input));
- return;
- }
-
- SYS$SETAST (0);
- /* Clear a flag, and tell ast routine above to set it. */
- SYS$CLREF (input_ef);
- waiting_for_ast = 1;
- stop_input = 1;
- SYS$CANCEL (fileno (CURTTY()->input));
- SYS$SETAST (1);
- SYS$WAITFR (input_ef);
- waiting_for_ast = 0;
-}
-
-/* Wait for either input available or time interval expiry. */
-
-void
-input_wait_timeout (timeval)
- int timeval; /* Time to wait, in seconds */
-{
- int time [2];
- static int zero = 0;
- static int large = -10000000;
-
- LIB$EMUL (&timeval, &large, &zero, time); /* Convert to VMS format */
-
- /* If already something, avoid doing system calls. */
- if (detect_input_pending ())
- {
- return;
- }
- /* Clear a flag, and tell ast routine above to set it. */
- SYS$CLREF (input_ef);
- waiting_for_ast = 1;
- /* Check for timing error: ast happened while we were doing that. */
- if (!detect_input_pending ())
- {
- /* No timing error: wait for flag to be set. */
- SYS$CANTIM (1, 0);
- if (SYS$SETIMR (timer_ef, time, 0, 1) & 1) /* Set timer */
- SYS$WFLOR (timer_ef, timer_eflist); /* Wait for timer expiry or input */
- }
- waiting_for_ast = 0;
-}
-
-/* The standard `sleep' routine works some other way
- and it stops working if you have ever quit out of it.
- This one continues to work. */
-
-sys_sleep (timeval)
- int timeval;
-{
- int time [2];
- static int zero = 0;
- static int large = -10000000;
-
- LIB$EMUL (&timeval, &large, &zero, time); /* Convert to VMS format */
-
- SYS$CANTIM (1, 0);
- if (SYS$SETIMR (timer_ef, time, 0, 1) & 1) /* Set timer */
- SYS$WAITFR (timer_ef); /* Wait for timer expiry only */
-}
-
-void
-init_sigio (fd)
- int fd;
-{
- request_sigio ();
-}
-
-reset_sigio (fd)
- int fd;
-{
- unrequest_sigio ();
-}
-
-void
-request_sigio ()
-{
- if (noninteractive)
- return;
- croak ("request sigio");
-}
-
-void
-unrequest_sigio ()
-{
- if (noninteractive)
- return;
- croak ("unrequest sigio");
-}
-
-#endif /* VMS */
-\f
-/* Note that VMS compiler won't accept defined (CANNOT_DUMP). */
-#ifndef CANNOT_DUMP
-#define NEED_STARTS
-#endif
-
-#ifndef SYSTEM_MALLOC
-#ifndef NEED_STARTS
-#define NEED_STARTS
-#endif
-#endif
-
-#ifdef NEED_STARTS
+#if !defined(CANNOT_DUMP) || !defined(SYSTEM_MALLOC)
/* Some systems that cannot dump also cannot implement these. */
/*
extern Lisp_Object Vsystem_name;
-#ifndef VMS
#ifdef HAVE_SOCKETS
#include <sys/socket.h>
#include <netdb.h>
#endif /* HAVE_SOCKETS */
-#endif /* not VMS */
#ifdef TRY_AGAIN
#ifndef HAVE_H_ERRNO
void
init_system_name ()
{
-#ifdef VMS
- char *sp, *end;
- if ((sp = egetenv ("SYS$NODE")) == 0)
- Vsystem_name = build_string ("vax-vms");
- else if ((end = index (sp, ':')) == 0)
- Vsystem_name = build_string (sp);
- else
- Vsystem_name = make_string (sp, end - sp);
-#else
#ifndef HAVE_GETHOSTNAME
struct utsname uts;
uname (&uts);
#endif /* HAVE_SOCKETS */
Vsystem_name = build_string (hostname);
#endif /* HAVE_GETHOSTNAME */
-#endif /* VMS */
{
unsigned char *p;
for (p = SDATA (Vsystem_name); *p; p++)
}
\f
#ifndef MSDOS
-#ifndef VMS
#if !defined (HAVE_SELECT)
#include "sysselect.h"
#endif
#endif /* not HAVE_SELECT */
-#endif /* not VMS */
#endif /* not MSDOS */
\f
/* POSIX signals support - DJB */
struct sigaction new_action, old_action;
sigemptyset (&new_action.sa_mask);
new_action.sa_handler = action;
-#if defined (SA_RESTART) && ! defined (BROKEN_SA_RESTART) && !defined(SYNC_INPUT)
+ new_action.sa_flags = 0;
+#if defined (SA_RESTART)
/* Emacs mostly works better with restartable system services. If this
flag exists, we probably want to turn it on here.
However, on some systems this resets the timeout of `select'
When SYNC_INPUT is set, we don't want SA_RESTART because we need to poll
for pending input so we need long-running syscalls to be interrupted
after a signal that sets the interrupt_input_pending flag. */
- new_action.sa_flags = SA_RESTART;
-#else
- new_action.sa_flags = 0;
+ /* Non-interactive keyboard input goes through stdio, where we always
+ want restartable system calls. */
+# if defined (BROKEN_SA_RESTART) || defined(SYNC_INPUT)
+ if (noninteractive)
+# endif
+ new_action.sa_flags = SA_RESTART;
#endif
sigaction (signal_number, &new_action, &old_action);
return (old_action.sa_handler);
#endif /* need at least 2 */
return val & ((1L << VALBITS) - 1);
}
-\f
-#ifdef VMS
-
-#ifdef getenv
-/* If any place else asks for the TERM variable,
- allow it to be overridden with the EMACS_TERM variable
- before attempting to translate the logical name TERM. As a last
- resort, ask for VAX C's special idea of the TERM variable. */
-#undef getenv
-char *
-sys_getenv (name)
- char *name;
-{
- register char *val;
- static char buf[256];
- static struct dsc$descriptor_s equiv
- = {sizeof (buf), DSC$K_DTYPE_T, DSC$K_CLASS_S, buf};
- static struct dsc$descriptor_s d_name
- = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
- short eqlen;
-
- if (!strcmp (name, "TERM"))
- {
- val = (char *) getenv ("EMACS_TERM");
- if (val)
- return val;
- }
-
- d_name.dsc$w_length = strlen (name);
- d_name.dsc$a_pointer = name;
- if (LIB$SYS_TRNLOG (&d_name, &eqlen, &equiv) == 1)
- {
- char *str = (char *) xmalloc (eqlen + 1);
- bcopy (buf, str, eqlen);
- str[eqlen] = '\0';
- /* This is a storage leak, but a pain to fix. With luck,
- no one will ever notice. */
- return str;
- }
- return (char *) getenv (name);
-}
-#endif /* getenv */
-
-#ifdef abort
-/* Since VMS doesn't believe in core dumps, the only way to debug this beast is
- to force a call on the debugger from within the image. */
-#undef abort
-sys_abort ()
-{
- reset_all_sys_modes ();
- LIB$SIGNAL (SS$_DEBUG);
-}
-#endif /* abort */
-#endif /* VMS */
-\f
-#ifdef VMS
-#ifdef LINK_CRTL_SHARE
-#ifdef SHARABLE_LIB_BUG
-/* Variables declared noshare and initialized in sharable libraries
- cannot be shared. The VMS linker incorrectly forces you to use a private
- version which is uninitialized... If not for this "feature", we
- could use the C library definition of sys_nerr and sys_errlist. */
-int sys_nerr = 35;
-char *sys_errlist[] =
- {
- "error 0",
- "not owner",
- "no such file or directory",
- "no such process",
- "interrupted system call",
- "i/o error",
- "no such device or address",
- "argument list too long",
- "exec format error",
- "bad file number",
- "no child process",
- "no more processes",
- "not enough memory",
- "permission denied",
- "bad address",
- "block device required",
- "mount devices busy",
- "file exists",
- "cross-device link",
- "no such device",
- "not a directory",
- "is a directory",
- "invalid argument",
- "file table overflow",
- "too many open files",
- "not a typewriter",
- "text file busy",
- "file too big",
- "no space left on device",
- "illegal seek",
- "read-only file system",
- "too many links",
- "broken pipe",
- "math argument",
- "result too large",
- "I/O stream empty",
- "vax/vms specific error code nontranslatable error"
- };
-#endif /* SHARABLE_LIB_BUG */
-#endif /* LINK_CRTL_SHARE */
-#endif /* VMS */
#ifndef HAVE_STRERROR
#ifndef WINDOWSNT
#ifdef SYNC_INPUT
/* I originally used `QUIT' but that might causes files to
be truncated if you hit C-g in the middle of it. --Stef */
- if (interrupt_input_pending)
- handle_async_input ();
- if (pending_atimers)
- do_pending_atimers ();
+ process_pending_signals ();
#endif
continue;
}
*/
#ifdef subprocesses
-#ifndef VMS
#ifndef HAVE_GETTIMEOFDAY
#ifdef HAVE_TIMEVAL
#endif
#endif
-#endif
-#endif /* subprocess && !HAVE_GETTIMEOFDAY && HAVE_TIMEVAL && !VMS */
+#endif /* subprocess && !HAVE_GETTIMEOFDAY && HAVE_TIMEVAL */
/*
* This function will go away as soon as all the stubs fixed. (fnf)
#endif /* not HAVE_CLOSEDIR */
#endif /* SYSV_SYSTEM_DIR */
-#ifdef NONSYSTEM_DIR_LIBRARY
-
-DIR *
-opendir (filename)
- char *filename; /* name of directory */
-{
- register DIR *dirp; /* -> malloc'ed storage */
- register int fd; /* file descriptor for read */
- struct stat sbuf; /* result of fstat */
-
- fd = emacs_open (filename, O_RDONLY, 0);
- if (fd < 0)
- return 0;
-
- BLOCK_INPUT;
- if (fstat (fd, &sbuf) < 0
- || (sbuf.st_mode & S_IFMT) != S_IFDIR
- || (dirp = (DIR *) xmalloc (sizeof (DIR))) == 0)
- {
- emacs_close (fd);
- UNBLOCK_INPUT;
- return 0; /* bad luck today */
- }
- UNBLOCK_INPUT;
-
- dirp->dd_fd = fd;
- dirp->dd_loc = dirp->dd_size = 0; /* refill needed */
-
- return dirp;
-}
-
-void
-closedir (dirp)
- register DIR *dirp; /* stream from opendir */
-{
- emacs_close (dirp->dd_fd);
- xfree ((char *) dirp);
-}
-
-
-#ifndef VMS
-#define DIRSIZ 14
-struct olddir
- {
- ino_t od_ino; /* inode */
- char od_name[DIRSIZ]; /* filename */
- };
-#endif /* not VMS */
-
-struct direct dir_static; /* simulated directory contents */
-
-/* ARGUSED */
-struct direct *
-readdir (dirp)
- register DIR *dirp; /* stream from opendir */
-{
-#ifndef VMS
- register struct olddir *dp; /* -> directory data */
-#else /* VMS */
- register struct dir$_name *dp; /* -> directory data */
- register struct dir$_version *dv; /* -> version data */
-#endif /* VMS */
-
- for (; ;)
- {
- if (dirp->dd_loc >= dirp->dd_size)
- dirp->dd_loc = dirp->dd_size = 0;
-
- if (dirp->dd_size == 0 /* refill buffer */
- && (dirp->dd_size = emacs_read (dirp->dd_fd, dirp->dd_buf, DIRBLKSIZ)) <= 0)
- return 0;
-
-#ifndef VMS
- dp = (struct olddir *) &dirp->dd_buf[dirp->dd_loc];
- dirp->dd_loc += sizeof (struct olddir);
-
- if (dp->od_ino != 0) /* not deleted entry */
- {
- dir_static.d_ino = dp->od_ino;
- strncpy (dir_static.d_name, dp->od_name, DIRSIZ);
- dir_static.d_name[DIRSIZ] = '\0';
- dir_static.d_namlen = strlen (dir_static.d_name);
- dir_static.d_reclen = sizeof (struct direct)
- - MAXNAMLEN + 3
- + dir_static.d_namlen - dir_static.d_namlen % 4;
- return &dir_static; /* -> simulated structure */
- }
-#else /* VMS */
- dp = (struct dir$_name *) dirp->dd_buf;
- if (dirp->dd_loc == 0)
- dirp->dd_loc = (dp->dir$b_namecount&1) ? dp->dir$b_namecount + 1
- : dp->dir$b_namecount;
- dv = (struct dir$_version *)&dp->dir$t_name[dirp->dd_loc];
- dir_static.d_ino = dv->dir$w_fid_num;
- dir_static.d_namlen = dp->dir$b_namecount;
- dir_static.d_reclen = sizeof (struct direct)
- - MAXNAMLEN + 3
- + dir_static.d_namlen - dir_static.d_namlen % 4;
- strncpy (dir_static.d_name, dp->dir$t_name, dp->dir$b_namecount);
- dir_static.d_name[dir_static.d_namlen] = '\0';
- dirp->dd_loc = dirp->dd_size; /* only one record at a time */
- return &dir_static;
-#endif /* VMS */
- }
-}
-
-#ifdef VMS
-/* readdirver is just like readdir except it returns all versions of a file
- as separate entries. */
-
-/* ARGUSED */
-struct direct *
-readdirver (dirp)
- register DIR *dirp; /* stream from opendir */
-{
- register struct dir$_name *dp; /* -> directory data */
- register struct dir$_version *dv; /* -> version data */
-
- if (dirp->dd_loc >= dirp->dd_size - sizeof (struct dir$_name))
- dirp->dd_loc = dirp->dd_size = 0;
-
- if (dirp->dd_size == 0 /* refill buffer */
- && (dirp->dd_size = sys_read (dirp->dd_fd, dirp->dd_buf, DIRBLKSIZ)) <= 0)
- return 0;
-
- dp = (struct dir$_name *) dirp->dd_buf;
- if (dirp->dd_loc == 0)
- dirp->dd_loc = (dp->dir$b_namecount & 1) ? dp->dir$b_namecount + 1
- : dp->dir$b_namecount;
- dv = (struct dir$_version *) &dp->dir$t_name[dirp->dd_loc];
- strncpy (dir_static.d_name, dp->dir$t_name, dp->dir$b_namecount);
- sprintf (&dir_static.d_name[dp->dir$b_namecount], ";%d", dv->dir$w_version);
- dir_static.d_namlen = strlen (dir_static.d_name);
- dir_static.d_ino = dv->dir$w_fid_num;
- dir_static.d_reclen = sizeof (struct direct) - MAXNAMLEN + 3
- + dir_static.d_namlen - dir_static.d_namlen % 4;
- dirp->dd_loc = ((char *) (++dv) - dp->dir$t_name);
- return &dir_static;
-}
-
-#endif /* VMS */
-
-#endif /* NONSYSTEM_DIR_LIBRARY */
-
\f
int
set_file_times (filename, atime, mtime)
/*
* Make a directory.
*/
-#ifdef MKDIR_PROTOTYPE
-MKDIR_PROTOTYPE
-#else
int
mkdir (dpath, dmode)
char *dpath;
int dmode;
-#endif
{
int cpid, status, fd;
struct stat statbuf;
}
#endif /* !HAVE_RMDIR */
-
\f
-/* Functions for VMS */
-#ifdef VMS
-#include <acldef.h>
-#include <chpdef.h>
-#include <jpidef.h>
+#ifndef BSTRING
-/* Return as a string the VMS error string pertaining to STATUS.
- Reuses the same static buffer each time it is called. */
+#ifndef bzero
-char *
-vmserrstr (status)
- int status; /* VMS status code */
+void
+bzero (b, length)
+ register char *b;
+ register int length;
{
- int bufadr[2];
- short len;
- static char buf[257];
-
- bufadr[0] = sizeof buf - 1;
- bufadr[1] = (int) buf;
- if (! (SYS$GETMSG (status, &len, bufadr, 0x1, 0) & 1))
- return "untranslatable VMS error status";
- buf[len] = '\0';
- return buf;
+ while (length-- > 0)
+ *b++ = 0;
}
-#ifdef access
-#undef access
-
-/* The following is necessary because 'access' emulation by VMS C (2.0) does
- * not work correctly. (It also doesn't work well in version 2.3.)
- */
-
-#ifdef VMS4_4
-
-#define DESCRIPTOR(name,string) struct dsc$descriptor_s name = \
- { strlen (string), DSC$K_DTYPE_T, DSC$K_CLASS_S, string }
-
-typedef union {
- struct {
- unsigned short s_buflen;
- unsigned short s_code;
- char *s_bufadr;
- unsigned short *s_retlenadr;
- } s;
- int end;
-} item;
-#define buflen s.s_buflen
-#define code s.s_code
-#define bufadr s.s_bufadr
-#define retlenadr s.s_retlenadr
-
-#define R_OK 4 /* test for read permission */
-#define W_OK 2 /* test for write permission */
-#define X_OK 1 /* test for execute (search) permission */
-#define F_OK 0 /* test for presence of file */
-
-int
-sys_access (path, mode)
- char *path;
- int mode;
-{
- static char *user = NULL;
- char dir_fn[512];
+#endif /* no bzero */
+#endif /* BSTRING */
- /* translate possible directory spec into .DIR file name, so brain-dead
- * access can treat the directory like a file. */
- if (directory_file_name (path, dir_fn))
- path = dir_fn;
-
- if (mode == F_OK)
- return access (path, mode);
- if (user == NULL && (user = (char *) getenv ("USER")) == NULL)
- return -1;
- {
- int stat;
- int flags;
- int acces;
- unsigned short int dummy;
- item itemlst[3];
- static int constant = ACL$C_FILE;
- DESCRIPTOR (path_desc, path);
- DESCRIPTOR (user_desc, user);
-
- flags = 0;
- acces = 0;
- if ((mode & X_OK) && ((stat = access (path, mode)) < 0 || mode == X_OK))
- return stat;
- if (mode & R_OK)
- acces |= CHP$M_READ;
- if (mode & W_OK)
- acces |= CHP$M_WRITE;
- itemlst[0].buflen = sizeof (int);
- itemlst[0].code = CHP$_FLAGS;
- itemlst[0].bufadr = (char *) &flags;
- itemlst[0].retlenadr = &dummy;
- itemlst[1].buflen = sizeof (int);
- itemlst[1].code = CHP$_ACCESS;
- itemlst[1].bufadr = (char *) &acces;
- itemlst[1].retlenadr = &dummy;
- itemlst[2].end = CHP$_END;
- stat = SYS$CHECK_ACCESS (&constant, &path_desc, &user_desc, itemlst);
- return stat == SS$_NORMAL ? 0 : -1;
- }
-}
-
-#else /* not VMS4_4 */
-
-#include <prvdef.h>
-#define ACE$M_WRITE 2
-#define ACE$C_KEYID 1
-
-static unsigned short memid, grpid;
-static unsigned int uic;
-
-/* Called from init_sys_modes, so it happens not very often
- but at least each time Emacs is loaded. */
-void
-sys_access_reinit ()
-{
- uic = 0;
-}
-
-int
-sys_access (filename, type)
- char * filename;
- int type;
-{
- struct FAB fab;
- struct XABPRO xab;
- int status, size, i, typecode, acl_controlled;
- unsigned int *aclptr, *aclend, aclbuf[60];
- union prvdef prvmask;
-
- /* Get UIC and GRP values for protection checking. */
- if (uic == 0)
- {
- status = LIB$GETJPI (&JPI$_UIC, 0, 0, &uic, 0, 0);
- if (! (status & 1))
- return -1;
- memid = uic & 0xFFFF;
- grpid = uic >> 16;
- }
-
- if (type != 2) /* not checking write access */
- return access (filename, type);
-
- /* Check write protection. */
-
-#define CHECKPRIV(bit) (prvmask.bit)
-#define WRITABLE(field) (! ((xab.xab$w_pro >> field) & XAB$M_NOWRITE))
-
- /* Find privilege bits */
- status = SYS$SETPRV (0, 0, 0, prvmask);
- if (! (status & 1))
- error ("Unable to find privileges: %s", vmserrstr (status));
- if (CHECKPRIV (PRV$V_BYPASS))
- return 0; /* BYPASS enabled */
- fab = cc$rms_fab;
- fab.fab$b_fac = FAB$M_GET;
- fab.fab$l_fna = filename;
- fab.fab$b_fns = strlen (filename);
- fab.fab$l_xab = &xab;
- xab = cc$rms_xabpro;
- xab.xab$l_aclbuf = aclbuf;
- xab.xab$w_aclsiz = sizeof (aclbuf);
- status = SYS$OPEN (&fab, 0, 0);
- if (! (status & 1))
- return -1;
- SYS$CLOSE (&fab, 0, 0);
- /* Check system access */
- if (CHECKPRIV (PRV$V_SYSPRV) && WRITABLE (XAB$V_SYS))
- return 0;
- /* Check ACL entries, if any */
- acl_controlled = 0;
- if (xab.xab$w_acllen > 0)
- {
- aclptr = aclbuf;
- aclend = &aclbuf[xab.xab$w_acllen / 4];
- while (*aclptr && aclptr < aclend)
- {
- size = (*aclptr & 0xff) / 4;
- typecode = (*aclptr >> 8) & 0xff;
- if (typecode == ACE$C_KEYID)
- for (i = size - 1; i > 1; i--)
- if (aclptr[i] == uic)
- {
- acl_controlled = 1;
- if (aclptr[1] & ACE$M_WRITE)
- return 0; /* Write access through ACL */
- }
- aclptr = &aclptr[size];
- }
- if (acl_controlled) /* ACL specified, prohibits write access */
- return -1;
- }
- /* No ACL entries specified, check normal protection */
- if (WRITABLE (XAB$V_WLD)) /* World writable */
- return 0;
- if (WRITABLE (XAB$V_GRP) &&
- (unsigned short) (xab.xab$l_uic >> 16) == grpid)
- return 0; /* Group writable */
- if (WRITABLE (XAB$V_OWN) &&
- (xab.xab$l_uic & 0xFFFF) == memid)
- return 0; /* Owner writable */
-
- return -1; /* Not writable */
-}
-#endif /* not VMS4_4 */
-#endif /* access */
-
-static char vtbuf[NAM$C_MAXRSS+1];
-
-/* translate a vms file spec to a unix path */
-char *
-sys_translate_vms (vfile)
- char * vfile;
-{
- char * p;
- char * targ;
-
- if (!vfile)
- return 0;
-
- targ = vtbuf;
-
- /* leading device or logical name is a root directory */
- if (p = strchr (vfile, ':'))
- {
- *targ++ = '/';
- while (vfile < p)
- *targ++ = *vfile++;
- vfile++;
- *targ++ = '/';
- }
- p = vfile;
- if (*p == '[' || *p == '<')
- {
- while (*++vfile != *p + 2)
- switch (*vfile)
- {
- case '.':
- if (vfile[-1] == *p)
- *targ++ = '.';
- *targ++ = '/';
- break;
-
- case '-':
- *targ++ = '.';
- *targ++ = '.';
- break;
-
- default:
- *targ++ = *vfile;
- break;
- }
- vfile++;
- *targ++ = '/';
- }
- while (*vfile)
- *targ++ = *vfile++;
-
- return vtbuf;
-}
-
-static char utbuf[NAM$C_MAXRSS+1];
-
-/* translate a unix path to a VMS file spec */
-char *
-sys_translate_unix (ufile)
- char * ufile;
-{
- int slash_seen = 0;
- char *p;
- char * targ;
-
- if (!ufile)
- return 0;
-
- targ = utbuf;
-
- if (*ufile == '/')
- {
- ufile++;
- }
-
- while (*ufile)
- {
- switch (*ufile)
- {
- case '/':
- if (slash_seen)
- if (index (&ufile[1], '/'))
- *targ++ = '.';
- else
- *targ++ = ']';
- else
- {
- *targ++ = ':';
- if (index (&ufile[1], '/'))
- *targ++ = '[';
- slash_seen = 1;
- }
- break;
-
- case '.':
- if (strncmp (ufile, "./", 2) == 0)
- {
- if (!slash_seen)
- {
- *targ++ = '[';
- slash_seen = 1;
- }
- ufile++; /* skip the dot */
- if (index (&ufile[1], '/'))
- *targ++ = '.';
- else
- *targ++ = ']';
- }
- else if (strncmp (ufile, "../", 3) == 0)
- {
- if (!slash_seen)
- {
- *targ++ = '[';
- slash_seen = 1;
- }
- *targ++ = '-';
- ufile += 2; /* skip the dots */
- if (index (&ufile[1], '/'))
- *targ++ = '.';
- else
- *targ++ = ']';
- }
- else
- *targ++ = *ufile;
- break;
-
- default:
- *targ++ = *ufile;
- break;
- }
- ufile++;
- }
- *targ = '\0';
-
- return utbuf;
-}
-
-char *
-getwd (pathname)
- char *pathname;
-{
- char *ptr, *val;
- extern char *getcwd ();
-
-#define MAXPATHLEN 1024
-
- ptr = xmalloc (MAXPATHLEN);
- val = getcwd (ptr, MAXPATHLEN);
- if (val == 0)
- {
- xfree (ptr);
- return val;
- }
- strcpy (pathname, ptr);
- xfree (ptr);
-
- return pathname;
-}
-
-int
-getppid ()
-{
- long item_code = JPI$_OWNER;
- unsigned long parent_id;
- int status;
-
- if (((status = LIB$GETJPI (&item_code, 0, 0, &parent_id)) & 1) == 0)
- {
- errno = EVMSERR;
- vaxc$errno = status;
- return -1;
- }
- return parent_id;
-}
-
-#undef getuid
-unsigned
-sys_getuid ()
-{
- return (getgid () << 16) | getuid ();
-}
-
-#undef read
-int
-sys_read (fildes, buf, nbyte)
- int fildes;
- char *buf;
- unsigned int nbyte;
-{
- return read (fildes, buf, (nbyte < MAXIOSIZE ? nbyte : MAXIOSIZE));
-}
-
-/*
- * VAX/VMS VAX C RTL really loses. It insists that records
- * end with a newline (carriage return) character, and if they
- * don't it adds one (nice of it isn't it!)
- *
- * Thus we do this stupidity below.
- */
-
-#undef write
-int
-sys_write (fildes, buf, nbytes)
- int fildes;
- char *buf;
- unsigned int nbytes;
-{
- register char *p;
- register char *e;
- int sum = 0;
- struct stat st;
-
- fstat (fildes, &st);
- p = buf;
- while (nbytes > 0)
- {
- int len, retval;
-
- /* Handle fixed-length files with carriage control. */
- if (st.st_fab_rfm == FAB$C_FIX
- && ((st.st_fab_rat & (FAB$M_FTN | FAB$M_CR)) != 0))
- {
- len = st.st_fab_mrs;
- retval = write (fildes, p, min (len, nbytes));
- if (retval != len)
- return -1;
- retval++; /* This skips the implied carriage control */
- }
- else
- {
- e = p + min (MAXIOSIZE, nbytes) - 1;
- while (*e != '\n' && e > p) e--;
- if (p == e) /* Ok.. so here we add a newline... sigh. */
- e = p + min (MAXIOSIZE, nbytes) - 1;
- len = e + 1 - p;
- retval = write (fildes, p, len);
- if (retval != len)
- return -1;
- }
- p += retval;
- sum += retval;
- nbytes -= retval;
- }
- return sum;
-}
-
-/* Create file NEW copying its attributes from file OLD. If
- OLD is 0 or does not exist, create based on the value of
- vms_stmlf_recfm. */
-
-/* Protection value the file should ultimately have.
- Set by create_copy_attrs, and use by rename_sansversions. */
-static unsigned short int fab_final_pro;
-
-int
-creat_copy_attrs (old, new)
- char *old, *new;
-{
- struct FAB fab = cc$rms_fab;
- struct XABPRO xabpro;
- char aclbuf[256]; /* Choice of size is arbitrary. See below. */
- extern int vms_stmlf_recfm;
-
- if (old)
- {
- fab.fab$b_fac = FAB$M_GET;
- fab.fab$l_fna = old;
- fab.fab$b_fns = strlen (old);
- fab.fab$l_xab = (char *) &xabpro;
- xabpro = cc$rms_xabpro;
- xabpro.xab$l_aclbuf = aclbuf;
- xabpro.xab$w_aclsiz = sizeof aclbuf;
- /* Call $OPEN to fill in the fab & xabpro fields. */
- if (SYS$OPEN (&fab, 0, 0) & 1)
- {
- SYS$CLOSE (&fab, 0, 0);
- fab.fab$l_alq = 0; /* zero the allocation quantity */
- if (xabpro.xab$w_acllen > 0)
- {
- if (xabpro.xab$w_acllen > sizeof aclbuf)
- /* If the acl buffer was too short, redo open with longer one.
- Wouldn't need to do this if there were some system imposed
- limit on the size of an ACL, but I can't find any such. */
- {
- xabpro.xab$l_aclbuf = (char *) alloca (xabpro.xab$w_acllen);
- xabpro.xab$w_aclsiz = xabpro.xab$w_acllen;
- if (SYS$OPEN (&fab, 0, 0) & 1)
- SYS$CLOSE (&fab, 0, 0);
- else
- old = 0;
- }
- }
- else
- xabpro.xab$l_aclbuf = 0;
- }
- else
- old = 0;
- }
- fab.fab$l_fna = new;
- fab.fab$b_fns = strlen (new);
- if (!old)
- {
- fab.fab$l_xab = 0;
- fab.fab$b_rfm = vms_stmlf_recfm ? FAB$C_STMLF : FAB$C_VAR;
- fab.fab$b_rat = FAB$M_CR;
- }
-
- /* Set the file protections such that we will be able to manipulate
- this file. Once we are done writing and renaming it, we will set
- the protections back. */
- if (old)
- fab_final_pro = xabpro.xab$w_pro;
- else
- SYS$SETDFPROT (0, &fab_final_pro);
- xabpro.xab$w_pro &= 0xff0f; /* set O:rewd for now. This is set back later. */
-
- /* Create the new file with either default attrs or attrs copied
- from old file. */
- if (!(SYS$CREATE (&fab, 0, 0) & 1))
- return -1;
- SYS$CLOSE (&fab, 0, 0);
- /* As this is a "replacement" for creat, return a file descriptor
- opened for writing. */
- return open (new, O_WRONLY);
-}
-
-#ifdef creat
-#undef creat
-#include <varargs.h>
-#ifdef __GNUC__
-#ifndef va_count
-#define va_count(X) ((X) = *(((int *) &(va_alist)) - 1))
-#endif
-#endif
-
-int
-sys_creat (va_alist)
- va_dcl
-{
- va_list list_incrementer;
- char *name;
- int mode;
- int rfd; /* related file descriptor */
- int fd; /* Our new file descriptor */
- int count;
- struct stat st_buf;
- char rfm[12];
- char rat[15];
- char mrs[13];
- char fsz[13];
- extern int vms_stmlf_recfm;
-
- va_count (count);
- va_start (list_incrementer);
- name = va_arg (list_incrementer, char *);
- mode = va_arg (list_incrementer, int);
- if (count > 2)
- rfd = va_arg (list_incrementer, int);
- va_end (list_incrementer);
- if (count > 2)
- {
- /* Use information from the related file descriptor to set record
- format of the newly created file. */
- fstat (rfd, &st_buf);
- switch (st_buf.st_fab_rfm)
- {
- case FAB$C_FIX:
- strcpy (rfm, "rfm = fix");
- sprintf (mrs, "mrs = %d", st_buf.st_fab_mrs);
- strcpy (rat, "rat = ");
- if (st_buf.st_fab_rat & FAB$M_CR)
- strcat (rat, "cr");
- else if (st_buf.st_fab_rat & FAB$M_FTN)
- strcat (rat, "ftn");
- else if (st_buf.st_fab_rat & FAB$M_PRN)
- strcat (rat, "prn");
- if (st_buf.st_fab_rat & FAB$M_BLK)
- if (st_buf.st_fab_rat & (FAB$M_CR|FAB$M_FTN|FAB$M_PRN))
- strcat (rat, ", blk");
- else
- strcat (rat, "blk");
- return creat (name, 0, rfm, rat, mrs);
-
- case FAB$C_VFC:
- strcpy (rfm, "rfm = vfc");
- sprintf (fsz, "fsz = %d", st_buf.st_fab_fsz);
- strcpy (rat, "rat = ");
- if (st_buf.st_fab_rat & FAB$M_CR)
- strcat (rat, "cr");
- else if (st_buf.st_fab_rat & FAB$M_FTN)
- strcat (rat, "ftn");
- else if (st_buf.st_fab_rat & FAB$M_PRN)
- strcat (rat, "prn");
- if (st_buf.st_fab_rat & FAB$M_BLK)
- if (st_buf.st_fab_rat & (FAB$M_CR|FAB$M_FTN|FAB$M_PRN))
- strcat (rat, ", blk");
- else
- strcat (rat, "blk");
- return creat (name, 0, rfm, rat, fsz);
-
- case FAB$C_STM:
- strcpy (rfm, "rfm = stm");
- break;
-
- case FAB$C_STMCR:
- strcpy (rfm, "rfm = stmcr");
- break;
-
- case FAB$C_STMLF:
- strcpy (rfm, "rfm = stmlf");
- break;
-
- case FAB$C_UDF:
- strcpy (rfm, "rfm = udf");
- break;
-
- case FAB$C_VAR:
- strcpy (rfm, "rfm = var");
- break;
- }
- strcpy (rat, "rat = ");
- if (st_buf.st_fab_rat & FAB$M_CR)
- strcat (rat, "cr");
- else if (st_buf.st_fab_rat & FAB$M_FTN)
- strcat (rat, "ftn");
- else if (st_buf.st_fab_rat & FAB$M_PRN)
- strcat (rat, "prn");
- if (st_buf.st_fab_rat & FAB$M_BLK)
- if (st_buf.st_fab_rat & (FAB$M_CR|FAB$M_FTN|FAB$M_PRN))
- strcat (rat, ", blk");
- else
- strcat (rat, "blk");
- }
- else
- {
- strcpy (rfm, vms_stmlf_recfm ? "rfm = stmlf" : "rfm=var");
- strcpy (rat, "rat=cr");
- }
- /* Until the VAX C RTL fixes the many bugs with modes, always use
- mode 0 to get the user's default protection. */
- fd = creat (name, 0, rfm, rat);
- if (fd < 0 && errno == EEXIST)
- {
- if (unlink (name) < 0)
- report_file_error ("delete", build_string (name));
- fd = creat (name, 0, rfm, rat);
- }
- return fd;
-}
-#endif /* creat */
-
-/* fwrite to stdout is S L O W. Speed it up by using fputc...*/
-int
-sys_fwrite (ptr, size, num, fp)
- register char * ptr;
- FILE * fp;
-{
- register int tot = num * size;
-
- while (tot--)
- fputc (*ptr++, fp);
- return num;
-}
-
-/*
- * The VMS C library routine creat actually creates a new version of an
- * existing file rather than truncating the old version. There are times
- * when this is not the desired behavior, for instance, when writing an
- * auto save file (you only want one version), or when you don't have
- * write permission in the directory containing the file (but the file
- * itself is writable). Hence this routine, which is equivalent to
- * "close (creat (fn, 0));" on Unix if fn already exists.
- */
-int
-vms_truncate (fn)
- char *fn;
-{
- struct FAB xfab = cc$rms_fab;
- struct RAB xrab = cc$rms_rab;
- int status;
-
- xfab.fab$l_fop = FAB$M_TEF; /* free allocated but unused blocks on close */
- xfab.fab$b_fac = FAB$M_TRN | FAB$M_GET; /* allow truncate and get access */
- xfab.fab$b_shr = FAB$M_NIL; /* allow no sharing - file must be locked */
- xfab.fab$l_fna = fn;
- xfab.fab$b_fns = strlen (fn);
- xfab.fab$l_dna = ";0"; /* default to latest version of the file */
- xfab.fab$b_dns = 2;
- xrab.rab$l_fab = &xfab;
-
- /* This gibberish opens the file, positions to the first record, and
- deletes all records from there until the end of file. */
- if ((SYS$OPEN (&xfab) & 01) == 01)
- {
- if ((SYS$CONNECT (&xrab) & 01) == 01 &&
- (SYS$FIND (&xrab) & 01) == 01 &&
- (SYS$TRUNCATE (&xrab) & 01) == 01)
- status = 0;
- else
- status = -1;
- }
- else
- status = -1;
- SYS$CLOSE (&xfab);
- return status;
-}
-
-/* Define this symbol to actually read SYSUAF.DAT. This requires either
- SYSPRV or a readable SYSUAF.DAT. */
-
-#ifdef READ_SYSUAF
-/*
- * getuaf.c
- *
- * Routine to read the VMS User Authorization File and return
- * a specific user's record.
- */
-
-static struct UAF retuaf;
-
-struct UAF *
-get_uaf_name (uname)
- char * uname;
-{
- register status;
- struct FAB uaf_fab;
- struct RAB uaf_rab;
-
- uaf_fab = cc$rms_fab;
- uaf_rab = cc$rms_rab;
- /* initialize fab fields */
- uaf_fab.fab$l_fna = "SYS$SYSTEM:SYSUAF.DAT";
- uaf_fab.fab$b_fns = 21;
- uaf_fab.fab$b_fac = FAB$M_GET;
- uaf_fab.fab$b_org = FAB$C_IDX;
- uaf_fab.fab$b_shr = FAB$M_GET|FAB$M_PUT|FAB$M_UPD|FAB$M_DEL;
- /* initialize rab fields */
- uaf_rab.rab$l_fab = &uaf_fab;
- /* open the User Authorization File */
- status = SYS$OPEN (&uaf_fab);
- if (!(status&1))
- {
- errno = EVMSERR;
- vaxc$errno = status;
- return 0;
- }
- status = SYS$CONNECT (&uaf_rab);
- if (!(status&1))
- {
- errno = EVMSERR;
- vaxc$errno = status;
- return 0;
- }
- /* read the requested record - index is in uname */
- uaf_rab.rab$l_kbf = uname;
- uaf_rab.rab$b_ksz = strlen (uname);
- uaf_rab.rab$b_rac = RAB$C_KEY;
- uaf_rab.rab$l_ubf = (char *)&retuaf;
- uaf_rab.rab$w_usz = sizeof retuaf;
- status = SYS$GET (&uaf_rab);
- if (!(status&1))
- {
- errno = EVMSERR;
- vaxc$errno = status;
- return 0;
- }
- /* close the User Authorization File */
- status = SYS$DISCONNECT (&uaf_rab);
- if (!(status&1))
- {
- errno = EVMSERR;
- vaxc$errno = status;
- return 0;
- }
- status = SYS$CLOSE (&uaf_fab);
- if (!(status&1))
- {
- errno = EVMSERR;
- vaxc$errno = status;
- return 0;
- }
- return &retuaf;
-}
-
-struct UAF *
-get_uaf_uic (uic)
- unsigned long uic;
-{
- register status;
- struct FAB uaf_fab;
- struct RAB uaf_rab;
-
- uaf_fab = cc$rms_fab;
- uaf_rab = cc$rms_rab;
- /* initialize fab fields */
- uaf_fab.fab$l_fna = "SYS$SYSTEM:SYSUAF.DAT";
- uaf_fab.fab$b_fns = 21;
- uaf_fab.fab$b_fac = FAB$M_GET;
- uaf_fab.fab$b_org = FAB$C_IDX;
- uaf_fab.fab$b_shr = FAB$M_GET|FAB$M_PUT|FAB$M_UPD|FAB$M_DEL;
- /* initialize rab fields */
- uaf_rab.rab$l_fab = &uaf_fab;
- /* open the User Authorization File */
- status = SYS$OPEN (&uaf_fab);
- if (!(status&1))
- {
- errno = EVMSERR;
- vaxc$errno = status;
- return 0;
- }
- status = SYS$CONNECT (&uaf_rab);
- if (!(status&1))
- {
- errno = EVMSERR;
- vaxc$errno = status;
- return 0;
- }
- /* read the requested record - index is in uic */
- uaf_rab.rab$b_krf = 1; /* 1st alternate key */
- uaf_rab.rab$l_kbf = (char *) &uic;
- uaf_rab.rab$b_ksz = sizeof uic;
- uaf_rab.rab$b_rac = RAB$C_KEY;
- uaf_rab.rab$l_ubf = (char *)&retuaf;
- uaf_rab.rab$w_usz = sizeof retuaf;
- status = SYS$GET (&uaf_rab);
- if (!(status&1))
- {
- errno = EVMSERR;
- vaxc$errno = status;
- return 0;
- }
- /* close the User Authorization File */
- status = SYS$DISCONNECT (&uaf_rab);
- if (!(status&1))
- {
- errno = EVMSERR;
- vaxc$errno = status;
- return 0;
- }
- status = SYS$CLOSE (&uaf_fab);
- if (!(status&1))
- {
- errno = EVMSERR;
- vaxc$errno = status;
- return 0;
- }
- return &retuaf;
-}
-
-static struct passwd retpw;
-
-struct passwd *
-cnv_uaf_pw (up)
- struct UAF * up;
-{
- char * ptr;
-
- /* copy these out first because if the username is 32 chars, the next
- section will overwrite the first byte of the UIC */
- retpw.pw_uid = up->uaf$w_mem;
- retpw.pw_gid = up->uaf$w_grp;
-
- /* I suppose this is not the best style, to possibly overwrite one
- byte beyond the end of the field, but what the heck... */
- ptr = &up->uaf$t_username[UAF$S_USERNAME];
- while (ptr[-1] == ' ')
- ptr--;
- *ptr = '\0';
- strcpy (retpw.pw_name, up->uaf$t_username);
-
- /* the rest of these are counted ascii strings */
- strncpy (retpw.pw_gecos, &up->uaf$t_owner[1], up->uaf$t_owner[0]);
- retpw.pw_gecos[up->uaf$t_owner[0]] = '\0';
- strncpy (retpw.pw_dir, &up->uaf$t_defdev[1], up->uaf$t_defdev[0]);
- retpw.pw_dir[up->uaf$t_defdev[0]] = '\0';
- strncat (retpw.pw_dir, &up->uaf$t_defdir[1], up->uaf$t_defdir[0]);
- retpw.pw_dir[up->uaf$t_defdev[0] + up->uaf$t_defdir[0]] = '\0';
- strncpy (retpw.pw_shell, &up->uaf$t_defcli[1], up->uaf$t_defcli[0]);
- retpw.pw_shell[up->uaf$t_defcli[0]] = '\0';
-
- return &retpw;
-}
-#else /* not READ_SYSUAF */
-static struct passwd retpw;
-#endif /* not READ_SYSUAF */
-
-struct passwd *
-getpwnam (name)
- char * name;
-{
-#ifdef READ_SYSUAF
- struct UAF *up;
-#else
- char * user;
- char * dir;
- unsigned char * full;
-#endif /* READ_SYSUAF */
- char *ptr = name;
-
- while (*ptr)
- {
- if ('a' <= *ptr && *ptr <= 'z')
- *ptr -= 040;
- ptr++;
- }
-#ifdef READ_SYSUAF
- if (!(up = get_uaf_name (name)))
- return 0;
- return cnv_uaf_pw (up);
-#else
- if (strcmp (name, getenv ("USER")) == 0)
- {
- retpw.pw_uid = getuid ();
- retpw.pw_gid = getgid ();
- strcpy (retpw.pw_name, name);
- if (full = egetenv ("FULLNAME"))
- strcpy (retpw.pw_gecos, full);
- else
- *retpw.pw_gecos = '\0';
- strcpy (retpw.pw_dir, egetenv ("HOME"));
- *retpw.pw_shell = '\0';
- return &retpw;
- }
- else
- return 0;
-#endif /* not READ_SYSUAF */
-}
-
-struct passwd *
-getpwuid (uid)
- unsigned long uid;
-{
-#ifdef READ_SYSUAF
- struct UAF * up;
-
- if (!(up = get_uaf_uic (uid)))
- return 0;
- return cnv_uaf_pw (up);
-#else
- if (uid == sys_getuid ())
- return getpwnam (egetenv ("USER"));
- else
- return 0;
-#endif /* not READ_SYSUAF */
-}
-
-/* return total address space available to the current process. This is
- the sum of the current p0 size, p1 size and free page table entries
- available. */
-int
-vlimit ()
-{
- int item_code;
- unsigned long free_pages;
- unsigned long frep0va;
- unsigned long frep1va;
- register status;
-
- item_code = JPI$_FREPTECNT;
- if (((status = LIB$GETJPI (&item_code, 0, 0, &free_pages)) & 1) == 0)
- {
- errno = EVMSERR;
- vaxc$errno = status;
- return -1;
- }
- free_pages *= 512;
-
- item_code = JPI$_FREP0VA;
- if (((status = LIB$GETJPI (&item_code, 0, 0, &frep0va)) & 1) == 0)
- {
- errno = EVMSERR;
- vaxc$errno = status;
- return -1;
- }
- item_code = JPI$_FREP1VA;
- if (((status = LIB$GETJPI (&item_code, 0, 0, &frep1va)) & 1) == 0)
- {
- errno = EVMSERR;
- vaxc$errno = status;
- return -1;
- }
-
- return free_pages + frep0va + (0x7fffffff - frep1va);
-}
-
-int
-define_logical_name (varname, string)
- char *varname;
- char *string;
-{
- struct dsc$descriptor_s strdsc =
- {strlen (string), DSC$K_DTYPE_T, DSC$K_CLASS_S, string};
- struct dsc$descriptor_s envdsc =
- {strlen (varname), DSC$K_DTYPE_T, DSC$K_CLASS_S, varname};
- struct dsc$descriptor_s lnmdsc =
- {7, DSC$K_DTYPE_T, DSC$K_CLASS_S, "LNM$JOB"};
-
- return LIB$SET_LOGICAL (&envdsc, &strdsc, &lnmdsc, 0, 0);
-}
-
-int
-delete_logical_name (varname)
- char *varname;
-{
- struct dsc$descriptor_s envdsc =
- {strlen (varname), DSC$K_DTYPE_T, DSC$K_CLASS_S, varname};
- struct dsc$descriptor_s lnmdsc =
- {7, DSC$K_DTYPE_T, DSC$K_CLASS_S, "LNM$JOB"};
-
- return LIB$DELETE_LOGICAL (&envdsc, &lnmdsc);
-}
-
-int
-ulimit ()
-{
- return 0;
-}
-
-int
-setpgrp ()
-{
- return 0;
-}
-
-int
-execvp ()
-{
- error ("execvp system call not implemented");
- return -1;
-}
-
-int
-rename (from, to)
- char *from, *to;
-{
- int status;
- struct FAB from_fab = cc$rms_fab, to_fab = cc$rms_fab;
- struct NAM from_nam = cc$rms_nam, to_nam = cc$rms_nam;
- char from_esn[NAM$C_MAXRSS];
- char to_esn[NAM$C_MAXRSS];
-
- from_fab.fab$l_fna = from;
- from_fab.fab$b_fns = strlen (from);
- from_fab.fab$l_nam = &from_nam;
- from_fab.fab$l_fop = FAB$M_NAM;
-
- from_nam.nam$l_esa = from_esn;
- from_nam.nam$b_ess = sizeof from_esn;
-
- to_fab.fab$l_fna = to;
- to_fab.fab$b_fns = strlen (to);
- to_fab.fab$l_nam = &to_nam;
- to_fab.fab$l_fop = FAB$M_NAM;
-
- to_nam.nam$l_esa = to_esn;
- to_nam.nam$b_ess = sizeof to_esn;
-
- status = SYS$RENAME (&from_fab, 0, 0, &to_fab);
-
- if (status & 1)
- return 0;
- else
- {
- if (status == RMS$_DEV)
- errno = EXDEV;
- else
- errno = EVMSERR;
- vaxc$errno = status;
- return -1;
- }
-}
-
-/* This function renames a file like `rename', but it strips
- the version number from the "to" filename, such that the "to" file is
- will always be a new version. It also sets the file protection once it is
- finished. The protection that we will use is stored in fab_final_pro,
- and was set when we did a creat_copy_attrs to create the file that we
- are renaming.
-
- We could use the chmod function, but Eunichs uses 3 bits per user category
- to describe the protection, and VMS uses 4 (write and delete are separate
- bits). To maintain portability, the VMS implementation of `chmod' wires
- the W and D bits together. */
-
-
-static struct fibdef fib; /* We need this initialized to zero */
-char vms_file_written[NAM$C_MAXRSS];
-
-int
-rename_sans_version (from,to)
- char *from, *to;
-{
- short int chan;
- int stat;
- short int iosb[4];
- int status;
- struct FAB to_fab = cc$rms_fab;
- struct NAM to_nam = cc$rms_nam;
- struct dsc$descriptor fib_d ={sizeof (fib),0,0,(char*) &fib};
- struct dsc$descriptor fib_attr[2]
- = {{sizeof (fab_final_pro),ATR$C_FPRO,0,(char*) &fab_final_pro},{0,0,0,0}};
- char to_esn[NAM$C_MAXRSS];
-
- $DESCRIPTOR (disk,to_esn);
-
- to_fab.fab$l_fna = to;
- to_fab.fab$b_fns = strlen (to);
- to_fab.fab$l_nam = &to_nam;
- to_fab.fab$l_fop = FAB$M_NAM;
-
- to_nam.nam$l_esa = to_esn;
- to_nam.nam$b_ess = sizeof to_esn;
-
- status = SYS$PARSE (&to_fab, 0, 0); /* figure out the full file name */
-
- if (to_nam.nam$l_fnb && NAM$M_EXP_VER)
- *(to_nam.nam$l_ver) = '\0';
-
- stat = rename (from, to_esn);
- if (stat < 0)
- return stat;
-
- strcpy (vms_file_written, to_esn);
-
- to_fab.fab$l_fna = vms_file_written; /* this points to the versionless name */
- to_fab.fab$b_fns = strlen (vms_file_written);
-
- /* Now set the file protection to the correct value */
- SYS$OPEN (&to_fab, 0, 0); /* This fills in the nam$w_fid fields */
-
- /* Copy these fields into the fib */
- fib.fib$r_fid_overlay.fib$w_fid[0] = to_nam.nam$w_fid[0];
- fib.fib$r_fid_overlay.fib$w_fid[1] = to_nam.nam$w_fid[1];
- fib.fib$r_fid_overlay.fib$w_fid[2] = to_nam.nam$w_fid[2];
-
- SYS$CLOSE (&to_fab, 0, 0);
-
- stat = SYS$ASSIGN (&disk, &chan, 0, 0); /* open a channel to the disk */
- if (!stat)
- LIB$SIGNAL (stat);
- stat = SYS$QIOW (0, chan, IO$_MODIFY, iosb, 0, 0, &fib_d,
- 0, 0, 0, &fib_attr, 0);
- if (!stat)
- LIB$SIGNAL (stat);
- stat = SYS$DASSGN (chan);
- if (!stat)
- LIB$SIGNAL (stat);
- strcpy (vms_file_written, to_esn); /* We will write this to the terminal*/
- return 0;
-}
-
-int
-link (file, new)
- char * file, * new;
-{
- register status;
- struct FAB fab;
- struct NAM nam;
- unsigned short fid[3];
- char esa[NAM$C_MAXRSS];
-
- fab = cc$rms_fab;
- fab.fab$l_fop = FAB$M_OFP;
- fab.fab$l_fna = file;
- fab.fab$b_fns = strlen (file);
- fab.fab$l_nam = &nam;
-
- nam = cc$rms_nam;
- nam.nam$l_esa = esa;
- nam.nam$b_ess = NAM$C_MAXRSS;
-
- status = SYS$PARSE (&fab);
- if ((status & 1) == 0)
- {
- errno = EVMSERR;
- vaxc$errno = status;
- return -1;
- }
- status = SYS$SEARCH (&fab);
- if ((status & 1) == 0)
- {
- errno = EVMSERR;
- vaxc$errno = status;
- return -1;
- }
-
- fid[0] = nam.nam$w_fid[0];
- fid[1] = nam.nam$w_fid[1];
- fid[2] = nam.nam$w_fid[2];
-
- fab.fab$l_fna = new;
- fab.fab$b_fns = strlen (new);
-
- status = SYS$PARSE (&fab);
- if ((status & 1) == 0)
- {
- errno = EVMSERR;
- vaxc$errno = status;
- return -1;
- }
-
- nam.nam$w_fid[0] = fid[0];
- nam.nam$w_fid[1] = fid[1];
- nam.nam$w_fid[2] = fid[2];
-
- nam.nam$l_esa = nam.nam$l_name;
- nam.nam$b_esl = nam.nam$b_name + nam.nam$b_type + nam.nam$b_ver;
-
- status = SYS$ENTER (&fab);
- if ((status & 1) == 0)
- {
- errno = EVMSERR;
- vaxc$errno = status;
- return -1;
- }
-
- return 0;
-}
-
-void
-croak (badfunc)
- char *badfunc;
-{
- printf ("%s not yet implemented\r\n", badfunc);
- reset_all_sys_modes ();
- exit (1);
-}
-
-long
-random ()
-{
- /* Arrange to return a range centered on zero. */
- return rand () - (1 << 30);
-}
-
-void
-srandom (seed)
-{
- srand (seed);
-}
-#endif /* VMS */
-\f
-#ifndef BSTRING
-
-#ifndef bzero
-
-void
-bzero (b, length)
- register char *b;
- register int length;
-{
-#ifdef VMS
- short zero = 0;
- long max_str = 65535;
-
- while (length > max_str) {
- (void) LIB$MOVC5 (&zero, &zero, &zero, &max_str, b);
- length -= max_str;
- b += max_str;
- }
- max_str = length;
- (void) LIB$MOVC5 (&zero, &zero, &zero, &max_str, b);
-#else
- while (length-- > 0)
- *b++ = 0;
-#endif /* not VMS */
-}
-
-#endif /* no bzero */
-#endif /* BSTRING */
-
-#if (!defined (BSTRING) && !defined (bcopy)) || defined (NEED_BCOPY)
-#undef bcopy
+#if (!defined (BSTRING) && !defined (bcopy)) || defined (NEED_BCOPY)
+#undef bcopy
/* Saying `void' requires a declaration, above, where bcopy is used
and that declaration causes pain for systems where bcopy is a macro. */
register char *b2;
register int length;
{
-#ifdef VMS
- long max_str = 65535;
-
- while (length > max_str) {
- (void) LIB$MOVC3 (&max_str, b1, b2);
- length -= max_str;
- b1 += max_str;
- b2 += max_str;
- }
- max_str = length;
- (void) LIB$MOVC3 (&length, b1, b2);
-#else
while (length-- > 0)
*b2++ = *b1++;
-#endif /* not VMS */
}
#endif /* (!defined (BSTRING) && !defined (bcopy)) || defined (NEED_BCOPY) */
register char *b2;
register int length;
{
-#ifdef VMS
- struct dsc$descriptor_s src1 = {length, DSC$K_DTYPE_T, DSC$K_CLASS_S, b1};
- struct dsc$descriptor_s src2 = {length, DSC$K_DTYPE_T, DSC$K_CLASS_S, b2};
-
- return STR$COMPARE (&src1, &src2);
-#else
while (length-- > 0)
if (*b1++ != *b2++)
return 1;
return 0;
-#endif /* not VMS */
}
#endif /* no bcmp */
#endif /* not BSTRING */
if (0 <= code && code < NSIG)
{
-#ifdef VMS
- signame = sys_errlist[code];
-#else
/* Cast to suppress warning if the table has const char *. */
signame = (char *) sys_siglist[code];
-#endif
}
return signame;
attr.c_cflag |= CLOCAL;
#endif
#if defined (CREAD)
- attr.c_cflag | CREAD;
+ attr.c_cflag |= CREAD;
#endif
/* Configure speed. */
}
#endif /* TERMIOS */
+\f
+/* System depended enumeration of and access to system processes a-la ps(1). */
+
+#ifdef HAVE_PROCFS
+
+/* Process enumeration and access via /proc. */
+
+Lisp_Object
+list_system_processes ()
+{
+ Lisp_Object procdir, match, proclist, next;
+ struct gcpro gcpro1, gcpro2;
+ register Lisp_Object tail;
+
+ GCPRO2 (procdir, match);
+ /* For every process on the system, there's a directory in the
+ "/proc" pseudo-directory whose name is the numeric ID of that
+ process. */
+ procdir = build_string ("/proc");
+ match = build_string ("[0-9]+");
+ proclist = directory_files_internal (procdir, Qnil, match, Qt, 0, Qnil);
+
+ /* `proclist' gives process IDs as strings. Destructively convert
+ each string into a number. */
+ for (tail = proclist; CONSP (tail); tail = next)
+ {
+ next = XCDR (tail);
+ XSETCAR (tail, Fstring_to_number (XCAR (tail), Qnil));
+ }
+ UNGCPRO;
+
+ /* directory_files_internal returns the files in reverse order; undo
+ that. */
+ proclist = Fnreverse (proclist);
+ return proclist;
+}
+
+/* The WINDOWSNT implementation is in w32.c.
+ The MSDOS implementation is in dosfns.c. */
+#elif !defined (WINDOWSNT) && !defined (MSDOS)
+
+Lisp_Object
+list_system_processes ()
+{
+ return Qnil;
+}
+
+#endif /* !defined (WINDOWSNT) */
+
+#ifdef GNU_LINUX
+static void
+time_from_jiffies (unsigned long long tval, long hz,
+ time_t *sec, unsigned *usec)
+{
+ unsigned long long ullsec;
+
+ *sec = tval / hz;
+ ullsec = *sec;
+ tval -= ullsec * hz;
+ /* Careful: if HZ > 1 million, then integer division by it yields zero. */
+ if (hz <= 1000000)
+ *usec = tval * 1000000 / hz;
+ else
+ *usec = tval / (hz / 1000000);
+}
+
+static Lisp_Object
+ltime_from_jiffies (unsigned long long tval, long hz)
+{
+ time_t sec;
+ unsigned usec;
+
+ time_from_jiffies (tval, hz, &sec, &usec);
+
+ return list3 (make_number ((sec >> 16) & 0xffff),
+ make_number (sec & 0xffff),
+ make_number (usec));
+}
+
+static void
+get_up_time (time_t *sec, unsigned *usec)
+{
+ FILE *fup;
+
+ *sec = *usec = 0;
+
+ BLOCK_INPUT;
+ fup = fopen ("/proc/uptime", "r");
+
+ if (fup)
+ {
+ double uptime, idletime;
+
+ /* The numbers in /proc/uptime use C-locale decimal point, but
+ we already set ourselves to the C locale (see `fixup_locale'
+ in emacs.c). */
+ if (2 <= fscanf (fup, "%lf %lf", &uptime, &idletime))
+ {
+ *sec = uptime;
+ *usec = (uptime - *sec) * 1000000;
+ }
+ fclose (fup);
+ }
+ UNBLOCK_INPUT;
+}
+
+#define MAJOR(d) (((unsigned)(d) >> 8) & 0xfff)
+#define MINOR(d) (((unsigned)(d) & 0xff) | (((unsigned)(d) & 0xfff00000) >> 12))
+
+static Lisp_Object
+procfs_ttyname (int rdev)
+{
+ FILE *fdev = NULL;
+ char name[PATH_MAX];
+
+ BLOCK_INPUT;
+ fdev = fopen ("/proc/tty/drivers", "r");
+
+ if (fdev)
+ {
+ unsigned major;
+ unsigned long minor_beg, minor_end;
+ char minor[25]; /* 2 32-bit numbers + dash */
+ char *endp;
+
+ while (!feof (fdev) && !ferror (fdev))
+ {
+ if (3 <= fscanf (fdev, "%*s %s %u %s %*s\n", name, &major, minor)
+ && major == MAJOR (rdev))
+ {
+ minor_beg = strtoul (minor, &endp, 0);
+ if (*endp == '\0')
+ minor_end = minor_beg;
+ else if (*endp == '-')
+ minor_end = strtoul (endp + 1, &endp, 0);
+ else
+ continue;
+
+ if (MINOR (rdev) >= minor_beg && MINOR (rdev) <= minor_end)
+ {
+ sprintf (name + strlen (name), "%u", MINOR (rdev));
+ break;
+ }
+ }
+ }
+ fclose (fdev);
+ }
+ UNBLOCK_INPUT;
+ return build_string (name);
+}
+
+static unsigned long
+procfs_get_total_memory (void)
+{
+ FILE *fmem = NULL;
+ unsigned long retval = 2 * 1024 * 1024; /* default: 2GB */
+
+ BLOCK_INPUT;
+ fmem = fopen ("/proc/meminfo", "r");
+
+ if (fmem)
+ {
+ unsigned long entry_value;
+ char entry_name[20]; /* the longest I saw is 13+1 */
+
+ while (!feof (fmem) && !ferror (fmem))
+ {
+ if (2 <= fscanf (fmem, "%s %lu kB\n", entry_name, &entry_value)
+ && strcmp (entry_name, "MemTotal:") == 0)
+ {
+ retval = entry_value;
+ break;
+ }
+ }
+ fclose (fmem);
+ }
+ UNBLOCK_INPUT;
+ return retval;
+}
+
+Lisp_Object
+system_process_attributes (Lisp_Object pid)
+{
+ char procfn[PATH_MAX], fn[PATH_MAX];
+ struct stat st;
+ struct passwd *pw;
+ struct group *gr;
+ long clocks_per_sec;
+ char *procfn_end;
+ char procbuf[1025], *p, *q;
+ int fd;
+ ssize_t nread;
+ const char *cmd = NULL;
+ char *cmdline = NULL;
+ size_t cmdsize = 0, cmdline_size;
+ unsigned char c;
+ int proc_id, ppid, uid, gid, pgrp, sess, tty, tpgid, thcount;
+ unsigned long long utime, stime, cutime, cstime, start;
+ long priority, nice, rss;
+ unsigned long minflt, majflt, cminflt, cmajflt, vsize;
+ time_t sec;
+ unsigned usec;
+ EMACS_TIME tnow, tstart, tboot, telapsed,ttotal;
+ double pcpu, pmem;
+ Lisp_Object attrs = Qnil;
+ Lisp_Object cmd_str, decoded_cmd, tem;
+ struct gcpro gcpro1, gcpro2;
+ EMACS_INT uid_eint, gid_eint;
+
+ CHECK_NUMBER_OR_FLOAT (pid);
+ proc_id = FLOATP (pid) ? XFLOAT_DATA (pid) : XINT (pid);
+ sprintf (procfn, "/proc/%u", proc_id);
+ if (stat (procfn, &st) < 0)
+ return attrs;
+
+ GCPRO2 (attrs, decoded_cmd);
+
+ /* euid egid */
+ uid = st.st_uid;
+ /* Use of EMACS_INT stops GCC whining about limited range of data type. */
+ uid_eint = uid;
+ attrs = Fcons (Fcons (Qeuid, make_fixnum_or_float (uid_eint)), attrs);
+ BLOCK_INPUT;
+ pw = getpwuid (uid);
+ UNBLOCK_INPUT;
+ if (pw)
+ attrs = Fcons (Fcons (Quser, build_string (pw->pw_name)), attrs);
+
+ gid = st.st_gid;
+ gid_eint = gid;
+ attrs = Fcons (Fcons (Qegid, make_fixnum_or_float (gid_eint)), attrs);
+ BLOCK_INPUT;
+ gr = getgrgid (gid);
+ UNBLOCK_INPUT;
+ if (gr)
+ attrs = Fcons (Fcons (Qgroup, build_string (gr->gr_name)), attrs);
+
+ strcpy (fn, procfn);
+ procfn_end = fn + strlen (fn);
+ strcpy (procfn_end, "/stat");
+ fd = emacs_open (fn, O_RDONLY, 0);
+ if (fd >= 0 && (nread = emacs_read (fd, procbuf, sizeof(procbuf) - 1)) > 0)
+ {
+ procbuf[nread] = '\0';
+ p = procbuf;
+
+ p = strchr (p, '(');
+ if (p != NULL)
+ {
+ q = strrchr (p + 1, ')');
+ /* comm */
+ if (q != NULL)
+ {
+ cmd = p + 1;
+ cmdsize = q - cmd;
+ }
+ }
+ else
+ q = NULL;
+ if (cmd == NULL)
+ {
+ cmd = "???";
+ cmdsize = 3;
+ }
+ /* Command name is encoded in locale-coding-system; decode it. */
+ cmd_str = make_unibyte_string (cmd, cmdsize);
+ decoded_cmd = code_convert_string_norecord (cmd_str,
+ Vlocale_coding_system, 0);
+ attrs = Fcons (Fcons (Qcomm, decoded_cmd), attrs);
+
+ if (q)
+ {
+ EMACS_INT ppid_eint, pgrp_eint, sess_eint, tpgid_eint, thcount_eint;
+ p = q + 2;
+ /* state ppid pgrp sess tty tpgid . minflt cminflt majflt cmajflt utime stime cutime cstime priority nice thcount . start vsize rss */
+ sscanf (p, "%c %d %d %d %d %d %*u %lu %lu %lu %lu %Lu %Lu %Lu %Lu %ld %ld %d %*d %Lu %lu %ld",
+ &c, &ppid, &pgrp, &sess, &tty, &tpgid,
+ &minflt, &cminflt, &majflt, &cmajflt,
+ &utime, &stime, &cutime, &cstime,
+ &priority, &nice, &thcount, &start, &vsize, &rss);
+ {
+ char state_str[2];
+
+ state_str[0] = c;
+ state_str[1] = '\0';
+ tem = build_string (state_str);
+ attrs = Fcons (Fcons (Qstate, tem), attrs);
+ }
+ /* Stops GCC whining about limited range of data type. */
+ ppid_eint = ppid;
+ pgrp_eint = pgrp;
+ sess_eint = sess;
+ tpgid_eint = tpgid;
+ thcount_eint = thcount;
+ attrs = Fcons (Fcons (Qppid, make_fixnum_or_float (ppid_eint)), attrs);
+ attrs = Fcons (Fcons (Qpgrp, make_fixnum_or_float (pgrp_eint)), attrs);
+ attrs = Fcons (Fcons (Qsess, make_fixnum_or_float (sess_eint)), attrs);
+ attrs = Fcons (Fcons (Qttname, procfs_ttyname (tty)), attrs);
+ attrs = Fcons (Fcons (Qtpgid, make_fixnum_or_float (tpgid_eint)), attrs);
+ attrs = Fcons (Fcons (Qminflt, make_fixnum_or_float (minflt)), attrs);
+ attrs = Fcons (Fcons (Qmajflt, make_fixnum_or_float (majflt)), attrs);
+ attrs = Fcons (Fcons (Qcminflt, make_fixnum_or_float (cminflt)), attrs);
+ attrs = Fcons (Fcons (Qcmajflt, make_fixnum_or_float (cmajflt)), attrs);
+ clocks_per_sec = sysconf (_SC_CLK_TCK);
+ if (clocks_per_sec < 0)
+ clocks_per_sec = 100;
+ attrs = Fcons (Fcons (Qutime,
+ ltime_from_jiffies (utime, clocks_per_sec)),
+ attrs);
+ attrs = Fcons (Fcons (Qstime,
+ ltime_from_jiffies (stime, clocks_per_sec)),
+ attrs);
+ attrs = Fcons (Fcons (Qtime,
+ ltime_from_jiffies (stime+utime, clocks_per_sec)),
+ attrs);
+ attrs = Fcons (Fcons (Qcutime,
+ ltime_from_jiffies (cutime, clocks_per_sec)),
+ attrs);
+ attrs = Fcons (Fcons (Qcstime,
+ ltime_from_jiffies (cstime, clocks_per_sec)),
+ attrs);
+ attrs = Fcons (Fcons (Qctime,
+ ltime_from_jiffies (cstime+cutime, clocks_per_sec)),
+ attrs);
+ attrs = Fcons (Fcons (Qpri, make_number (priority)), attrs);
+ attrs = Fcons (Fcons (Qnice, make_number (nice)), attrs);
+ attrs = Fcons (Fcons (Qthcount, make_fixnum_or_float (thcount_eint)), attrs);
+ EMACS_GET_TIME (tnow);
+ get_up_time (&sec, &usec);
+ EMACS_SET_SECS (telapsed, sec);
+ EMACS_SET_USECS (telapsed, usec);
+ EMACS_SUB_TIME (tboot, tnow, telapsed);
+ time_from_jiffies (start, clocks_per_sec, &sec, &usec);
+ EMACS_SET_SECS (tstart, sec);
+ EMACS_SET_USECS (tstart, usec);
+ EMACS_ADD_TIME (tstart, tboot, tstart);
+ attrs = Fcons (Fcons (Qstart,
+ list3 (make_number
+ ((EMACS_SECS (tstart) >> 16) & 0xffff),
+ make_number
+ (EMACS_SECS (tstart) & 0xffff),
+ make_number
+ (EMACS_USECS (tstart)))),
+ attrs);
+ attrs = Fcons (Fcons (Qvsize, make_fixnum_or_float (vsize/1024)), attrs);
+ attrs = Fcons (Fcons (Qrss, make_fixnum_or_float (4*rss)), attrs);
+ EMACS_SUB_TIME (telapsed, tnow, tstart);
+ attrs = Fcons (Fcons (Qetime,
+ list3 (make_number
+ ((EMACS_SECS (telapsed) >> 16) & 0xffff),
+ make_number
+ (EMACS_SECS (telapsed) & 0xffff),
+ make_number
+ (EMACS_USECS (telapsed)))),
+ attrs);
+ time_from_jiffies (utime + stime, clocks_per_sec, &sec, &usec);
+ pcpu = (sec + usec / 1000000.0) / (EMACS_SECS (telapsed) + EMACS_USECS (telapsed) / 1000000.0);
+ if (pcpu > 1.0)
+ pcpu = 1.0;
+ attrs = Fcons (Fcons (Qpcpu, make_float (100 * pcpu)), attrs);
+ pmem = 4.0 * 100 * rss / procfs_get_total_memory ();
+ if (pmem > 100)
+ pmem = 100;
+ attrs = Fcons (Fcons (Qpmem, make_float (pmem)), attrs);
+ }
+ }
+ if (fd >= 0)
+ emacs_close (fd);
+
+ /* args */
+ strcpy (procfn_end, "/cmdline");
+ fd = emacs_open (fn, O_RDONLY, 0);
+ if (fd >= 0)
+ {
+ for (cmdline_size = 0; emacs_read (fd, &c, 1) == 1; cmdline_size++)
+ {
+ if (isspace (c) || c == '\\')
+ cmdline_size++; /* for later quoting, see below */
+ }
+ if (cmdline_size)
+ {
+ cmdline = xmalloc (cmdline_size + 1);
+ lseek (fd, 0L, SEEK_SET);
+ cmdline[0] = '\0';
+ if ((nread = read (fd, cmdline, cmdline_size)) >= 0)
+ cmdline[nread++] = '\0';
+ else
+ {
+ /* Assigning zero to `nread' makes us skip the following
+ two loops, assign zero to cmdline_size, and enter the
+ following `if' clause that handles unknown command
+ lines. */
+ nread = 0;
+ }
+ /* We don't want trailing null characters. */
+ for (p = cmdline + nread - 1; p > cmdline && !*p; p--)
+ nread--;
+ for (p = cmdline; p < cmdline + nread; p++)
+ {
+ /* Escape-quote whitespace and backslashes. */
+ if (isspace (*p) || *p == '\\')
+ {
+ memmove (p + 1, p, nread - (p - cmdline));
+ nread++;
+ *p++ = '\\';
+ }
+ else if (*p == '\0')
+ *p = ' ';
+ }
+ cmdline_size = nread;
+ }
+ if (!cmdline_size)
+ {
+ if (!cmd)
+ cmd = "???";
+ if (!cmdsize)
+ cmdsize = strlen (cmd);
+ cmdline_size = cmdsize + 2;
+ cmdline = xmalloc (cmdline_size + 1);
+ strcpy (cmdline, "[");
+ strcat (strncat (cmdline, cmd, cmdsize), "]");
+ }
+ emacs_close (fd);
+ /* Command line is encoded in locale-coding-system; decode it. */
+ cmd_str = make_unibyte_string (cmdline, cmdline_size);
+ decoded_cmd = code_convert_string_norecord (cmd_str,
+ Vlocale_coding_system, 0);
+ xfree (cmdline);
+ attrs = Fcons (Fcons (Qargs, decoded_cmd), attrs);
+ }
+
+ UNGCPRO;
+ return attrs;
+}
+
+#elif defined (SOLARIS2) && defined (HAVE_PROCFS)
+
+/* The <procfs.h> header does not like to be included if _LP64 is defined and
+ __FILE_OFFSET_BITS == 64. This is an ugly workaround that. */
+#if !defined (_LP64) && defined (_FILE_OFFSET_BITS) && (_FILE_OFFSET_BITS == 64)
+#define PROCFS_FILE_OFFSET_BITS_HACK 1
+#undef _FILE_OFFSET_BITS
+#else
+#define PROCFS_FILE_OFFSET_BITS_HACK 0
+#endif
+
+#include <procfs.h>
+
+#if PROCFS_FILE_OFFSET_BITS_HACK == 1
+#define _FILE_OFFSET_BITS 64
+#endif /* PROCFS_FILE_OFFSET_BITS_HACK == 1 */
+
+Lisp_Object
+system_process_attributes (Lisp_Object pid)
+{
+ char procfn[PATH_MAX], fn[PATH_MAX];
+ struct stat st;
+ struct passwd *pw;
+ struct group *gr;
+ char *procfn_end;
+ struct psinfo pinfo;
+ int fd;
+ ssize_t nread;
+ int proc_id, uid, gid;
+ Lisp_Object attrs = Qnil;
+ Lisp_Object decoded_cmd, tem;
+ struct gcpro gcpro1, gcpro2;
+ EMACS_INT uid_eint, gid_eint;
+
+ CHECK_NUMBER_OR_FLOAT (pid);
+ proc_id = FLOATP (pid) ? XFLOAT_DATA (pid) : XINT (pid);
+ sprintf (procfn, "/proc/%u", proc_id);
+ if (stat (procfn, &st) < 0)
+ return attrs;
+
+ GCPRO2 (attrs, decoded_cmd);
+
+ /* euid egid */
+ uid = st.st_uid;
+ /* Use of EMACS_INT stops GCC whining about limited range of data type. */
+ uid_eint = uid;
+ attrs = Fcons (Fcons (Qeuid, make_fixnum_or_float (uid_eint)), attrs);
+ BLOCK_INPUT;
+ pw = getpwuid (uid);
+ UNBLOCK_INPUT;
+ if (pw)
+ attrs = Fcons (Fcons (Quser, build_string (pw->pw_name)), attrs);
+
+ gid = st.st_gid;
+ gid_eint = gid;
+ attrs = Fcons (Fcons (Qegid, make_fixnum_or_float (gid_eint)), attrs);
+ BLOCK_INPUT;
+ gr = getgrgid (gid);
+ UNBLOCK_INPUT;
+ if (gr)
+ attrs = Fcons (Fcons (Qgroup, build_string (gr->gr_name)), attrs);
+
+ strcpy (fn, procfn);
+ procfn_end = fn + strlen (fn);
+ strcpy (procfn_end, "/psinfo");
+ fd = emacs_open (fn, O_RDONLY, 0);
+ if (fd >= 0
+ && (nread = read (fd, (char*)&pinfo, sizeof(struct psinfo)) > 0))
+ {
+ attrs = Fcons (Fcons (Qppid, make_fixnum_or_float (pinfo.pr_ppid)), attrs);
+ attrs = Fcons (Fcons (Qpgrp, make_fixnum_or_float (pinfo.pr_pgid)), attrs);
+ attrs = Fcons (Fcons (Qsess, make_fixnum_or_float (pinfo.pr_sid)), attrs);
+
+ {
+ char state_str[2];
+ state_str[0] = pinfo.pr_lwp.pr_sname;
+ state_str[1] = '\0';
+ tem = build_string (state_str);
+ attrs = Fcons (Fcons (Qstate, tem), attrs);
+ }
+
+ /* FIXME: missing Qttyname. psinfo.pr_ttydev is a dev_t,
+ need to get a string from it. */
+
+ /* FIXME: missing: Qtpgid */
+
+ /* FIXME: missing:
+ Qminflt
+ Qmajflt
+ Qcminflt
+ Qcmajflt
+
+ Qutime
+ Qcutime
+ Qstime
+ Qcstime
+ Are they available? */
+
+ attrs = Fcons (Fcons (Qtime,
+ list3 (make_number (pinfo.pr_time.tv_sec >> 16),
+ make_number (pinfo.pr_time.tv_sec & 0xffff),
+ make_number (pinfo.pr_time.tv_nsec))),
+ attrs);
+
+ attrs = Fcons (Fcons (Qctime,
+ list3 (make_number (pinfo.pr_ctime.tv_sec >> 16),
+ make_number (pinfo.pr_ctime.tv_sec & 0xffff),
+ make_number (pinfo.pr_ctime.tv_nsec))),
+ attrs);
+
+ attrs = Fcons (Fcons (Qpri, make_number (pinfo.pr_lwp.pr_pri)), attrs);
+ attrs = Fcons (Fcons (Qnice, make_number (pinfo.pr_lwp.pr_nice)), attrs);
+ attrs = Fcons (Fcons (Qthcount, make_fixnum_or_float (pinfo.pr_nlwp)), attrs);
+
+ attrs = Fcons (Fcons (Qstart,
+ list3 (make_number (pinfo.pr_start.tv_sec >> 16),
+ make_number (pinfo.pr_start.tv_sec & 0xffff),
+ make_number (pinfo.pr_start.tv_nsec))),
+ attrs);
+ attrs = Fcons (Fcons (Qvsize, make_fixnum_or_float (pinfo.pr_size)), attrs);
+ attrs = Fcons (Fcons (Qrss, make_fixnum_or_float (pinfo.pr_rssize)), attrs);
+
+ /* pr_pctcpu and pr_pctmem are encoded as a fixed point 16 bit number in [0 ... 1]. */
+ attrs = Fcons (Fcons (Qpcpu, (pinfo.pr_pctcpu * 100.0) / (double)0x8000), attrs);
+ attrs = Fcons (Fcons (Qpmem, (pinfo.pr_pctmem * 100.0) / (double)0x8000), attrs);
+
+ decoded_cmd
+ = code_convert_string_norecord (make_unibyte_string (pinfo.pr_fname,
+ strlen (pinfo.pr_fname)),
+ Vlocale_coding_system, 0);
+ attrs = Fcons (Fcons (Qcomm, decoded_cmd), attrs);
+ decoded_cmd
+ = code_convert_string_norecord (make_unibyte_string (pinfo.pr_psargs,
+ strlen (pinfo.pr_psargs)),
+ Vlocale_coding_system, 0);
+ attrs = Fcons (Fcons (Qargs, decoded_cmd), attrs);
+ }
+
+ if (fd >= 0)
+ emacs_close (fd);
+
+ UNGCPRO;
+ return attrs;
+}
+
+/* The WINDOWSNT implementation is in w32.c.
+ The MSDOS implementation is in dosfns.c. */
+#elif !defined (WINDOWSNT) && !defined (MSDOS)
+
+Lisp_Object
+system_process_attributes (Lisp_Object pid)
+{
+ return Qnil;
+}
+
+#endif /* !defined (WINDOWSNT) */
+
/* arch-tag: edb43589-4e09-4544-b325-978b5b121dcf
(do not change this comment) */