vixie@wrl.dec.com (Paul Vixie) (05/04/90)
Submitted-by: vixie@wrl.dec.com (Paul Vixie)
Posting-number: Volume 7, Issue 25
Archive-name: awl/part11
#! /bin/sh
# This is a shell archive. Remove anything before this line, then unpack
# it by saving it into a file and typing "sh file". To overwrite existing
# files, type "sh file -c". You can also feed this as standard input via
# unshar, or by typing "sh <file", e.g.. If this archive is complete, you
# will see the following message at the end:
# "End of archive 11 (of 17)."
# Contents: sysrtns.c
# Wrapped by vixie@jove.pa.dec.com on Mon Apr 30 01:25:25 1990
PATH=/bin:/usr/bin:/usr/ucb ; export PATH
if test -f 'sysrtns.c' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'sysrtns.c'\"
else
echo shar: Extracting \"'sysrtns.c'\" \(35683 characters\)
sed "s/^X//" >'sysrtns.c' <<'END_OF_FILE'
X#ifndef lint
static char *rcsid = "$Header: /usr/src/local/awl/RCS/sysrtns.c,v 2.1 90/04/19 20:05:56 jkh Exp $";
X#endif
X
X/*
X *
X * Copyright 1989
X * Jordan K. Hubbard
X *
X * PCS Computer Systeme, GmbH.
X * Munich, West Germany
X *
X *
X * This file is part of AWL.
X *
X * AWL is free software; you can redistribute it and/or modify
X * it under the terms of the GNU General Public License as published by
X * the Free Software Foundation; either version 1, or (at your option)
X * any later version.
X *
X * AWL is distributed in the hope that it will be useful,
X * but WITHOUT ANY WARRANTY; without even the implied warranty of
X * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
X * GNU General Public License for more details.
X *
X * You should have received a copy of the GNU General Public License
X * along with AWL; see the file COPYING. If not, write to
X * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
X *
X *
X */
X
X/*
X * This file contains all the system (UNIX) specific built-ins and
X * a few awl utility functions.
X *
X * Note that mathrtns.c also uses some UNIX dependant features
X * to handle floating point traps.
X *
X * $Log: sysrtns.c,v $
X * Revision 2.1 90/04/19 20:05:56 jkh
X * Alpha checkin.
X *
X * Revision 2.0 90/03/26 01:43:52 jkh
X * pre-beta check-in
X *
X */
X
X#include "AwlP.h"
X#include "y.tab.h"
X#include <dirent.h>
X#include <grp.h>
X#include <pwd.h>
X
X/* global signal table */
Import Symbol *_procSignalTable;
X
Local Value arg, arg2, arg3;
Local int doit(), print_value();
Local void illfmt();
Local char *ctor();
Local Value get_value();
X
X#ifndef MAXPATHLEN
X#define MAXPATHLEN 1024 /* take a guess */
X#endif
X
X/*********************************
X * AWL "internal" utilities *
X * (i.e. not UNIX counterparts) *
X *********************************/
X
X/*
X * _argc():
X * Returns number of args passed to function.
X */
DEFUN(_argc)
X{
X value_set(arg, DATA, INT, int, value_int(awl_stack(aw)[awl_fp(aw) - 1]));
X return(arg);
X}
X
X/*
X * _argv(INT):
X * Returns a specific arg number. This is VERY awl specific (I.E. if you
X * change awl's basic frame layout, this will break).
X */
DEFUN(_argv)
X{
X arg = get_arg(aw, 1, INT, TRUE);
X if (value_type(arg)) {
X int old_nparms = value_int(awl_stack(aw)[awl_fp(aw) - 1]);
X debug(aw, "_argv: fetching arg #%d from frame.", value_int(arg));
X if (value_int(arg) > old_nparms) {
X exec_warn(aw, "_argv: Requested arg #%d > %d passed",
X value_int(arg), old_nparms);
X value_clear(arg);
X }
X else {
X /*
X * We can't simply use FRAME_OFFSET here because we're
X * loading the value from the previous stack frame, not the
X * current one.
X */
X arg = do_load(aw,
X awl_stack(aw)[value_int(awl_stack(aw)[awl_fp(aw)])
X - ((old_nparms
X - value_int(arg))
X + FRAME_REG_SIZE)],
X TRUE);
X }
X }
X return(arg);
X}
X
X/*
X * assign(FDESC, NAME):
X * Redirect stdin, stdout or stderr.
X */
DEFUN(assign)
X{
X arg = get_arg(aw, 1, ANY, FALSE);
X if (is_filedesc_type(value_type(arg))) {
X FILE *ifp = (value_type(arg) != FILEPDESC ? value_file(arg)
X : proc_in(value_any(arg))),
X *ofp = (value_type(arg) != FILEPDESC ? value_file(arg)
X : proc_out(value_any(arg)));
X
X arg2 = get_arg(aw, 2, STRING, TRUE);
X if (!stricomp(value_string(arg2), "stdin"))
X awl_in(aw) = ifp;
X else if (!stricomp(value_string(arg2), "stdout"))
X awl_out(aw) = ofp;
X else if (!stricomp(value_string(arg2), "stderr"))
X awl_err(aw) = ofp;
X else
X exec_warn("assign: Expected stdin, stdout or stderr. Got: %s",
X value_string(arg2));
X }
X else {
X exec_warn("assign: Expected type file descriptor, got '%s'",
X type_name(value_type(arg)));
X value_clear(arg);
X }
X return(arg);
X}
X
X/*
X * classid(name):
X * Returns class id (as int) for name.
X */
DEFUN(classid)
X{
X String name;
X
X arg = get_arg(aw, 1, STRING, TRUE);
X if (value_type(arg)) {
X name = value_string(arg);
X value_set(arg, DATA, INT, int, map_resword_to_token(name, T_CLASS));
X }
X return(arg);
X}
X
X/*
X * classof(value):
X * Returns class of value as an int.
X */
DEFUN(classof)
X{
X int tmp;
X
X arg = get_arg(aw, 1, ANY, FALSE);
X tmp = value_class(arg);
X value_set(arg, DATA, INT, int, tmp);
X return(arg);
X}
X
X/*
X * get(type):
X * Get formatted input of "type" from input. If "type" is ANY, try to
X * intuit type.
X */
DEFUN(get)
X{
X arg = get_arg(aw, 1, INT, TRUE);
X arg2 = get_value(aw, arg);
X return(arg2);
X}
X
X/*
X * input(value, type):
X * Prints "value" to stdout and waits for data of type "type" on stdin.
X * Basically a convenience function for the often used print()/get()
X * pair.
X */
DEFUN(input)
X{
X print_value(aw, get_arg(aw, 1, ANY, FALSE));
X return(get_value(aw, get_arg(aw, 2, INT, TRUE)));
X}
X
X/*
X * length(type):
X * Returns the length of a string, list or file (coercing expression to
X * a string if necessary).
X */
DEFUN(length)
X{
X arg = get_arg(aw, 1, ANY, FALSE);
X if (value_type(arg) == STRING)
X value_set(arg, DATA, INT, int, strlen(value_string(arg)));
X else if (value_type(arg) == LIST)
X value_set(arg, DATA, INT, int, list_len(value_list(arg)));
X else if (is_filedesc_type(value_type(arg))) {
X struct stat sb;
X FILE *fp;
X Import int fstat();
X if (value_type(arg) == FILEDESC)
X fp = value_file(arg);
X else
X fp = (proc_in(value_any(arg)) ? proc_in(value_any(arg))
X : proc_out(value_any(arg)));
X
X fstat(fileno(fp), &sb);
X value_set(arg, DATA, INT, int, sb.st_size);
X }
X else {
X Value x;
X
X x = coerce(aw, arg, STRING);
X value_set(arg, DATA, INT, int, strlen(value_string(x)));
X }
X return(arg);
X}
X
X/*
X * load(STRING):
X * Load awl code from file STRING. Return 0 if successful, 1 if failure.
X */
DEFUN(load)
X{
X arg = get_arg(aw, 1, STRING, TRUE);
X if (value_any(arg)) {
X String file = value_string(arg);
X
X value_set(arg, DATA, INT, int, parseFile(aw, file));
X }
X return(arg);
X}
X
X/*
X * print(n...n1):
X * Print values from the stack. This is a good example of a routine
X * handling a variable number of arguments.
X */
DEFUN(print)
X{
X int i, len = 0;
X
X for (i = 1; i <= awl_nparms(aw); i++) {
X arg = get_arg(aw, i, ANY, FALSE);
X len += print_value(aw, arg);
X }
X fflush(awl_out(aw));
X value_set(arg, DATA, INT, int, len);
X return(arg);
X}
X
X/*
X * println(n..n1):
X * same as print but with a newline automatically appended.
X */
DEFUN(println)
X{
X arg = awl_print(aw);
X fputc('\n', awl_out(aw));
X ++value_int(arg);
X return(arg);
X}
X
X/*
X * printname(INT):
X * Returns printable version of type/class INT
X */
DEFUN(printname)
X{
X String result;
X
X arg = get_arg(aw, 1, INT, FALSE);
X result = map_token_to_resword(value_int(arg), T_ALL);
X if (result)
X value_set(arg, DATA, STRING, aobj, new_aobj(XtNewString(result)));
X else
X value_set(arg, DATA, INT, int, 0);
X return(arg);
X}
X
X/*
X * setbuf(FILE, STRING):
X * Set the buffer for a file descriptor.
X */
DEFUN(setbuf)
X{
X arg = get_arg(aw, 1, ANY, FALSE);
X if (value_type(arg) == FILEDESC || value_type(arg) == FILEPDESC) {
X arg2 = get_arg(aw, 2, ANY, FALSE);
X if (value_type(arg2) == STRING || value_type(arg2) == INT
X || value_type(arg2) == ANY) {
X Generic buf1 = (value_type(arg2) == STRING
X ? (Generic)value_string(arg2)
X : value_any(arg2));
X
X if (value_type(arg) == FILEDESC)
X setbuf(value_file(arg), buf1);
X else {
X if (proc_in(value_any(arg)) && proc_out(value_any(arg))) {
X arg3 = get_arg(aw, 3, ANY, FALSE);
X if (value_type(arg3) == STRING
X || value_type(arg3) == INT
X || value_type(arg3) == ANY) {
X Generic buf2 = (value_type(arg3) == STRING
X ? (Generic)value_string(arg3)
X : value_any(arg3));
X setbuf(proc_in(value_any(arg)), buf1);
X setbuf(proc_out(value_any(arg)), buf2);
X }
X else
X exec_error(aw, "Need 2 buffers for this process descriptor");
X }
X else if (proc_in(value_any(arg)))
X setbuf(proc_in(value_any(arg)), buf1);
X else if (proc_out(value_any(arg)))
X setbuf(proc_out(value_any(arg)), buf1);
X else
X exec_error(aw, "Process has no open descriptors!");
X }
X }
X else
X exec_error(aw, "Illegal buffer argument for setbuf");
X }
X else
X exec_error(aw, "Expected file descriptor, got '%s'",
X type_name(value_type(arg)));
X return(arg);
X}
X
X/*
X * symbol(STRING):
X * Look for a symbol named STRING and return it as-is.
X */
DEFUN(symbol)
X{
X arg = get_arg(aw, 1, STRING, TRUE);
X if (value_any(arg)) {
X String s = value_string(arg);
X value_set(arg, DATA, SYMBOL, symbol, symbol_find(aw, s));
X }
X return(arg);
X}
X
X/*
X * typeid(name):
X * Returns type id (as int) for name.
X */
DEFUN(typeid)
X{
X String name;
X
X arg = get_arg(aw, 1, STRING, TRUE);
X if (value_type(arg)) {
X name = value_string(arg);
X value_set(arg, DATA, INT, int, map_resword_to_token(name, T_TYPE));
X }
X return(arg);
X}
X
X/*
X * typeof(value):
X * Returns type of value as an int.
X */
DEFUN(typeof)
X{
X int tmp;
X
X arg = get_arg(aw, 1, ANY, FALSE);
X tmp = value_type(arg);
X value_set(arg, DATA, INT, int, tmp);
X return(arg);
X}
X
X
X/************************************
X * UNIX interface functions *
X ************************************/
X
X/*
X * chdir(STRING):
X * Do a chdir(STRING).
X */
DEFUN(chdir)
X{
X Import int chdir();
X int status = -1;
X
X arg = get_arg(aw, 1, STRING, TRUE);
X if (value_type(arg))
X status = chdir(value_string(arg));
X value_set(arg, DATA, INT, int, status);
X return(arg);
X}
X
X/*
X * chmod(STRING, INT):
X * chmod() file STRING to mode INT.
X */
DEFUN(chmod)
X{
X int status = -1;
X Import int chmod();
X
X arg = get_arg(aw, 1, STRING, TRUE);
X if (value_type(arg)) {
X arg2 = get_arg(aw, 2, INT, TRUE);
X if (value_type(arg2))
X status = chmod(value_string(arg), value_int(arg2));
X }
X value_set(arg, DATA, INT, int, status);
X return(arg);
X}
X
X/*
X * chown(STRING, INT1, INT2):
X * chown() file STRING to user INT1 and group INT2.
X */
DEFUN(chown)
X{
X int status = -1;
X Import int chown(), fchown();
X
X arg = get_arg(aw, 1, ANY, FALSE);
X if (value_type(arg) == STRING || value_type(arg) == FILEDESC) {
X arg2 = get_arg(aw, 2, INT, TRUE);
X if (value_type(arg2)) {
X arg3 = get_arg(aw, 3, INT, TRUE);
X if (value_type(arg3)) {
X if (value_type(arg) == STRING)
X status = chown(value_string(arg),
X value_int(arg2),
X value_int(arg3));
X else
X status = fchown(fileno(value_file(arg)),
X value_int(arg2),
X value_int(arg3));
X }
X }
X }
X else {
X exec_warn(aw, "chown: Expected file name or descriptor, got '%s'",
X type_name(value_type(arg)));
X }
X value_set(arg, DATA, INT, int, status);
X return(arg);
X}
X
X/*
X * chroot(STRING):
X * Change root directory to STRING.
X */
DEFUN(chroot)
X{
X int status = -1;
X Import int chroot();
X
X arg = get_arg(aw, 1, STRING, TRUE);
X if (type_name(arg)) {
X status = chroot(value_string(arg));
X }
X value_set(arg, DATA, INT, int, status);
X return(arg);
X}
X
X/*
X * close(FDESC):
X * close() a file descriptor or process.
X */
DEFUN(close)
X{
X int status = EOF;
X
X arg = get_arg(aw, 1, ANY, FALSE);
X if (value_type(arg) == FILEDESC)
X status = fclose(value_file(arg));
X else if (value_type(arg) == FILEPDESC)
X status = p_pclose(aw, value_any(arg));
X else
X exec_warn("close: Expected file descriptor, got '%s'",
X type_name(value_type(arg)));
X value_set(arg, DATA, INT, int, status);
X return(arg);
X}
X
X/*
X * exec(STRING, LIST):
X * execvp() file STRING with arguments LIST.
X */
DEFUN(exec)
X{
X Import int execvp();
X
X arg = get_arg(aw, 1, STRING, TRUE);
X if (value_type(arg)) {
X arg2 = get_arg(aw, 2, LIST, TRUE);
X if (value_type(arg2)) {
X execvp(value_string(arg), value_list(arg2));
X value_set(arg, DATA, INT, int, -1); /* we failed */
X }
X }
X return(arg); /* maybe */
X}
X
X/*
X * exit(INT):
X * exit() with return code (INT)expr.
X */
DEFUN(exit)
X{
X arg = get_arg(aw, 1, INT, FALSE);
X exit(value_int(arg));
X return(arg); /* sure hope not! */
X}
X
X/*
X * fork():
X * fork() a process. Wheee... This may get you into trouble
X * if you don't handle your file descriptors properly.
X */
DEFUN(fork)
X{
X Import int fork();
X
X value_set(arg, DATA, INT, int, fork());
X return(arg);
X}
X
X/*
X * free(value):
X * Free's previously malloc'd value.
X */
DEFUN(free)
X{
X arg = get_arg(aw, 1, STRING, TRUE);
X if (value_type(arg)) {
X if (value_class(arg) != ALLOCATED)
X exec_warn(aw, "attempt to free non-malloc'd variable");
X else {
X if (--aobj_cnt(value_aobj(arg)) <= 0) {
X XtFree(value_string(arg));
X XtFree(value_aobj(arg));
X value_clear(arg);
X }
X }
X }
X return(arg);
X}
X
X/*
X * fmt_time(fmt, time):
X * Format time description according to fmt.
X */
DEFUN(fmt_time)
X{
X String res;
X
X arg = get_arg(aw, 1, STRING, TRUE);
X if (value_type(arg)) {
X arg2 = get_arg(aw, 2, ANY, FALSE);
X if ((res = format_time(value_string(arg), value_any(arg2))) != NULL)
X value_set(arg, DATA, STRING, aobj, new_aobj(res));
X else
X value_clear(arg);
X }
X return(arg);
X}
X
X/*
X * getenv(STRING):
X * Returns environment variable STRING.
X */
DEFUN(getenv)
X{
X String cp = NULL;
X Import String getenv();
X
X arg = get_arg(aw, 1, STRING, TRUE);
X if (value_type(arg)) {
X if ((cp = getenv(value_string(arg))) != NULL)
X cp = XtNewString(cp);
X }
X if (cp)
X value_set(arg, DATA, STRING, aobj, new_aobj(cp));
X else
X value_clear(arg);
X return(arg);
X}
X
X/*
X * getegid():
X * Return our effective GID.
X */
DEFUN(getegid)
X{
X Import int getegid();
X
X value_set(arg, DATA, INT, int, getegid());
X return(arg);
X}
X
X/*
X * geteuid():
X * Return our effective UID.
X */
DEFUN(geteuid)
X{
X Import int geteuid();
X
X value_set(arg, DATA, INT, int, geteuid());
X return(arg);
X}
X
X/*
X * getgid():
X * Return our GID.
X */
DEFUN(getgid)
X{
X Import int getgid();
X
X value_set(arg, DATA, INT, int, getgid());
X return(arg);
X}
X
X/*
X * getpid()
X * Return our PID.
X */
DEFUN(getpid)
X{
X Import int getpid();
X
X value_set(arg, DATA, INT, int, getpid());
X return(arg);
X}
X
X/*
X * getuid():
X * Return our UID.
X */
DEFUN(getuid)
X{
X Import int getuid();
X
X value_set(arg, DATA, INT, int, getuid());
X return(arg);
X}
X
X/*
X * getwd():
X * return the current working directory.
X */
DEFUN(getwd)
X{
X Import String getwd();
X char name[MAXPATHLEN + 1];
X String cp = NULL;
X
X if (getwd(name))
X cp = XtNewString(name);
X if (cp)
X value_set(arg, DATA, STRING, aobj, new_aobj(cp));
X else
X value_clear(arg);
X return(arg);
X}
X
X/*
X * group(ANY):
X * Return the group name for group ID or group ID for group name.
X */
DEFUN(group)
X{
X Import struct group *getgrnam(), *getgrgid();
X struct group *id = NULL;
X int typ;
X
X arg = get_arg(aw, 1, ANY, FALSE);
X typ = value_type(arg);
X
X if (typ == STRING)
X id = getgrnam(value_string(arg));
X else if (typ == INT) {
X int x = value_int(arg);
X
X if (x < 0)
X x = -x;
X id = getgrgid(x);
X }
X if (id) {
X if (typ == STRING)
X value_set(arg, DATA, INT, int, id->gr_gid);
X else if (typ == INT) {
X if (value_int(arg) < 0)
X value_set(arg, DATA, LIST, aobj,
X new_aobj(list_dup(aw, id->gr_mem)));
X else
X value_set(arg, DATA, STRING, aobj,
X new_aobj(XtNewString(id->gr_name)));
X }
X }
X return(arg);
X}
X
X/*
X * kill(proc, sig):
X * Try to send sig to pid/process file desc.
X */
DEFUN(kill)
X{
X Import int kill();
X
X arg = get_arg(aw, 1, ANY, FALSE);
X if (value_type(arg) == INT || value_type(arg) == FILEPDESC) {
X arg2 = get_arg(aw, 2, INT, TRUE);
X if (value_type(arg2)) {
X int pid = (value_type(arg) == INT ? value_int(arg)
X : proc_pid(value_any(arg)));
X
X value_set(arg, DATA, INT, int, kill(pid, value_int(arg2)));
X }
X }
X else
X exec_warn(aw, "kill: expected pid or process file desc. Got '%s'",
X type_name(value_type(arg)));
X return(arg);
X}
X
X/*
X * malloc(INT):
X * Returns INT bytes of allocated space.
X */
DEFUN(malloc)
X{
X String cp;
X int size;
X
X arg = get_arg(aw, 1, INT, TRUE);
X if (value_type(arg)) {
X size = value_int(arg);
X if ((cp = XtMalloc(size)) != NULL) {
X bzero(cp, size);
X value_set(arg, ALLOCATED, STRING, aobj, new_aobj(cp));
X }
X else
X value_clear(arg);
X }
X return(arg);
X}
X
X/*
X * open(NAME, MODE):
X * open() a file or process with a given mode.
X */
DEFUN(open)
X{
X arg = get_arg(aw, 1, STRING, TRUE);
X if (value_type(arg)) {
X arg2 = get_arg(aw, 2, STRING, TRUE);
X if (value_type(arg2)) {
X FILE *fp;
X int type;
X char mode[3];
X
X strncpy(mode, value_string(arg2), 2);
X mode[2] = '\0';
X if (mode[1] == 'p') {
X mode[1] = '\0';
X value_set(arg, DATA, FILEPDESC, any,
X p_popen(aw, value_string(arg), mode));
X }
X else {
X value_set(arg, DATA, FILEDESC, file,
X fopen(value_string(arg), mode));
X }
X }
X }
X return(arg);
X}
X
X/*
X * perror(STRING):
X * Call perror(STRING).
X */
DEFUN(perror)
X{
X Import void perror();
X
X arg = get_arg(aw, 1, STRING, TRUE);
X if (value_type(arg)) {
X perror(value_string(arg));
X }
X return(arg);
X}
X
X/*
X * printf(format [,arg] ...)
X * Do a printf() using our own sprintf() call.
X */
DEFUN(printf)
X{
X int cnt;
X Import Value awl_sprintf();
X
X arg = awl_sprintf(aw);
X cnt = fprintf(awl_out(aw), value_string(arg));
X do_free(&arg);
X value_set(arg, DATA, INT, int, cnt);
X return(arg);
X}
X
X/*
X * read(dest, cnt):
X * read cnt bytes from stdin, storing in dest.
X */
DEFUN(read)
X{
X int result;
X
X arg = get_arg(aw, 1, ANY, FALSE);
X arg2 = get_arg(aw, 2, INT, TRUE);
X if (value_type(arg) == STRING)
X result = fread(value_string(arg), 1, value_int(arg2), awl_in(aw));
X else
X result = fread(value_any(arg), 1, value_int(arg2), awl_in(aw));
X value_set(arg, DATA, INT, int, result);
X return(arg);
X}
X
X/*
X * readdir(STRING):
X * Slurp in directory STRING and return list of files therein.
X * (note: This does *not* match the behaviour of its unix namesake, but
X * I like this approach better).
X */
X
X#define LIST_HUNK 32
X
DEFUN(readdir)
X{
X DIR *frobozz;
X struct dirent *dp;
X int lsize, lmax;
X String *ll;
X
X arg = get_arg(aw, 1, STRING, TRUE);
X if (value_type(arg)) {
X frobozz = opendir(value_string(arg));
X if (frobozz) {
X lsize = lmax = 0;
X while ((dp = readdir(frobozz)) != NULL) {
X if (!lmax) {
X lmax = LIST_HUNK;
X ll = (String *)XtMalloc(lmax * sizeof(String *));
X }
X else if (lsize == lmax) {
X lmax += LIST_HUNK;
X ll = (String *)XtRealloc(ll, lmax * sizeof(String *));
X }
X ll[lsize++] = XtNewString(dp->d_name);
X }
X ll[lsize] = NULL;
X closedir(frobozz);
X value_set(arg, DATA, LIST, aobj, new_aobj(ll));
X }
X else
X value_clear(arg);
X }
X else
X value_clear(arg);
X return(arg);
X}
X
X/*
X * setgid(INT):
X * Do a setgid() call.
X */
DEFUN(setgid)
X{
X Import int setgid();
X
X arg = get_arg(aw, 1, INT, TRUE);
X if (value_type(arg)) {
X int gid = value_int(arg);
X
X value_set(arg, DATA, INT, int, setgid(gid));
X }
X return(arg);
X}
X
X/*
X * setuid(INT):
X * Do a setuid() call.
X */
DEFUN(setuid)
X{
X Import int setuid();
X
X arg = get_arg(aw, 1, INT, TRUE);
X if (value_type(arg)) {
X int uid = value_int(arg);
X
X value_set(arg, DATA, INT, int, setuid(uid));
X }
X return(arg);
X}
X
X/*
X * signal(INT, sym):
X * Set signal routine for a given signal INT.
X */
DEFUN(signal)
X{
X Symbol oldval = (Symbol)NULL;
X
X arg = get_arg(aw, 1, INT, TRUE);
X if (value_type(arg)) {
X int signo = value_int(arg);
X
X if (signo < 0 || signo >= MAXSIG)
X exec_warn(aw, "Illegal signal number %d", value_int(arg));
X else {
X arg2 = get_arg(aw, 2, ANY, FALSE);
X if (!_procSignalTable) {
X _procSignalTable =
X (Symbol *)XtMalloc(sizeof(Symbol) * MAXSIG);
X bzero(_procSignalTable, sizeof(Symbol) * MAXSIG);
X }
X oldval = _procSignalTable[signo];
X /*
X * Since signals are process global and there is no limit on
X * the number of awl widgets a process may have, we warn the
X * user of any conflicts between awl widget instances using
X * the signal mechanism.
X */
X if (oldval > (Symbol)MY_SIG_IGN && aw != symbol_root(oldval))
X exec_warn(aw, "Widget %x usurping handler for signal %d",
X signo);
X if (value_type(arg2) == INT) {
X if (value_int(arg2) == MY_SIG_IGN)
X signal(signo, SIG_IGN);
X else if (value_int(arg2) == MY_SIG_DFL)
X signal(signo, SIG_DFL);
X else
X exec_error(aw, "Illegal int passed as signal func");
X _procSignalTable[signo] = (Symbol)value_int(arg2);
X }
X else if (value_type(arg2) == SYMBOL) {
X if (symbol_is_function(value_symbol(arg2))) {
X _procSignalTable[signo] = value_symbol(arg2);
X signal(signo, do_signal_user);
X }
X else
X exec_error(aw, "Signal handler is not a function");
X }
X else
X exec_error(aw, "Signal handler must be a function symbol");
X }
X }
X value_set(arg, DATA, SYMBOL, symbol, oldval);
X return(arg);
X}
X
X/*
X * sleep(INT):
X * sleep() for INT seconds.
X */
DEFUN(sleep)
X{
X Import unsigned int sleep();
X
X arg = get_arg(aw, 1, INT, TRUE);
X if (value_type(arg))
X sleep(value_int(arg));
X return(arg);
X}
X
X/*
X * sprintf(var, format [,arg] ...)
X * Do a sprintf to "var".
X *
X * This routine was taken almost verbatim from Chris Torek and Fred Blonder's
X * Uncopyrighted "shell printf()" code. See the man page.
X *
X */
DEFUN(sprintf)
X{
X register String cp, convp, targstr;
X register int ch, ndyn, flags;
X char cbuf[BUFSIZ]; /* separates each conversion */
X Local char hasmod[] = "has integer length modifier";
X Value target;
X int tindex, aa, nargs, tsize;
X
X /* flags */
X#define LONG 1
X#define SHORT 2
X
X nargs = awl_nparms(aw);
X if (nargs < 1) {
X value_set(arg, DATA, INT, int, 0);
X return(arg);
X }
X arg = get_arg(aw, 1, STRING, TRUE);
X if (value_type(arg)) {
X /* try to guess how much space we'll need */
X tsize = strlen(value_string(arg));
X for (aa = 1; aa <= nargs; aa++) {
X target = get_arg(aw, aa, ANY, FALSE);
X if (value_type(target) == STRING && value_string(target))
X tsize += strlen(value_string(target));
X else /* guesstimate generously */
X tsize += 28;
X }
X targstr = XtMalloc(tsize);
X bzero(targstr, tsize);
X value_set(target, DATA, STRING, aobj, new_aobj(targstr));
X
X aa = 1;
X tindex = 0;
X cp = value_string(arg);
X
X /*
X * Scan format string for conversion specifications.
X * (The labels would be loops, but then everything falls
X * off the right.)
X */
scan:
X while ((ch = *(cp++)) != '%') {
X if (ch == '\0')
X return(target);
X targstr[tindex++] = ch;
X }
X
X ++aa;
X ndyn = 0;
X flags = 0;
X convp = cbuf;
X *(convp++) = ch;
X
X /* scan for conversion character */
cvt:
X switch (ch = *(cp++)) {
X
X case '\0': /* unterminated conversion */
X targstr[tindex] = '\0';
X return(target);
X
X /* string or character format */
X case 'c': case 's':
X if (flags) {
X illfmt(aw, cbuf, convp, ch, hasmod);
X targstr[tindex] = '\0';
X return(target);
X }
X if (!doit(aw, cbuf, convp, aa, nargs, targstr, &tindex,
X ndyn, ch, ch)) {
X targstr[tindex] = '\0';
X return(target);
X }
X goto scan;
X
X /* integer formats */
X case 'd': case 'i': case 'o': case 'u': case 'x': case 'X':
X if ((flags & (LONG|SHORT)) == (LONG|SHORT)) {
X illfmt(aw, cbuf, convp, ch, "is both long and short");
X targstr[tindex] = '\0';
X return(target);
X }
X if (!doit(aw, cbuf, convp, aa, nargs, targstr, &tindex,
X ndyn, ch, (flags & LONG ? 'l' : flags & SHORT ? 'h' :
X 'i'))) {
X targstr[tindex] = '\0';
X return(target);
X }
X goto scan;
X
X /* floating point formats */
X case 'e': case 'E': case 'f': case 'g': case 'G':
X if (flags) {
X illfmt(aw, cbuf, convp, ch, hasmod);
X targstr[tindex] = '\0';
X return(target);
X }
X if (!doit(aw, cbuf, convp, aa, nargs, targstr, &tindex,
X ndyn, ch, 'f')) {
X targstr[tindex] = '\0';
X return(target);
X }
X goto scan;
X
X /* Roman (well, why not?) */
X case 'r': case 'R':
X if (flags) {
X illfmt(aw, cbuf, convp, ch, hasmod);
X targstr[tindex] = '\0';
X return(target);
X }
X if (!doit(aw, cbuf, convp, aa, nargs, targstr, &tindex,
X ndyn, 's', ch)) {
X targstr[tindex] = '\0';
X return(target);
X }
X goto scan;
X
X case '%': /* boring */
X targstr[tindex++] = '%';
X goto scan;
X
X /* short integers */
X case 'h':
X flags |= SHORT;
X break;
X
X /* long integers */
X case 'l':
X flags |= LONG;
X break;
X
X /* field-width or precision specifier, or flag: keep scanning */
X case '.': case '#': case '-': case '+': case ' ':
X case '0': case '1': case '2': case '3': case '4':
X case '5': case '6': case '7': case '8': case '9':
X break;
X
X /* dynamic field width or precision: count it */
X case '*':
X ndyn++;
X break;
X
X default: /* something we cannot handle */
X if (isascii(ch) && isprint(ch))
X cbuf[0] = ch, cbuf[1] = 0;
X else
X (void)sprintf(cbuf, "\\%03o", (unsigned char)ch);
X exec_warn(aw, "vprintf: illegal conversion character `%s'",
X cbuf);
X targstr[tindex] = '\0';
X return(target);
X /* NOTREACHED */
X }
X
X /* 2 leaves room for ultimate conversion char and for \0 */
X if (convp >= &cbuf[sizeof(cbuf) - 2]) {
X exec_warn(aw, "vprintf: conversion string too long");
X targstr[tindex] = '\0';
X return(target);
X }
X *(convp++) = ch;
X goto cvt;
X }
X return(target);
X}
X
X/*
X * stat(FMT, FILE):
X * Stat a file name or file descriptor, returning stat information according
X * to format string.
X */
DEFUN(stat)
X{
X struct stat sb;
X Value ret;
X Import int stat(), fstat();
X
X value_clear(ret);
X arg = get_arg(aw, 1, STRING, TRUE);
X if (value_type(arg)) {
X arg2 = get_arg(aw, 2, ANY, FALSE);
X if (value_type(arg2) == STRING) {
X if (!stat(value_string(arg2), &sb))
X value_set(ret, DATA, STRING, aobj,
X new_aobj(stat_expand(aw, value_string(arg2),
X value_string(arg), &sb)));
X }
X else if (is_filedesc_type(value_type(arg2))) {
X FILE *fp;
X char name[80];
X
X fp = (value_type(arg2) == FILEDESC ? value_file(arg2)
X : (proc_in(value_any(arg2)) ? proc_in(value_any(arg2))
X : proc_out(value_any(arg2))));
X
X if (!fstat(fileno(fp), &sb)) {
X sprintf(name, "<fdesc#%d>", value_file(arg2));
X value_set(ret, DATA, STRING, aobj,
X new_aobj(stat_expand(aw, name,
X value_string(arg), &sb)));
X }
X }
X else
X exec_warn(aw, "stat: Expected file name or descriptor, got %s",
X type_name(value_type(arg2)));
X }
X return(ret);
X}
X
X/*
X * system(STRING):
X * Do a system(STRING) call.
X */
DEFUN(system)
X{
X arg = get_arg(aw, 1, STRING, TRUE);
X if (value_type(arg)) {
X int status = system(value_string(arg));
X value_set(arg, DATA, INT, int, status);
X }
X return(arg);
X}
X
X/*
X * time():
X * Return the time in seconds since 00:00:00 GMT, January 1, 1970.
X */
DEFUN(time)
X{
X time_t ret;
X Import time_t time();
X
X ret = time(0);
X value_set(arg, DATA, ANY, any, (Generic)ret);
X return(arg);
X}
X
X/*
X * user(ANY):
X * Return user name for user ID or user ID for user name.
X */
DEFUN(user)
X{
X int typ;
X Import struct passwd *getpwnam(), *getpwuid();
X struct passwd *pw = NULL;
X
X arg = get_arg(aw, 1, ANY, FALSE);
X typ = value_type(arg);
X
X if (typ == STRING)
X pw = getpwnam(value_string(arg));
X else if (typ == INT)
X pw = getpwuid(value_int(arg));
X if (pw) {
X if (typ == STRING)
X value_set(arg, DATA, INT, int, pw->pw_uid);
X else if (typ == INT)
X value_set(arg, DATA, STRING, aobj,
X new_aobj(XtNewString(pw->pw_name)));
X }
X return(arg);
X}
X
X/*
X * write(dest, cnt):
X * write cnt bytes from dest to stdout.
X */
DEFUN(write)
X{
X int result;
X
X arg = get_arg(aw, 1, ANY, FALSE);
X arg2 = get_arg(aw, 2, INT, TRUE);
X if (value_type(arg) == STRING)
X result = fwrite(value_string(arg), 1, value_int(arg2), awl_out(aw));
X else
X result = fwrite(value_any(arg), 1, value_int(arg2), awl_out(aw));
X value_set(arg, DATA, INT, int, result);
X return(arg);
X}
X
X
X/******************************************
X * Various local work functions needed *
X * by the systems interface *
X ******************************************/
X
X/*
X * These next two functions are for sprintf/printf.
X */
Local void illfmt(aw, cbuf, convp, ch, why)
AwlWidget aw;
char *cbuf, *convp;
int ch;
char *why;
X{
X
X *(convp++) = ch;
X *convp = 0;
X exec_warn(aw, "vprintf: format `%s' illegal: %s", cbuf, why);
X}
X
X/*
X * Emit a conversion. cch holds the printf format character for
X * this conversion; cty holds a simplified version (all integer
X * conversions, e.g., are represented as 'i').
X */
Local int doit(aw, cbuf, convp, argn, nargs, targ, tidx, ndyn, cch, cty)
AwlWidget aw;
char *cbuf, *convp;
int argn, nargs;
String targ;
int *tidx, ndyn;
int cch, cty;
X{
X char *s;
X union { /* four basic conversion types */
X int i;
X long l;
X FTYPE d;
X String str;
X } arg;
X int a1, a2; /* dynamic width and/or precision */
X
X /* finish off the conversion string */
X s = convp;
X *(s++) = cch;
X *s = 0;
X s = cbuf;
X
X /* verify number of arguments */
X if (argn > nargs) {
X exec_warn(aw, "vprintf: not enough args for format `%s'", s);
X return(0);
X }
X
X /* pick up dynamic specifiers */
X if (ndyn) {
X a1 = value_int(get_arg(aw, argn, INT, FALSE));
X if (ndyn > 1)
X a2 = value_int(get_arg(aw, argn, INT, FALSE));
X if (ndyn > 2) {
X exec_warn(aw, "vprintf: too many `*'s in `%s'", s);
X return(0);
X }
X }
X
X#define PRINTF(what) \
X if (ndyn == 0) \
X *tidx += sprintf(targ + *tidx, s, what); \
X else if (ndyn == 1) \
X *tidx += sprintf(targ + *tidx, s, a1, what); \
X else \
X *tidx += sprintf(targ + *tidx, s, a1, a2, what);
X
X /* emit the appropriate conversion */
X switch (cty) {
X
X /* string */
X case 's':
X arg.str = value_string(get_arg(aw, argn, STRING, FALSE));
X if (arg.str)
X backslash_eliminate(arg.str, NORMAL_ELIMINATE, 0);
X else
X arg.str = "(null)";
X goto string;
X
X /* roman (much like string) */
X case 'r': case 'R':
X arg.str = ctor(value_int(get_arg(aw, argn, INT, FALSE)), cty == 'R');
X goto string;
X
X string:
X PRINTF(arg.str);
X break;
X
X /* floating point */
X case 'f':
X arg.d = value_float(get_arg(aw, argn, FLOAT, FALSE));
X PRINTF(arg.d);
X break;
X
X /* character */
X case 'c':
X arg.i = (int)value_char(get_arg(aw, argn, CHAR, FALSE));
X goto integer;
X
X /* short integer */
X case 'h':
X arg.i = (short)value_int(get_arg(aw, argn, INT, FALSE));
X goto integer;
X
X /* integer */
X case 'i':
X arg.i = value_int(get_arg(aw, argn, INT, FALSE));
X goto integer;
X
X integer:
X PRINTF(arg.i);
X break;
X
X /* long integer */
X case 'l':
X arg.l = (long)value_int(get_arg(aw, argn, INT, FALSE));
X PRINTF(arg.l);
X break;
X }
X return (1);
X}
X/*
X * Convert integer to Roman Numerals. (How have you survived without it?)
X * [That's a very good question, Chris..]
X */
Local char *ctor(x, caps)
int x, caps;
X{
X Local char buf[BUFSIZ];
X register char *outp = buf;
X register unsigned n = x;
X register int u, v;
X register char *p, *q;
X
X if ((int)n < 0) {
X *(outp++) = '-';
X n = -n;
X }
X p = caps ? "M\2D\5C\2L\5X\2V\5I" : "m\2d\5c\2l\5x\2v\5i";
X v = 1000;
X if (n >= v * BUFSIZ / 2) /* conservative */
X return ("[abortive Roman numeral]");
X for (;;) {
X while (n >= v)
X *(outp++) = *p, n -= v;
X if (n == 0)
X break;
X q = p + 1;
X u = v / *q;
X if (*q == 2) /* magic */
X u /= *(q += 2);
X if (n + u >= v) {
X *(outp++) = *(++q);
X n += u;
X } else {
X p++;
X v /= *(p++);
X }
X }
X *outp = 0;
X return (buf);
X}
X
X/* For get() and input() */
Local Value get_value(aw, arg)
AwlWidget aw;
Value arg;
X{
X register char ch;
X String inbuf = NULL;
X int i = 0, max = 0;
X Value ret;
X Import Boolean isValidDigit();
X#ifndef toupper
X Import char toupper();
X#endif
X
X switch (value_int(arg)) {
X case ANY:
X while ((ch = fgetc(awl_in(aw))) != EOF && ch != awl_sep(aw)[0])
X append_string(&inbuf, &max, i++, ch);
X append_string(&inbuf, &max, i, '\0');
X if (isValidDigit(aw, *inbuf, ANY)) {
X if (index(inbuf, '.'))
X value_set(ret, DATA, FLOAT, float, atof(inbuf));
X else
X value_set(ret, DATA, INT, int, atonum(aw, inbuf, 0));
X XtFree(inbuf);
X }
X else {
X if (i || ch == awl_sep(aw)[0])
X value_set(ret, DATA, STRING, aobj, new_aobj(inbuf));
X else {
X value_set(ret, DATA, INT, int, 0);
X XtFree(inbuf);
X }
X }
X break;
X
X case INT:
X while ((ch = fgetc(awl_in(aw))) != EOF) {
X if (isspace(ch) && !i)
X continue;
X else if (isValidDigit(aw, ch, INT))
X append_string(&inbuf, &max, i++, ch);
X else if (ch == '.')
X exec_warn(aw, "decimal point ignored for INT get/input");
X else
X break;
X }
X append_string(&inbuf, &max, i, '\0');
X value_set(ret, DATA, INT, int, atonum(aw, inbuf, 0));
X XtFree(inbuf);
X break;
X
X case CHAR:
X value_set(ret, DATA, CHAR, char, fgetc(awl_in(aw)));
X break;
X
X case FLOAT:
X while ((ch = fgetc(awl_in(aw))) != EOF) {
X if (isspace(ch) && !i)
X continue;
X else if (isValidDigit(aw, ch, FLOAT))
X append_string(&inbuf, &max, i++, ch);
X else
X break;
X }
X append_string(&inbuf, &max, i, '\0');
X value_set(ret, DATA, FLOAT, float, atof(inbuf));
X XtFree(inbuf);
X break;
X
X case STRING:
X while ((ch = fgetc(awl_in(aw))) != EOF && ch != awl_sep(aw)[0])
X append_string(&inbuf, &max, i++, ch);
X append_string(&inbuf, &max, i, '\0');
X if (i || ch == awl_sep(aw)[0])
X value_set(ret, DATA, STRING, aobj, new_aobj(inbuf));
X else {
X value_set(ret, DATA, INT, int, 0);
X XtFree(inbuf);
X }
X break;
X
X default:
X exec_error(aw, "Illegal type '%s' for get/input", value_string(arg));
X break;
X }
X return(ret);
X}
X
X/* For print()/println()/input() */
Local int print_value(aw, arg)
AwlWidget aw;
Value arg;
X{
X String tmp;
X int ret = 0;
X
X if (value_type(arg) == LIST) {
X String *v = value_list(arg);
X
X if (!v)
X fprintf(awl_out(aw), "(null list)");
X else while (*v) {
X ret += (strlen(*v) + 1);
X fprintf(awl_out(aw), "%s", *(v++));
X fputs(awl_sep(aw), awl_out(aw));
X }
X }
X else {
X tmp = value_string_value(aw, arg);
X ret += strlen(tmp);
X fprintf(awl_out(aw), "%s", tmp);
X }
X return(ret);
X}
END_OF_FILE
if test 35683 -ne `wc -c <'sysrtns.c'`; then
echo shar: \"'sysrtns.c'\" unpacked with wrong size!
fi
# end of 'sysrtns.c'
fi
echo shar: End of archive 11 \(of 17\).
cp /dev/null ark11isdone
MISSING=""
for I in 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 ; do
if test ! -f ark${I}isdone ; then
MISSING="${MISSING} ${I}"
fi
done
if test "${MISSING}" = "" ; then
echo You have unpacked all 17 archives.
rm -f ark[1-9]isdone ark[1-9][0-9]isdone
else
echo You still need to unpack the following archives:
echo " " ${MISSING}
fi
## End of shell archive.
exit 0
dan
----------------------------------------------------
O'Reilly && Associates argv@sun.com / argv@ora.com
Opinions expressed reflect those of the author only.