.ref-BSD-4_3_Net_2/usr/src/usr.bin/lisp/franz/lam9.c

#ifndef lint
static char *rcsid =
   "$Header: lam9.c,v 1.7 85/03/13 17:19:15 sklower Exp $";
#endif

/*                                      -[Sat Oct  1 19:44:47 1983 by jkf]-
 *      lam9.c                          $Locker:  $
 * lambda functions
 *
 * (c) copyright 1982, Regents of the University of California
 */

#include "global.h"
/*
 * These routines writen in C will allow use of the termcap file
 * by any lisp program. They are very basic routines which initialize
 * termcap and allow the lisp to execute any of the termcap functions.
 */

#include <stdio.h>              /*add definations for I/O and bandrate */
#include <sgtty.h>
#include <sys/types.h>
#include <sys/stat.h>
#include <pwd.h>


#undef putchar
int     putchar();              /* functions used from the termlib */
int     tgetflag();
char    *getenv();
char    *tgoto();
char    *tgetstr();

char    bpbuf[1024];
char    tstrbuf[100];
extern short    ospeed;
extern char     PC;
extern char   *BC;
extern char   *UP;

/*
/*      This routine will initialize the termcap for the lisp programs.
/*      If the termcap file is not found, or terminal type is undefined,
/*      it will print out an error mesg.                                */

lispval
Ltci()
{
char *cp = getenv("TERM");
char *pc;
int found;
struct sgttyb tty;

found = tgetent(bpbuf,cp);              /* open ther termcap file */
switch(found) {
      case -1:  printf("\nError Termcap File not found \n");break;
      case 0 :  printf("\nError No Termcap Entry for this terminal \n");
                break;
      case 1 : {                        /* everything was ok    */
                gtty(1, &tty);
                ospeed = tty.sg_ospeed;
                }
                break;
        }
cp = tstrbuf;
BC = tgetstr("bc", &cp);
UP = tgetstr("up", &cp);
pc = tgetstr("pc", &cp);
if (pc)
    PC = *pc;
return(nil);
}
/* This routine will execute any of the termcap functions used by the lisp
/* program. If the feature is not include in the terminal defined it will
/* ignore the call.
/*              option  : feature to execute
/*              line    : line if is nessery
/*              colum   : colum if is nessaery
/*                                                                      */
lispval
Ltcx()
{
        register struct argent *mylbot = lbot;
        int line, column;

        switch(np-lbot) {
        case 1:
                line = column = 0;
                break;
        case 2:
                error("Wrong number of Arguments to Termcapexecute",FALSE);
                break;
        case 3:
                line = mylbot[1].val->i;
                column = mylbot[2].val->i;
        }
        return(inewint(show((char *) mylbot->val,&line,&column)));
}


static
show(option,line,colum)
char *option;
int  *line,*colum;
{
int found;
char clbuf[20];
char *clbp = clbuf;
char *clear;

/* the tegetflag doesnot work ? */
clear = tgetstr(option,&clbp);
/*printf("option = %d , %s \n",clear,option);*/
if (!clear)
        {found = tgetnum(option);
         if (found)
                return(found);
          return(-1);
       }
PC = ' ';
if (strcmp(option, "cm") == 0) {                /* if cursor motion, do it */
        clear=tgoto(clear,*colum,*line);
        if (*clear == 'O')
                clear = 0;
        }
if (clear)                                      /* execute the feature */
     tputs(clear,0,putchar);
return (0);
}


/*
 * LIfranzcall :: lisp function int:franz-call
 *   this function serves many purposes.  It provides access to
 *   those things that are best done in C or which required a
 *   C access to unix system calls.
 *
 *   Calls to this routine are not error checked, for the most part
 *   because this is only called from trusted lisp code.
 *
 *   The functions in this file may or may not be documented in the manual.
 *   See the lisp interface to this function for more details. (common2.l)
 *
 *  the first argument is always a fixnum index, the other arguments
 *   depend on the function.
 */

#define fc_getpwnam 1
#define fc_access   2
#define fc_chdir    3
#define fc_unlink   4
#define fc_time     5
#define fc_chmod    6
#define fc_getpid   7
#define fc_stat     8
#define fc_gethostname 9
#define fc_link     10
#define fc_sleep    11
#define fc_nice     12

lispval
LIfranzcall()
{
    register lispval handy;

    if((np-lbot) <= 0) argerr("int:franz-call");

    switch (lbot[0].val->i) {

    case fc_getpwnam:
        /* arg 1 = user name
         * return vector of name, uid, gid, dir
         * or nil if doesn't exist.
         */
         {
             struct passwd *pw, *getpwnam();
             lispval newvec(), inewint();
             struct argent *oldnp;

             pw = getpwnam(verify(lbot[1].val,"int:franz-call: invalid name"));
             if(pw)
             {
                 handy =  newvec(4 * sizeof(long));
                 oldnp = np;
                 protect(handy);
                 handy->v.vector[0] = (lispval) inewstr(pw->pw_name);
                 handy->v.vector[1] = inewint(pw->pw_uid);
                 handy->v.vector[2] = inewint(pw->pw_gid);
                 handy->v.vector[3] = (lispval) inewstr(pw->pw_dir);
                 np = oldnp;
                 return(handy);
             }
             return(nil);
         }
         case fc_access:
                return(inewint
                        (access
                           (verify(lbot[1].val, "i:fc,access: non string"),
                            lbot[2].val->i)));
         case fc_chdir:
                return(inewint
                       (chdir(verify(lbot[1].val,"i:fc,chdir: non string"))));

         case fc_unlink:
                return(inewint
                       (unlink(verify(lbot[1].val,"i:fc,unlink: non string"))));

         case fc_time:
                return(inewint(time(0)));

         case fc_chmod:
                return(inewint(chmod(verify(lbot[1].val,
                                                "i:fc,chmod: non string"),
                                     lbot[2].val->i)));

         case fc_getpid:
                return(inewint(getpid()));

         case fc_stat:
                {
                    struct argent *oldnp;
                    struct stat statbuf;

                    if(stat(verify(lbot[1].val,"ifc:stat bad file name "),
                            &statbuf)
                        != 0) return(nil);      /* nil on error */
                    handy = newvec(12 * sizeof(long));
                    oldnp = np;
                    protect(handy);
                    handy->v.vector[0] = inewint(statbuf.st_mode & 07777);
                    handy->v.vector[1] = inewint(
                                           (statbuf.st_mode & S_IFMT) >> 12 );
                    handy->v.vector[2] = inewint(statbuf.st_nlink);
                    handy->v.vector[3] = inewint(statbuf.st_uid);
                    handy->v.vector[4] = inewint(statbuf.st_gid);
                    handy->v.vector[5] = inewint(statbuf.st_size);
                    handy->v.vector[6] = inewint(statbuf.st_atime);
                    handy->v.vector[7] = inewint(statbuf.st_mtime);
                    handy->v.vector[8] = inewint(statbuf.st_ctime);
                    handy->v.vector[9] = inewint(statbuf.st_dev);
                    handy->v.vector[10] = inewint(statbuf.st_rdev);
                    handy->v.vector[11] = inewint(statbuf.st_ino);
                    np = oldnp;
                    return(handy);
                }
         case fc_gethostname:
            {
#if os_4_1a || os_4_1c || os_4_2 || os_4_3
                char hostname[32];
                gethostname(hostname,sizeof(hostname));
                return((lispval) inewstr(hostname));
#else
                return((lispval) inewstr(SITE));
#endif
            }
         case fc_link:
            return(inewint
                    (link(verify(lbot[1].val,"i:fc,link: non string"),
                          verify(lbot[2].val,"i:fc,link: non string"))));

         /* sleep for the given number of seconds */
         case fc_sleep:
            return(inewint(sleep(lbot[1].val->i)));

         case fc_nice:
            return(inewint(nice(lbot[1].val->i)));

         default:
                return(inewint(-1));
        } /* end of switch */
}