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

736 lines
18 KiB
C
Raw Blame History

/*
*
* u n i x . c -- Some Unix primitives
*
* Copyright © 1993-1998 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: 29-Mar-1994 10:57
* Last file update: 17-Apr-1998 12:17
*/
#ifndef WIN32
# include <unistd.h>
# include <pwd.h>
#else
# include <io.h>
# define F_OK 00
# define X_OK 01
# define W_OK 02
# define R_OK 04
#endif
#include <sys/types.h>
#include <sys/stat.h>
#ifdef WIN32
/* One of above files includes <stdarg.h> with BC++ (and stdarg and
* vararg are not compatible
*/
# undef __STDARG_H
# ifdef MSC_VER
# include <direct.h>
# include <windows.h>
# define S_ISDIR(mode) ((mode&0xF0000) == 0x40000)
# define S_ISREG(mode) ((mode&0xF00000) == 0x100000)
# else
/* Borland defines the opendir/readdir/closedir functions. Use them. */
# include <dirent.h>
# endif
#else
# include <dirent.h>
#endif
#include "stk.h"
#ifdef SUNOS4
/* I avoid to use the POSIX getcwd since it is implemented using popen(3) and
* pwd(1) on SunOS 4.1.3 ==> It is VERY SLOW.
*/
#define getcwd my_getcwd
static char *my_getcwd(char *path, int size)
{
if (!path) path = (char *) must_malloc(size);
getwd(path);
return path;
}
#endif /* SUNOS4 */
/******************************************************************************
*
* Utilities
*
******************************************************************************/
/*
* TILDE-EXPAND -- expand '~' and '~user' string prefix
*
*/
static char *tilde_expand(char *name, char *result)
{
char *dir, *p;
#ifdef WIN32
strcpy(result, name);
return name;
#else
if (name[0] != '~') {
strcpy(result, name);
return name;
}
if ((name[1] == '/') || (name[1] == '\0')) {
dir = getenv("HOME");
if (dir == NULL)
Err("couldn't find HOME environment for expanding ", STk_makestring(name));
sprintf(result, "%s%s", dir, name+1);
}
else {
struct passwd *pwPtr;
register int len;
for (p=&name[1]; (*p != 0) && (*p != '/'); p++) {
/* Null body; just find end of name. */
}
len = p-(name+1);
strncpy(result, name+1, len);
result[len] = '\0';
pwPtr = getpwnam(result);
if (pwPtr == NULL) {
endpwent();
Err("User does not exist", STk_makestring(result));
}
sprintf(result, "%s%s", pwPtr->pw_dir, p);
endpwent();
}
return result;
#endif
}
/*
* ABSOLUTE -- Given a file name, return its (mostly clean) absolute path name
*
*/
static void absolute(char *s, char *pathname)
{
char *p = pathname;
char *t;
if (!ISABSOLUTE(s)) {
getcwd(pathname, MAX_PATH_LENGTH);
p = &pathname[strlen(pathname)]; /* place p at end of pathname */
}
*p = DIRSEP;
for ( ; *s; s++) {
t = s;
switch (*s) {
case '.' : if (*(s+1)) {
switch (*++s) {
case '.' : if (ISDIRSEP(*p) && (*(s+1)=='\0' ||
ISDIRSEP(*(s+1)))) {
/* We must go back to the parent */
if (ISDIRSEP(*p) && p > pathname) p --;
while (p > pathname && !ISDIRSEP(*p)) p--;
}
else {
/* There is a suit of dot. Copy it */
for (s = t; *s == '.'; s++) *++p = '.';
s -= 1;
}
break;
#ifdef WIN32
case '\\':
#endif
case '/' : if (!ISDIRSEP(*p)) {
*++p = '.';
*++p = DIRSEP;
}
break;
default : *++p = '.'; *++p = *s; break;
}
}
else { /* We have a final (single) dot */
if (!ISDIRSEP(*p)) *++p = '.';
}
break;
#ifdef WIN32
case '\\':
#endif
case '/' : if (!ISDIRSEP(*p)) *++p = DIRSEP; break;
default : *++p = *s;
}
}
/* Place a \0 at end. If path ends with a "/", delete it */
if (p == pathname || !ISDIRSEP(*p)) p++;
*p = '\0';
}
#define MAXLINK 50 /* Number max of link before declaring we have a loop */
SCM STk_resolve_link(char *path, int count)
{
#ifdef WIN32
return STk_internal_expand_file_name(path);
#else
char link[MAX_PATH_LENGTH], dst[MAX_PATH_LENGTH], *s, *d=dst;
int n;
SCM p;
p = STk_internal_expand_file_name(path);
for (s=CHARS(p)+1, *d++='/' ; ; s++, d++) {
switch (*s) {
case '\0':
case '/' : *d = '\0';
if ((n=readlink(dst, link, MAX_PATH_LENGTH-1)) > 0) {
link[n] = '\0';
if (link[0] == '/')
/* link is absolute */
d = dst;
else {
/* relative link. Delete last item */
while (*--d != '/') {
}
d += 1;
}
/* d points the place where the link must be placed */
if (d - dst + strlen(link) + strlen(s) < MAX_PATH_LENGTH - 1) {
/* we have enough room */
sprintf(d, "%s%s", link, s);
/* Recurse. Be careful for loops (a->b and b->a) */
if (count < MAXLINK)
return STk_resolve_link(dst, count+1);
}
return Ntruth;
}
else {
if (errno != EINVAL)
/* EINVAL = file is not a symlink (i.e. it's a true error) */
return Ntruth;
else
if (*s) *d = '/';
else return STk_makestring(dst);
}
default: *d = *s;
}
}
#endif
}
/*
*----------------------------------------------------------------------
*
* fileglob --
* ***** ******
* ***** This function is an adaptation of the Tcl function DoGlob ******
* ***** Adaptated to use true lists rather than string as in Tcl ******
* ***** ******
*
*
* This recursive procedure forms the heart of the globbing
* code. It performs a depth-first traversal of the tree
* given by the path name to be globbed.
*
* Results:
* The return value is a standard Tcl result indicating whether
* an error occurred in globbing. After a normal return the
* result in interp will be set to hold all of the file names
* given by the dir and rem arguments. After an error the
* result in interp will hold an error message.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static SCM fileglob(char *dir, char *rem, SCM result)
/* dir: Name of a directory at which to start glob expansion. This name
* is fixed: it doesn't contain any globbing chars.
* rem: Path to glob-expand.
*/
{
/*
* When this procedure is entered, the name to be globbed may
* already have been partly expanded by ancestor invocations of
* fileglob. The part that's already been expanded is in "dir"
* (this may initially be empty), and the part still to expand
* is in "rem". This procedure expands "rem" one level, making
* recursive calls to itself if there's still more stuff left
* in the remainder.
*/
Tcl_DString newName; /* Holds new name consisting of
* dir plus the first part of rem. */
register char *p;
register char c;
char *openBrace, *closeBrace, *name, *dirName;
int gotSpecial, baseLength;
struct stat statBuf;
/*
* Make sure that the directory part of the name really is a
* directory. If the directory name is "", use the name "."
* instead, because some UNIX systems don't treat "" like "."
* automatically. Keep the "" for use in generating file names,
* otherwise "glob foo.c" would return "./foo.c".
*/
dirName = (*dir == '\0') ? ".": dir;
if ((stat(dirName, &statBuf) != 0) || !S_ISDIR(statBuf.st_mode))
return result;
Tcl_DStringInit(&newName);
/*
* First, find the end of the next element in rem, checking
* along the way for special globbing characters.
*/
gotSpecial = 0;
openBrace = closeBrace = NULL;
for (p = rem; ; p++) {
c = *p;
if ((c == '\0') || ((openBrace == NULL) && (c == '/'))) break;
if ((c == '{') && (openBrace == NULL)) openBrace = p;
if ((c == '}') && (openBrace != NULL) && (closeBrace == NULL)) closeBrace = p;
if ((c == '*') || (c == '[') || (c == '\\') || (c == '?')) gotSpecial = 1;
}
/*
* If there is an open brace in the argument, then make a recursive
* call for each element between the braces. In this case, the
* recursive call to fileglob uses the same "dir" that we got.
* If there are several brace-pairs in a single name, we just handle
* one here, and the others will be handled in recursive calls.
*/
if (openBrace != NULL) {
char *element;
if (closeBrace == NULL) {
Tcl_DStringFree(&newName);
Err("unmatched open-brace in file name", NIL);
}
Tcl_DStringAppend(&newName, rem, openBrace-rem);
baseLength = newName.length;
for (p = openBrace; *p != '}'; ) {
element = p+1;
for (p = element; ((*p != '}') && (*p != ',')); p++) {}
Tcl_DStringAppend(&newName, element, p-element);
Tcl_DStringAppend(&newName, closeBrace+1, -1);
result = fileglob(dir, newName.string, result);
newName.length = baseLength;
}
goto done;
}
/*
* Start building up the next-level name with dir plus a slash if
* needed to separate it from the next file name.
*/
Tcl_DStringAppend(&newName, dir, -1);
if ((dir[0] != 0) && (newName.string[newName.length-1] != '/')) {
Tcl_DStringAppend(&newName, SDIRSEP, 1);
}
baseLength = newName.length;
/*
* If there were any pattern-matching characters, then scan through
* the directory to find all the matching names.
*/
if (gotSpecial) {
#ifdef _MSC_VER
WIN32_FIND_DATA wfd; /* VC++ support from Caleb Deupree <cdeupree@erinet.com> */
HANDLE handle;
Tcl_DString msvcname;
char savedChar;
BOOL bFound = TRUE;
Tcl_DStringInit(&msvcname);
Tcl_DStringAppend(&msvcname, dirName, -1);
Tcl_DStringAppend(&msvcname, SDIRSEP, 1);
Tcl_DStringAppend(&msvcname, "*\0", -1);
handle = FindFirstFile(Tcl_DStringValue(&msvcname), &wfd);
if (handle == INVALID_HANDLE_VALUE) {
Tcl_DStringFree(&msvcname);
Err("Cannot find files, error = ", STk_makestring(GetLastError()));
}
savedChar = *p;
*p = 0;
while (bFound) {
/*
* Don't match names starting with "." unless the "." is
* present in the pattern.
*/
if ((wfd.cFileName == '.') && (*rem != '.')) continue;
if (Tcl_StringMatch(wfd.cFileName, rem)) {
newName.length = baseLength;
Tcl_DStringAppend(&newName, wfd.cFileName, -1);
if (savedChar == 0)
result = Cons(STk_makestring(newName.string), result);
else {
result = fileglob(newName.string, p+1, result);
if (result != TCL_OK) break;
}
}
bFound = FindNextFile(handle, &wfd);
}
FindClose(handle);
Tcl_DStringFree(&msvcname);
*p = savedChar;
goto done;
#else
DIR *d;
struct dirent *entryPtr;
char savedChar;
d = opendir(dirName);
if (d == NULL) {
Tcl_DStringFree(&newName);
Err("cannot read directory", STk_makestring(dirName));
}
/*
* Temporarily store a null into rem so that the pattern string
* is now null-terminated.
*/
savedChar = *p;
*p = 0;
while (1) {
entryPtr = readdir(d);
if (entryPtr == NULL) break;
/*
* Don't match names starting with "." unless the "." is
* present in the pattern.
*/
if ((*entryPtr->d_name == '.') && (*rem != '.')) continue;
if (Tcl_StringMatch(entryPtr->d_name, rem)) {
newName.length = baseLength;
Tcl_DStringAppend(&newName, entryPtr->d_name, -1);
if (savedChar == 0)
result = Cons(STk_makestring(newName.string), result);
else {
result = fileglob(newName.string, p+1, result);
if (result != TCL_OK) break;
}
}
}
closedir(d);
*p = savedChar;
goto done;
#endif
}
/*
* The current element is a simple one with no fancy features. Add
* it to the new name. If there are more elements still to come,
* then recurse to process them.
*/
Tcl_DStringAppend(&newName, rem, p-rem);
if (*p != 0) {
result = fileglob(newName.string, p+1, result);
goto done;
}
/*
* There are no more elements in the pattern. Check to be sure the
* file actually exists, then add its name to the list being formed
* in main_interp-result.
*/
name = newName.string;
if (*name == 0) name = ".";
if (access(name, F_OK) != 0) goto done;
result = Cons(STk_makestring(name), result);
done:
Tcl_DStringFree(&newName);
return result;
}
SCM STk_internal_expand_file_name(char *s)
{
char expanded[2 * MAX_PATH_LENGTH], abs[2 * MAX_PATH_LENGTH];
/* Warning: absolute makes no control about path overflow. Hence the "2 *" */
absolute(tilde_expand(s, expanded), abs);
return STk_makestring(abs);
}
void STk_whence(char *exec, char *path)
{
char *p, *q, dir[MAX_PATH_LENGTH];
struct stat buf;
if (ISABSOLUTE(exec)) {
strncpy(path, exec, MAX_PATH_LENGTH);
return;
}
#ifdef FREEBSD
/* I don't understand why this is needed */
if (access(path, X_OK) == 0) {
stat(path, &buf);
if (!S_ISDIR(buf.st_mode)) return;
}
#endif
p = getenv("PATH");
while (*p) {
/* Copy the stuck of path in dir */
for (q = dir; *p && *p != PATHSEP; p++, q++) *q = *p;
*q = '\000';
if (!*dir) {
/* patch suggested by Erik Ostrom <eostrom@vesuvius.ccs.neu.edu> */
getcwd(path, MAX_PATH_LENGTH);
sprintf(path + strlen(path), "%c%s", DIRSEP, exec);
}
else
sprintf(path, "%s%c%s", dir, DIRSEP, exec);
sprintf(path, "%s%c%s", dir, DIRSEP, exec);
if (access(path, X_OK) == 0) {
stat(path, &buf);
if (!S_ISDIR(buf.st_mode)) return;
}
/* Try next path */
if (*p) p++;
}
/* Not found. Set path to "" */
path[0] = '\0';
}
int STk_dirp(const char *path)
{
struct stat buf;
if (stat(path, &buf) >= 0)
return S_ISDIR(buf.st_mode);
return FALSE;
}
/******************************************************************************
*
* Primitives
*
******************************************************************************/
PRIMITIVE STk_expand_file_name(SCM s)
{
if (NSTRINGP(s)) Err("expand-file-name: bad string", s);
return STk_internal_expand_file_name(CHARS(s));
}
PRIMITIVE STk_canonical_path(SCM str)
{
if (NSTRINGP(str)) Err("canonical-path: not a string", str);
return STk_resolve_link(CHARS(str), 0);
}
PRIMITIVE STk_getcwd(void)
{
char *buf = (char *)getcwd(NULL, MAX_PATH_LENGTH);
SCM z;
if (!buf) Err("getcwd: cannot allocate space", NIL);
z = STk_makestring(buf);
free(buf);
return z;
}
PRIMITIVE STk_chdir(SCM s)
{
if (NSTRINGP(s)) Err("chdir: bad string", s);
if (chdir(CHARS(STk_internal_expand_file_name(CHARS(s)))))
Err("chdir: cannot change directory to", s);
return UNDEFINED;
}
PRIMITIVE STk_getpid(void)
{
return (STk_makeinteger((int) getpid()));
}
PRIMITIVE STk_system(SCM com)
{
if (NSTRINGP(com)) Err("system: not a string", com);
return STk_makeinteger(system(CHARS(com)));
}
PRIMITIVE STk_getenv(SCM str)
{
char *tmp;
if (NSTRINGP(str)) Err("getenv: not a string", str);
tmp = getenv(CHARS(str));
return tmp ? STk_makestring(tmp) : Ntruth;
}
PRIMITIVE STk_setenv(SCM var, SCM value)
{
char *s;
if (NSTRINGP(var)) Err("setenv!: variable is not a string", var);
if (strchr(CHARS(var), '=')) Err("setenv!: variable contains a '='", var);
if (NSTRINGP(value)) Err("setenv!: value is not a string", value);
s = malloc(strlen(CHARS(var))+ strlen(CHARS(value)) + 2); /* 2 cause '=' & \0 */
sprintf(s, "%s=%s", CHARS(var), CHARS(value));
putenv(s);
return UNDEFINED;
}
/******************************************************************************
*
* file-is-xxx? primitives
*
******************************************************************************/
static SCM my_access(SCM path, int mode, char *who)
{
if (NSTRINGP(path)) {
char buff[100];
sprintf(buff, "%s: bad string", who);
Err(buff, path);
}
return (access(CHARS(path), mode) == 0) ? Truth: Ntruth;
}
static SCM my_stat(SCM path, int mode, char *who)
{
struct stat info;
if (NSTRINGP(path)) {
char buff[100];
sprintf(buff, "%s: bad string", who);
Err(buff, path);
}
if (stat(CHARS(path), &info) != 0) return Ntruth;
switch (mode) {
case 1: return (S_ISDIR(info.st_mode)) ? Truth : Ntruth;
case 2: return (S_ISREG(info.st_mode)) ? Truth : Ntruth;
}
}
PRIMITIVE STk_file_is_directoryp(SCM f)
{
return my_stat(f, 1, "file-is-directory?");
}
PRIMITIVE STk_file_is_regularp(SCM f)
{
return my_stat(f, 2, "file-is-regular?");
}
PRIMITIVE STk_file_is_readablep(SCM f)
{
return my_access(f, R_OK, "file-is-readable?");
}
PRIMITIVE STk_file_is_writablep(SCM f)
{
return my_access(f, W_OK, "file-is-writable?");
}
PRIMITIVE STk_file_is_executablep(SCM f)
{
return my_access(f, X_OK, "file-is-executable?");
}
PRIMITIVE STk_file_existp(SCM f)
{
return my_access(f, F_OK, "file-exists?");
}
PRIMITIVE STk_file_glob(SCM l, int len) /* len is unused here */
{
SCM res = NIL;
char s[2*MAX_PATH_LENGTH];
for ( ; NNULLP(l); l = CDR(l)) {
if (NSTRINGP(CAR(l))) Err("glob: bad string", CAR(l));
tilde_expand(CHARS(CAR(l)), s);
res = STk_append2(res, (ISDIRSEP(*s)) ? fileglob(SDIRSEP, s+1, NIL) :
fileglob("", s, NIL));
}
return res;
}
PRIMITIVE STk_remove_file(SCM filename)
{
ENTER_PRIMITIVE("remove-file");
if (NSTRINGP(filename)) Serror("bad string", filename);
if (remove(CHARS(filename)) != 0)
Serror("cannot remove file", filename);
return UNDEFINED;
}
PRIMITIVE STk_rename_file(SCM filename1, SCM filename2)
{
ENTER_PRIMITIVE("rename-file");
if (NSTRINGP(filename1)) Serror("bad string", filename1);
if (NSTRINGP(filename2)) Serror("bad string", filename2);
if (rename(CHARS(filename1), CHARS(filename2)) != 0)
Serror("cannot rename file", filename1);
return UNDEFINED;
}
PRIMITIVE STk_temporary_file_name(void)
{
char *s;
ENTER_PRIMITIVE("temporary-file-name");
s = tmpnam(NULL);
return s ? STk_makestring(s) : Ntruth;
}
Reference in New Issue View Git Blame Copy Permalink