Logo Search packages:      
Sourcecode: scheme9 version File versions

unix.c

#define EXTERN
#include "s9.h"
#undef EXTERN

#include <unistd.h>
#include <errno.h>
#include <stdlib.h>
#include <stdio.h>
#include <sys/types.h>
#include <sys/time.h>
#include <sys/stat.h>
#include <sys/param.h>
#include <pwd.h>
#include <grp.h>
#include <dirent.h>
#include <time.h>

/*
 *    Allow us at least to write
 *          assign(assign(car(x) = alloc(foo, bar)));
 *    in presence of that fact that C's
 *    order of evaluation messes up
 *          car(x) = alloc(foo, bar);
 */
cell  New_node;
#define assign(n,v)     { New_node = v; n = New_node; }

cell  Last_errno = 0;

cell unix_error(char *who, int what, cell args) {
      Last_errno = what;
      return FALSE;
}

cell pp_unix_chdir(cell x) {
      if (chdir(string(cadr(x))) < 0)
            return unix_error("chdir", errno, x);
      return TRUE;
}

cell pp_unix_chmod(cell x) {
      int   r;

      r = chmod(string(cadr(x)), integer_value("unix:chmod", caddr(x)));
      if (r < 0) return unix_error("chown", errno, x);
      return TRUE;
}

cell pp_unix_chown(cell x) {
      int   r;

      r = chown(string(cadr(x)),
            integer_value("unix:chown", caddr(x)),
            integer_value("unix:chown", cadddr(x)));
      if (r < 0) return unix_error("chown", errno, x);
      return TRUE;
}

cell pp_unix_command_line(cell x) {
      cell  n, a;
      char  **cl;

      if (Command_line == NULL || *Command_line == NULL)
            return NIL;
      n = alloc(NIL, NIL);
      a = n;
      save(n);
      cl = Command_line;
      while (*cl != NULL) {
            assign(car(a), make_string(*cl, strlen(*cl)));
            cl++;
            if (*cl != NULL) {
                  assign(cdr(a), alloc(NIL, NIL));
                  a = cdr(a);
            }
      }
      unsave(1);
      return n;
}

cell pp_unix_errno(cell x) {
      return make_integer(Last_errno);
}

cell pp_unix_exit(cell x) {
      int   r;

      r = integer_value("unix:exit", cadr(x));
      if (r > 255 || r < 0)
            return error("unix:exit: value out of range", cadr(x));
      exit(r);
      fatal("exit() failed");
      return UNSPECIFIC;
}

cell pp_unix_flush(cell x) {
      if (fflush(Ports[port_no(cadr(x))]))
            return FALSE;
      return TRUE;
}

cell pp_unix_getcwd(cell x) {
      char  *s;
      cell  n;

      s = getcwd(NULL, 1024);
      n = make_string(s, strlen(s));
      free(s);
      return n;
}

cell pp_unix_getenv(cell x) {
      char  *s;

      s = getenv(string(cadr(x)));
      if (s == NULL) return FALSE;
      return make_string(s, strlen(s));
}

cell pp_unix_getgid(cell x) {
      return make_integer(getgid());
}

cell mkgrent(struct group *gr) {
      cell  n, a;

      n = alloc(NIL, NIL);
      save(n);
      assign(car(n), alloc(add_symbol("name"), NIL));
      cdar(n) = make_string(gr->gr_name, strlen(gr->gr_name));
      a = alloc(NIL, NIL);
      cdr(n) = a;
      assign(car(a), alloc(add_symbol("gid"), NIL));
      cdar(a) = make_integer(gr->gr_gid);
      unsave(1);
      return n;
}

cell pp_unix_getgrnam(cell x) {
      struct group      *gr;

      gr = getgrnam(string(cadr(x)));
      if (gr == NULL) return FALSE;
      return mkgrent(gr);
}

cell pp_unix_getgrgid(cell x) {
      struct group      *gr;

      gr = getgrgid(integer_value("unix:getgrgid", cadr(x)));
      if (gr == NULL) return FALSE;
      return mkgrent(gr);
}

cell pp_unix_getpwent(cell x) {
      struct passwd     *pw;
      cell        n, a, pa;

      setpwent();
      n = alloc(NIL, NIL);
      save(n);
      a = n;
      pa = n;
      while (1) {
            pw = getpwent();
            if (pw == NULL) break;
            pa = a;
            assign(car(a), make_string(pw->pw_name, strlen(pw->pw_name)));
            if (pw != NULL) {
                  assign(cdr(a), alloc(NIL, NIL));
                  a = cdr(a);
            }
      }
      cdr(pa) = NIL;
      endpwent();
      unsave(1);
      return n;
}

cell mkpwent(struct passwd *pw) {
      cell  n, a;

      n = alloc(NIL, NIL);
      save(n);
      assign(car(n), alloc(add_symbol("name"), NIL));
      cdar(n) = make_string(pw->pw_name, strlen(pw->pw_name));
      a = alloc(NIL, NIL);
      cdr(n) = a;
      assign(car(a), alloc(add_symbol("uid"), NIL));
      cdar(a) = make_integer(pw->pw_uid);
      assign(cdr(a), alloc(NIL, NIL));
      a = cdr(a);
      assign(car(a), alloc(add_symbol("gid"), NIL));
      cdar(a) = make_integer(pw->pw_gid);
      assign(cdr(a), alloc(NIL, NIL));
      a = cdr(a);
      assign(car(a), alloc(add_symbol("gecos"), NIL));
      cdar(a) = make_string(pw->pw_gecos, strlen(pw->pw_gecos));
      assign(cdr(a), alloc(NIL, NIL));
      a = cdr(a);
      assign(car(a), alloc(add_symbol("home"), NIL));
      cdar(a) = make_string(pw->pw_dir, strlen(pw->pw_dir));
      assign(cdr(a), alloc(NIL, NIL));
      a = cdr(a);
      assign(car(a), alloc(add_symbol("shell"), NIL));
      cdar(a) = make_string(pw->pw_shell, strlen(pw->pw_shell));
      unsave(1);
      return n;
}

cell pp_unix_getpwnam(cell x) {
      struct passwd     *pw;

      pw = getpwnam(string(cadr(x)));
      if (pw == NULL) return FALSE;
      return mkpwent(pw);
}

cell pp_unix_getpwuid(cell x) {
      struct passwd     *pw;

      pw = getpwuid(integer_value("unix:getpwuid", cadr(x)));
      if (pw == NULL) return FALSE;
      return mkpwent(pw);
}

cell pp_unix_getuid(cell x) {
      return make_integer(getuid());
}

cell pp_unix_link(cell x) {
      if (link(string(cadr(x)), string(caddr(x))) < 0)
            return unix_error("link", errno, x);
      return TRUE;
}

cell pp_unix_lock(cell x) {
      char  p[256], *s;

      s = string(cadr(x));
      if (strlen(s) > 248)
            return error("unix:lock: path too long", cadr(x));
      sprintf(p, "%s.lock", s);
      return (mkdir(p, 0700) < 0)? FALSE: TRUE;
}

cell pp_unix_mkdir(cell x) {
      if (mkdir(string(cadr(x)), 0755) < 0)
            return unix_error("mkdir", errno, x);
      return TRUE;
}

cell pp_unix_readdir(cell x) {
      DIR         *dir;
      struct dirent     *dp;
      cell        n, a, pa;

      dir = opendir(string(cadr(x)));
      if (dir == NULL) return FALSE;
      n = alloc(NIL, NIL);
      save(n);
      a = n;
      pa = n;
      while (1) {
            dp = readdir(dir);
            if (dp == NULL) break;
            pa = a;
            assign(car(a), make_string(dp->d_name, strlen(dp->d_name)));
            if (dp != NULL) {
                  assign(cdr(a), alloc(NIL, NIL));
                  a = cdr(a);
            }
      }
      cdr(pa) = NIL;
      closedir(dir);
      unsave(1);
      return n;
}

cell pp_unix_readlink(cell x) {
      char  buf[MAXPATHLEN+1];
      int   k;

      k = readlink(string(cadr(x)), buf, MAXPATHLEN);
      if (k < 0) return unix_error("readlink", errno, x);
      return make_string(buf, k);
}

cell pp_unix_rmdir(cell x) {
      if (rmdir(string(cadr(x))) < 0)
            return unix_error("rmdir", errno, x);
      return TRUE;
}

cell pp_unix_spawn(cell x) {
      int   r;
      cell  n;
      int   to_child[2], from_child[2];
      int   in_port, out_port;

      in_port = alloc_port();
      if (in_port < 0) return error("spawn: out of ports", NOEXPR);
      Port_flags[in_port] |= LOCK_TAG;
      Ports[in_port] = (FILE*)1;
      out_port = alloc_port();
      if (out_port < 0) {
            Ports[in_port] = NULL;
            Port_flags[in_port] = 0;
            return error("spawn: out of ports", NOEXPR);
      }
      Port_flags[out_port] |= LOCK_TAG;
      Ports[out_port] = (FILE*)1;
      if (pipe(from_child) < 0) {
            Port_flags[in_port] = 0;
            Port_flags[out_port] = 0;
            Ports[in_port] = NULL;
            Ports[out_port] = NULL;
            error("spawn: pipe() returned", make_integer(errno));
      }
      if (pipe(to_child) < 0) {
            r = errno;
            Port_flags[in_port] = 0;
            Port_flags[out_port] = 0;
            Ports[in_port] = NULL;
            Ports[out_port] = NULL;
            close(from_child[0]);
            close(from_child[1]);
            error("spawn: pipe() returned", make_integer(r));
      }
      r = fork();
      if (r < 0) {
            r = errno;
            Port_flags[in_port] = 0;
            Port_flags[out_port] = 0;
            Ports[in_port] = NULL;
            Ports[out_port] = NULL;
            close(from_child[0]);
            close(from_child[1]);
            close(to_child[0]);
            close(to_child[1]);
            error("spawn: fork() returned", make_integer(r));
      }
      if (r == 0) {
            close(from_child[0]);
            close(to_child[1]);
            dup2(from_child[1], 1);
            dup2(to_child[0], 0);
            execl("/bin/sh", "/bin/sh", "-c", string(cadr(x)), NULL);
            exit(1);
      }
      close(from_child[1]);
      close(to_child[0]);
      Ports[in_port] = fdopen(from_child[0], "r");
      Ports[out_port] = fdopen(to_child[1], "w");
      n = alloc(NIL, NIL);
      save(n);
      assign(car(n), make_port(in_port, T_INPUT_PORT));
      assign(cdr(n), alloc(NIL, NIL));
      cadr(n) = make_port(out_port, T_OUTPUT_PORT);
      unsave(1);
      Port_flags[in_port] &= ~LOCK_TAG;
      Port_flags[out_port] &= ~LOCK_TAG;
      return n;
}

cell pp_unix_stat(cell x) {
      struct stat sb;
      cell        n, a;

      if (stat(string(cadr(x)), &sb) < 0) return FALSE;
      n = alloc(NIL, NIL);
      save(n);
      assign(car(n), alloc(add_symbol("name"), cadr(x)));
      a = alloc(NIL, NIL);
      cdr(n) = a;
      assign(car(a), alloc(add_symbol("size"), NIL));
      cdar(a) = make_integer(sb.st_size);
      assign(cdr(a), alloc(NIL, NIL));
      a = cdr(a);
      assign(car(a), alloc(add_symbol("uid"), NIL));
      cdar(a) = make_integer(sb.st_uid);
      assign(cdr(a), alloc(NIL, NIL));
      a = cdr(a);
      assign(car(a), alloc(add_symbol("gid"), NIL));
      cdar(a) = make_integer(sb.st_gid);
      assign(cdr(a), alloc(NIL, NIL));
      a = cdr(a);
      assign(car(a), alloc(add_symbol("mode"), NIL));
      cdar(a) = make_integer(sb.st_mode);
      assign(cdr(a), alloc(NIL, NIL));
      a = cdr(a);
      assign(car(a), alloc(add_symbol("ctime"), NIL));
      cdar(a) = make_integer(sb.st_ctime);
      assign(cdr(a), alloc(NIL, NIL));
      a = cdr(a);
      assign(car(a), alloc(add_symbol("atime"), NIL));
      cdar(a) = make_integer(sb.st_atime);
      assign(cdr(a), alloc(NIL, NIL));
      a = cdr(a);
      assign(car(a), alloc(add_symbol("mtime"), NIL));
      cdar(a) = make_integer(sb.st_mtime);
      assign(cdr(a), alloc(NIL, NIL));
      a = cdr(a);
      assign(car(a), alloc(add_symbol("dev"), NIL));
      cdar(a) = make_integer(sb.st_dev);
      assign(cdr(a), alloc(NIL, NIL));
      a = cdr(a);
      assign(car(a), alloc(add_symbol("ino"), NIL));
      cdar(a) = make_integer(sb.st_ino);
      assign(cdr(a), alloc(NIL, NIL));
      a = cdr(a);
      assign(car(a), alloc(add_symbol("nlink"), NIL));
      cdar(a) = make_integer(sb.st_nlink);
      unsave(1);
      return n;
}

cell pp_unix_symlink(cell x) {
      if (symlink(string(cadr(x)), string(caddr(x))) < 0)
            return unix_error("symlink", errno, x);
      return TRUE;
}

cell pp_unix_system(cell x) {
      return system(string(cadr(x))) == 0? TRUE: FALSE;
}

cell pp_unix_time(cell x) {
      time_t      t;

      time(&t);
      return make_integer(t);
}

cell pp_unix_unlink(cell x) {
      if (unlink(string(cadr(x))) < 0)
            return unix_error("unlink", errno, x);
      return TRUE;
}

cell pp_unix_unlock(cell x) {
      char  p[256], *s;

      s = string(cadr(x));
      if (strlen(s) > 248)
            return error("unix:unlock: path too long", cadr(x));
      sprintf(p, "%s.lock", s);
      rmdir(p);
      return UNSPECIFIC;
}

cell pp_unix_utimes(cell x) {
      if (utimes(string(cadr(x)), NULL) < 0)
            return unix_error("utimes", errno, x);
      return TRUE;
}

struct Primitive_procedure Unix_primitives[] = {
 { "unix:chdir",        pp_unix_chdir,        1,  1, { STR,___,___ } },
 { "unix:chmod",        pp_unix_chmod,        2,  2, { STR,INT,___ } },
 { "unix:chown",        pp_unix_chown,        3,  3, { STR,INT,INT } },
 { "unix:command-line", pp_unix_command_line, 0,  0, { ___,___,___ } },
 { "unix:errno",        pp_unix_errno,        0,  0, { ___,___,___ } },
 { "unix:exit",         pp_unix_exit,         1,  1, { INT,___,___ } },
 { "unix:flush",        pp_unix_flush,        1,  1, { OUP,___,___ } },
 { "unix:getcwd",       pp_unix_getcwd,       0,  0, { ___,___,___ } },
 { "unix:getenv",       pp_unix_getenv,       1,  1, { STR,___,___ } },
 { "unix:getgid",       pp_unix_getgid,       0,  0, { ___,___,___ } },
 { "unix:getgrnam",     pp_unix_getgrnam,     1,  1, { STR,___,___ } },
 { "unix:getgrgid",     pp_unix_getgrgid,     1,  1, { INT,___,___ } },
 { "unix:getpwent",     pp_unix_getpwent,     0,  0, { ___,___,___ } },
 { "unix:getpwnam",     pp_unix_getpwnam,     1,  1, { STR,___,___ } },
 { "unix:getpwuid",     pp_unix_getpwuid,     1,  1, { INT,___,___ } },
 { "unix:getuid",       pp_unix_getuid,       0,  0, { ___,___,___ } },
 { "unix:link",         pp_unix_link,         2,  2, { STR,STR,___ } },
 { "unix:lock",         pp_unix_lock,         1,  1, { STR,___,___ } },
 { "unix:mkdir",        pp_unix_mkdir,        1,  1, { STR,___,___ } },
 { "unix:readdir",      pp_unix_readdir,      1,  1, { STR,___,___ } },
 { "unix:readlink",     pp_unix_readlink,     1,  1, { STR,___,___ } },
 { "unix:rmdir",        pp_unix_rmdir,        1,  1, { STR,___,___ } },
 { "unix:spawn",        pp_unix_spawn,        1,  1, { STR,___,___ } },
 { "unix:stat",         pp_unix_stat,         1,  1, { STR,___,___ } },
 { "unix:symlink",      pp_unix_symlink,      2,  2, { STR,STR,___ } },
 { "unix:system",       pp_unix_system,       1,  1, { STR,___,___ } },
 { "unix:time",         pp_unix_time,         0,  0, { ___,___,___ } },
 { "unix:unlink",       pp_unix_unlink,       1,  1, { STR,___,___ } },
 { "unix:unlock",       pp_unix_unlock,       1,  1, { STR,___,___ } },
 { "unix:utimes",       pp_unix_utimes,       1,  1, { STR,___,___ } },
 { NULL }
};

void unix_init(void) {
      add_primitives("unix", Unix_primitives);
}

Generated by  Doxygen 1.6.0   Back to index