/* * * p o s i x . c -- Provide some POSIX.1 functions * * Copyright (C) 1993,1994,1995 Erick Gallesio - I3S-CNRS/ESSI * * * Permission to use, copy, and/or distribute this software and its * documentation for any purpose and without fee is hereby granted, provided * that both the above copyright notice and this permission notice appear in * all copies and derived works. Fees for distribution or use of this * software or derived works may only be charged with express written * permission of the copyright holder. * This software is provided ``as is'' without express or implied warranty. * * This software is a derivative work of other copyrighted softwares; the * copyright notices of these softwares are placed in the file COPYRIGHTS * * * Author: Erick Gallesio [eg@kaolin.unice.fr] * Creation date: 14-Mar-1995 20:14 * Last file update: 5-Jun-1995 16:12 */ #include #include #define DefineConst(c) {VCELL(STk_intern(#c)) = STk_makeinteger(c);} /****************************************************************************** * * Error management * ******************************************************************************/ extern int errno; static SCM get_errno(char *s) { return STk_makeinteger((long) errno); } static void set_errno(char *s, SCM value) { long n = STk_integer_value_no_overflow(value); if (n == LONG_MIN) Err("setting *errno*: bad integer", value); errno = n; } static PRIMITIVE posix_perror(SCM str) { if (NSTRINGP(str)) Err("posix-perror: bad string", str); perror(CHARS(str)); return UNDEFINED; } /****************************************************************************** * * File and Directory functions * ******************************************************************************/ #include static Cpointer_stat; static PRIMITIVE posix_stat(SCM filename) { struct stat *p; if (NSTRINGP(filename)) Err("posix-stat: bad string", filename); p = (struct stat *) must_malloc(sizeof(struct stat)); if (stat(CHARS(filename), p) == -1) return Ntruth; return STk_make_Cpointer(Cpointer_stat, (void *) p, FALSE); } static PRIMITIVE posix_stat2vector(SCM descr) { SCM z; struct stat *info; if (NCPOINTERP(descr) || EXTID(descr) != Cpointer_stat) Err("posix-stat2vector: bad structure ", descr); info = (struct stat *) EXTDATA(descr); z = STk_makevect(10, NULL); VECT(z)[0] = STk_makeinteger(info->st_dev); VECT(z)[1] = STk_makeinteger(info->st_ino); VECT(z)[2] = STk_makeinteger(info->st_mode); VECT(z)[3] = STk_makeinteger(info->st_nlink); VECT(z)[4] = STk_makeinteger(info->st_uid); VECT(z)[5] = STk_makeinteger(info->st_gid); VECT(z)[6] = STk_makeinteger(info->st_size); VECT(z)[7] = STk_makeinteger(info->st_atime); VECT(z)[8] = STk_makeinteger(info->st_mtime); VECT(z)[9] = STk_makeinteger(info->st_ctime); return z; } static PRIMITIVE posix_access(SCM filename, SCM mode) { long m; if (NSTRINGP(filename)) Err("posix-access: bad string", filename); if ((m=STk_integer_value_no_overflow(mode)) == LONG_MIN) Err("posix-access: bad integer", mode); return (access(CHARS(filename), (int) m) == 0) ? Truth: Ntruth; } static PRIMITIVE posix_pipe(void) { int fd[2]; SCM z0, z1; FILE *f0, *f1; if (pipe(fd) == -1) return Ntruth; if ((f0 = fdopen(fd[0], "r")) == NULL || (f1 = fdopen(fd[1], "w")) == NULL) { fclose(f0); fclose(f1); close(fd[0]); close(fd[1]); return Ntruth; } NEWCELL(z0, tc_iport); z0->storage_as.port.f = f0; z0->storage_as.port.name = "pipe (input)"; NEWCELL(z1, tc_oport); z1->storage_as.port.f = f1; z1->storage_as.port.name = "pipe (output)"; return Cons(z0, z1); } /****************************************************************************** * * Time functions * ******************************************************************************/ #include #ifdef SUNOS4 #define mktime(c) timegm(c) #endif static Cpointer_tm; static void display_Cpointer_tm(SCM obj, SCM port, int mode) { struct tm *p = (struct tm *) EXTDATA(obj); sprintf(STk_tkbuffer, "#", p->tm_mon, p->tm_mday, p->tm_year, p->tm_hour, p->tm_min, p->tm_sec); Puts(STk_tkbuffer, port->storage_as.port.f); } static PRIMITIVE posix_time(void) { return STk_makeinteger((long) time(NULL)); } static PRIMITIVE posix_ctime(SCM seconds) { long sec; sec = (seconds == UNBOUND) ? time(NULL) : STk_integer_value_no_overflow(seconds); if (sec == LONG_MIN) Err("posix-ctime: bad time value", seconds); return STk_makestring(ctime((time_t *) &sec)); } static PRIMITIVE posix_localtime(SCM timer) { long t = STk_integer_value_no_overflow(timer); if (t == LONG_MIN) Err("posix-localtime: bad time value", timer); return STk_make_Cpointer(Cpointer_tm, (void *) localtime((time_t *) &t), TRUE); } static PRIMITIVE posix_gmtime(SCM timer) { long t = STk_integer_value_no_overflow(timer); if (t == LONG_MIN) Err("posix-gmtime: bad time value", timer); return STk_make_Cpointer(Cpointer_tm, (void *) gmtime((time_t *) &t), TRUE); } static PRIMITIVE posix_mktime(SCM t) { time_t sec; if (NCPOINTERP(t) || EXTID(t) != Cpointer_tm) Err("posix-mktime: bad time structure", t); sec = (time_t) mktime(EXTDATA(t)); return STk_makeinteger((double) sec); } static PRIMITIVE posix_tm2vector(SCM t) { SCM z; struct tm *p; if (NCPOINTERP(t) || EXTID(t) != Cpointer_tm) Err("posix-tm->vector: bad time structure", t); z = STk_makevect(9, NIL); p = (struct tm *) EXTDATA(t); VECT(z)[0] = STk_makeinteger(p->tm_sec); VECT(z)[1] = STk_makeinteger(p->tm_min); VECT(z)[2] = STk_makeinteger(p->tm_hour); VECT(z)[3] = STk_makeinteger(p->tm_mday); VECT(z)[4] = STk_makeinteger(p->tm_mon); VECT(z)[5] = STk_makeinteger(p->tm_year); VECT(z)[6] = STk_makeinteger(p->tm_wday); VECT(z)[7] = STk_makeinteger(p->tm_yday); VECT(z)[8] = (p->tm_isdst) ? Truth: Ntruth; return z; } static PRIMITIVE vector2posix_tm(SCM v) { struct tm *p; if (NVECTORP(v) || VECTSIZE(v) != 9) Err("vector->posix-tm: bad vector", v); p = (struct tm *) malloc(sizeof(struct tm)); p->tm_sec = STk_integer_value_no_overflow(VECT(v)[0]); p->tm_min = STk_integer_value_no_overflow(VECT(v)[1]); p->tm_hour = STk_integer_value_no_overflow(VECT(v)[2]); p->tm_mday = STk_integer_value_no_overflow(VECT(v)[3]); p->tm_mon = STk_integer_value_no_overflow(VECT(v)[4]); p->tm_year = STk_integer_value_no_overflow(VECT(v)[5]); p->tm_wday = STk_integer_value_no_overflow(VECT(v)[6]); p->tm_yday = STk_integer_value_no_overflow(VECT(v)[7]); p->tm_isdst = (VECT(v)[8] == Truth); return STk_make_Cpointer(Cpointer_tm, p, FALSE); } static PRIMITIVE posix_strftime(SCM format, SCM t) { char buffer[1024]; struct tm *p; int len; if (NSTRINGP(format)) Err("posix-strftime: Bad string", format); /* If t is not provided, assume that we want current localtime */ if (t == UNBOUND) { time_t t = time(NULL); p = localtime(&t); } else { if (NCPOINTERP(t) || EXTID(t) != Cpointer_tm) Err("posix-strftime: bad time structure", t); p = EXTDATA(t); } if (len=strftime(buffer, 1023, CHARS(format), p)) return STk_makestring(buffer); else Err("posix-strftime: buffer too short", NIL); } /****************************************************************************** * * Processes stuff * ******************************************************************************/ static PRIMITIVE posix_fork(void) { pid_t pid = fork(); #ifdef USE_TK /* Really silly. Try to do something better */ if (pid == 0 && Tk_initialized) { /* Delete all the Tk commands associated to the interpreter (except send) * to avoid interpreter unregistering */ struct Tk_command *W; Interp *iPtr = (Interp *) STk_main_interp; Tcl_HashEntry *hPtr; /* Try to find "send". Modify it's delproc to point NULL */ hPtr = Tcl_FindHashEntry(&iPtr->commandTable, "send"); if (hPtr != NULL) { W = (struct Tk_command *) Tcl_GetHashValue(hPtr); W->delproc = NULL; } /* Now we can destroy the interpreter (send will not be destroyed) */ Tcl_DeleteInterp(STk_main_interp); /* Report-error points to a graphical procedure. Undefine it * to display error messages on stderr in the child process */ STk_set_symbol_value("report-error", UNBOUND); /* Redefine exit to the standard STk exit function */ STk_add_new_primitive("exit", tc_subr_0_or_1, STk_quit_interpreter); } #endif return (pid == -1) ? Ntruth: STk_makeinteger((long) pid); } static PRIMITIVE posix_wait(void) { pid_t pid; int status; pid = wait(&status); if (pid == -1) return Ntruth; else return Cons(STk_makeinteger((long) pid), STk_makeinteger((long) status)); } /****************************************************************************** * * Initialization code * ******************************************************************************/ PRIMITIVE STk_init_posix(void) { /* Error management */ STk_define_C_variable("*errno*", get_errno, set_errno); STk_add_new_primitive("posix-perror", tc_subr_1, posix_perror); /* File and directories */ Cpointer_stat = STk_new_Cpointer_id(NULL); STk_add_new_primitive("posix-stat", tc_subr_1, posix_stat); STk_add_new_primitive("posix-stat->vector", tc_subr_1, posix_stat2vector); STk_add_new_primitive("posix-access", tc_subr_2, posix_access); STk_add_new_primitive("posix-pipe", tc_subr_0, posix_pipe); #ifdef X0000 DefineConst(S_IRUSR); DefineConst(S_IWUSR); DefineConst(S_IXUSR); DefineConst(S_IRGRP); DefineConst(S_IWGRP); DefineConst(S_IXGRP); DefineConst(S_IROTH); DefineConst(S_IWOTH); DefineConst(S_IXOTH); DefineConst(S_IRWXU); DefineConst(S_IRWXG); DefineConst(S_IRWXO); #endif DefineConst(F_OK); DefineConst(R_OK); DefineConst(W_OK); /* Time */ Cpointer_tm = STk_new_Cpointer_id(display_Cpointer_tm); STk_add_new_primitive("posix-time", tc_subr_0, posix_time); STk_add_new_primitive("posix-ctime", tc_subr_0_or_1, posix_ctime); STk_add_new_primitive("posix-localtime", tc_subr_1, posix_localtime); STk_add_new_primitive("posix-gmtime", tc_subr_1, posix_gmtime); STk_add_new_primitive("posix-mktime", tc_subr_1, posix_mktime); STk_add_new_primitive("posix-tm->vector", tc_subr_1, posix_tm2vector); STk_add_new_primitive("vector->posix-tm", tc_subr_1, vector2posix_tm); STk_add_new_primitive("posix-strftime", tc_subr_1_or_2, posix_strftime); /* Processes */ STk_add_new_primitive("posix-fork", tc_subr_0, posix_fork); STk_add_new_primitive("posix-wait", tc_subr_0, posix_wait); return UNDEFINED; }