conservatory
/
stk
4
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity
stk/Extensions/posix.c

395 lines
11 KiB
C
Raw Blame History

/*
*
* p o s i x . c -- Provide some POSIX.1 functions
*
* Copyright © 1993-1996 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
*
*
* 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: 25-Sep-1996 14:36
*/
#include <stk.h>
#include <sys/types.h>
#include <sys/utsname.h>
#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 <sys/stat.h>
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-stat->vector: 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];
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;
}
return Cons(STk_Cfile2port("pipe (input)", f0, tc_iport, 0),
STk_Cfile2port("pipe (output)", f1, tc_oport, 0));
}
/******************************************************************************
*
* Time functions
*
******************************************************************************/
#include <time.h>
#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, "#<C-struct tm %02d/%02d/%02d %02d:%02d:%02d>",
p->tm_mon, p->tm_mday, p->tm_year,
p->tm_hour, p->tm_min, p->tm_sec);
Puts(STk_tkbuffer, PORT_FILE(port));
}
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 *) must_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();
if (pid == 0) {
/* Child process must delete Tcl interpreter (if it exists) */
STk_delete_Tcl_child_Interp();
}
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));
}
/******************************************************************************
*
* System infos
* gethostname and getdomainname: POSIX.1 does not define these
* functions, but ISO/IEC 9945-1:1990 mentions them in B.4.4.1.
* -- Linux documentation
*
******************************************************************************/
static PRIMITIVE posix_uname(void)
{
struct utsname buff;
SCM v;
if (uname(&buff) == -1)
Err("posix-uname: cannot stat", NIL);
v = STk_makevect(5, NIL);
VECT(v)[0] = STk_makestring(buff.sysname);
VECT(v)[1] = STk_makestring(buff.nodename);
VECT(v)[2] = STk_makestring(buff.release);
VECT(v)[3] = STk_makestring(buff.version);
VECT(v)[4] = STk_makestring(buff.machine);
return v;
}
static PRIMITIVE posix_host_name(void)
{
char name[100];
if (gethostname(name, 100) != 0)
Err("posix-host-name: cannot determine name", NIL);
return STk_makestring(name);
}
static PRIMITIVE posix_domain_name(void)
{
char name[100];
if (getdomainname(name, 100) != 0)
Err("posix-domain-name: cannot determine domain", NIL);
return STk_makestring(name);
}
/******************************************************************************
*
* 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);
DefineConst(F_OK); DefineConst(R_OK); DefineConst(W_OK);
DefineConst(X_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);
/* System information */
STk_add_new_primitive("posix-uname", tc_subr_0, posix_uname);
STk_add_new_primitive("posix-host-name", tc_subr_0, posix_host_name);
STk_add_new_primitive("posix-domain-name",tc_subr_0, posix_domain_name);
return UNDEFINED;
}
Reference in New Issue View Git Blame Copy Permalink