pathname.c

Branch :
Show log
Commit
Author : matthieu
Date : 2006-11-25 20:07:29
Hash : 616b6f15
Message : Importing from X.Org 7.2RC2
app/xedit/lisp/pathname.c
/*
 * Copyright (c) 2001 by The XFree86 Project, Inc.
 *
 * Permission is hereby granted, free of charge, to any person obtaining a
 * copy of this software and associated documentation files (the "Software"),
 * to deal in the Software without restriction, including without limitation
 * the rights to use, copy, modify, merge, publish, distribute, sublicense,
 * and/or sell copies of the Software, and to permit persons to whom the
 * Software is furnished to do so, subject to the following conditions:
 *
 * The above copyright notice and this permission notice shall be included in
 * all copies or substantial portions of the Software.
 *  
 * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
 * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
 * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.  IN NO EVENT SHALL
 * THE XFREE86 PROJECT BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
 * WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF
 * OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
 * SOFTWARE.
 *
 * Except as contained in this notice, the name of the XFree86 Project shall
 * not be used in advertising or otherwise to promote the sale, use or other
 * dealings in this Software without prior written authorization from the
 * XFree86 Project.
 *
 * Author: Paulo César Pereira de Andrade
 */

/* $XFree86: xc/programs/xedit/lisp/pathname.c,v 1.17tsi Exp $ */

#include <stdio.h>	/* including dirent.h first may cause problems */
#include <sys/types.h>
#include <dirent.h>
#include <errno.h>
#include <sys/stat.h>
#include "lisp/pathname.h"
#include "lisp/private.h"

#define NOREAD_SKIP	0
#define NOREAD_ERROR	1

/*
 * Initialization
 */
LispObj *Oparse_namestring, *Kerror, *Kabsolute, *Krelative, *Kskip;

/*
 * Implementation
 */
void
LispPathnameInit(void)
{
    Kerror		= KEYWORD("ERROR");
    Oparse_namestring	= STATIC_ATOM("PARSE-NAMESTRING");
    Kabsolute		= KEYWORD("ABSOLUTE");
    Krelative		= KEYWORD("RELATIVE");
}

static int
glob_match(char *cmp1, char *cmp2)
/*
 * Note: this code was written from scratch, and may generate incorrect
 * results for very complex glob masks.
 */
{
    for (;;) {
	while (*cmp1 && *cmp1 == *cmp2) {
	    ++cmp1;
	    ++cmp2;
	}
	if (*cmp2) {
	    if (*cmp1 == '*') {
		while (*cmp1 == '*')
		    ++cmp1;
		if (*cmp1) {
		    int count = 0, settmp = 1;
		    char *tmp = cmp2, *sav2;

		    while (*cmp1 && *cmp1 == '?') {
			++cmp1;
			++count;
		    }

		    /* need to recurse here to make sure
		     * all cases are tested.
		     */
		    while (*cmp2 && *cmp2 != *cmp1)
			++cmp2;
		    if (!*cmp1 && cmp2 - tmp < count)
			return (0);
		    sav2 = cmp2;

		    /* if recursive calls fails, make sure all '?'
		     * following '*' are processed */
		    while (*sav2 && sav2 - tmp < count)
			++sav2;

		    for (; *cmp2;) {
			if (settmp) /* repeated letters: *?o? => boot, root */
			    tmp = cmp2;
			else
			    settmp = 1;
			while (*cmp2 && *cmp2 != *cmp1)
			    ++cmp2;
			if (cmp2 - tmp < count) {
			    if (*cmp2)
				++cmp2;
			    settmp = 0;
			    continue;
			}
			if (*cmp2) {
			    if (glob_match(cmp1, cmp2))
				return (1);
			    ++cmp2;
			}
		    }
		    cmp2 = sav2;
		}
		else {
		    while (*cmp2)
			++cmp2;
		    break;
		}
	    }
	    else if (*cmp1 == '?') {
		while (*cmp1 == '?' && *cmp2) {
		    ++cmp1;
		    ++cmp2;
		}
		continue;
	    }
	    else
		break;
	}
	else {
	    while (*cmp1 == '*')
		++cmp1;
	    break;
	}
    }

    return (*cmp1 == '\0' && *cmp2 == '\0');
}

/*
 * Since directory is a function to be extended by the implementation,
 * current extensions are:
 *	all		=> list files and directories
 *			   it is an error to call
 *			   (directory "<pathname-spec>/" :all t)
 *			   if non nil, it is like the shell command
 *			   echo <pathname-spec>, but normally, not in the
 *			   same order, as the code does not sort the result.
 *		!=nil	=> list files and directories
 * (default)	nil	=> list only files, or only directories if
 *			   <pathname-spec> ends with PATH_SEP char.
 *	if-cannot-read	=> if opendir fails on a directory
 *		:error	=> generate an error
 * (default)	:skip	=> skip search in this directory
 */
LispObj *
Lisp_Directory(LispBuiltin *builtin)
/*
 directory pathname &key all if-cannot-read
 */
{
    GC_ENTER();
    DIR *dir;
    struct stat st;
    struct dirent *ent;
    int length, listdirs, i, ndirs, nmatches;
    char name[PATH_MAX + 1], path[PATH_MAX + 2], directory[PATH_MAX + 2];
    char *sep, *base, *ptr, **dirs, **matches,
	  dot[] = {'.', PATH_SEP, '\0'},
	  dotdot[] = {'.', '.', PATH_SEP, '\0'};
    int cannot_read;

    LispObj *pathname, *all, *if_cannot_read, *result, *cons, *object;

    if_cannot_read = ARGUMENT(2);
    all = ARGUMENT(1);
    pathname = ARGUMENT(0);
    result = NIL;

    cons = NIL;

    if (if_cannot_read != UNSPEC) {
	if (!KEYWORDP(if_cannot_read) ||
	    (if_cannot_read != Kskip &&
	     if_cannot_read != Kerror))
	    LispDestroy("%s: bad :IF-CANNOT-READ %s",
			STRFUN(builtin), STROBJ(if_cannot_read));
	if (if_cannot_read != Kskip)
	    cannot_read = NOREAD_SKIP;
	else
	    cannot_read = NOREAD_ERROR;
    }
    else
	cannot_read = NOREAD_SKIP;

    if (PATHNAMEP(pathname))
	pathname = CAR(pathname->data.pathname);
    else if (STREAMP(pathname) && pathname->data.stream.type == LispStreamFile)
	pathname = CAR(pathname->data.stream.pathname->data.pathname);
    else if (!STRINGP(pathname))
	LispDestroy("%s: %s is not a pathname",
		    STRFUN(builtin), STROBJ(pathname));

    strncpy(name, THESTR(pathname), sizeof(name) - 1);
    name[sizeof(name) - 1] = '\0';
    length = strlen(name);
    if (length < STRLEN(pathname))
	LispDestroy("%s: pathname too long %s",
		    STRFUN(builtin), name);

    if (length == 0) {
	if (getcwd(path, sizeof(path) - 2) == NULL)
	    LispDestroy("%s: getcwd(): %s", STRFUN(builtin), strerror(errno));
	length = strlen(path);
	if (!length || path[length - 1] != PATH_SEP) {
	    path[length++] = PATH_SEP;
	    path[length] = '\0';
	}
	result = APPLY1(Oparse_namestring, LSTRING(path, length));
	GC_LEAVE();

	return (result);
    }

    if (name[length - 1] == PATH_SEP) {
	listdirs = 1;
	if (length > 1) {
	    --length;
	    name[length] = '\0';
	}
    }
    else
	listdirs = 0;

    if (name[0] != PATH_SEP) {
	if (getcwd(path, sizeof(path) - 2) == NULL)
	    LispDestroy("%s: getcwd(): %s", STRFUN(builtin), strerror(errno));
	length = strlen(path);
	if (!length || path[length - 1] != PATH_SEP) {
	    path[length++] = PATH_SEP;
	    path[length] = '\0';
	}
    }
    else
	path[0] = '\0';

    result = NIL;

    /* list intermediate directories */
    matches = NULL;
    nmatches = 0;
    dirs = LispMalloc(sizeof(char*));
    ndirs = 1;
    if (snprintf(directory, sizeof(directory), "%s%s%c",
		 path, name, PATH_SEP) > PATH_MAX)
	LispDestroy("%s: pathname too long %s", STRFUN(builtin), directory);

    /* Remove ../ */
    sep = directory;
    for (sep = strstr(sep, dotdot); sep; sep = strstr(sep, dotdot)) {
	if (sep <= directory + 1)
	    strcpy(directory, sep + 2);
	else if (sep[-1] == PATH_SEP) {
	    for (base = sep - 2; base > directory; base--)
		if (*base == PATH_SEP)
		    break;
	    strcpy(base, sep + 2);
	    sep = base;
	}
	else
	    ++sep;
    }

    /* Remove "./" */
    sep = directory;
    for (sep = strstr(sep, dot); sep; sep = strstr(sep, dot)) {
	if (sep == directory || sep[-1] == PATH_SEP)
	    strcpy(sep, sep + 2);
	else
	    ++sep;
    }

    /* This will happen when there are too many '../'  in the path */
    if (directory[1] == '\0') {
	directory[1] = PATH_SEP;
	directory[2] = '\0';
    }

    base = directory;
    sep = strchr(base + 1, PATH_SEP);
    dirs[0] = LispMalloc(2);
    dirs[0][0] = PATH_SEP;
    dirs[0][1] = '\0';

    for (base = directory + 1, sep = strchr(base, PATH_SEP); ;
	 base = sep + 1, sep = strchr(base, PATH_SEP)) {
	*sep = '\0';
	if (sep[1] == '\0')
	    sep = NULL;
	length = strlen(base);
	if (length == 0) {
	    if (sep)
		*sep = PATH_SEP;
	    else
		break;
	    continue;
	}

	for (i = 0; i < ndirs; i++) {
	    length = strlen(dirs[i]);
	    if (length > 1)
		dirs[i][length - 1] = '\0';		/* remove trailing / */
	    if ((dir = opendir(dirs[i])) != NULL) {
		(void)readdir(dir);	/* "." */
		(void)readdir(dir);	/* ".." */
		if (length > 1)
		    dirs[i][length - 1] = PATH_SEP;	/* add trailing / again */

		snprintf(path, sizeof(path), "%s", dirs[i]);
		length = strlen(path);
		ptr = path + length;

		while ((ent = readdir(dir)) != NULL) {
		    int isdir;
		    unsigned d_namlen = strlen(ent->d_name);

		    if (length + d_namlen + 2 < sizeof(path))
			strcpy(ptr, ent->d_name);
		    else {
			closedir(dir);
			LispDestroy("%s: pathname too long %s",
				    STRFUN(builtin), dirs[i]);
		    }

		    if (stat(path, &st) != 0)
			isdir = 0;
		    else
			isdir = S_ISDIR(st.st_mode);

		    if (all != UNSPEC || ((isdir && (listdirs || sep)) ||
					  (!listdirs && !sep && !isdir))) {
			if (glob_match(base, ent->d_name)) {
			    if (isdir) {
				length = strlen(ptr);
				ptr[length++] = PATH_SEP;
				ptr[length] = '\0';
			    }
			    /* XXX won't closedir on memory allocation failure! */
			    matches = LispRealloc(matches, sizeof(char*) *
						  nmatches + 1);
			    matches[nmatches++] = LispStrdup(ptr);
			}
		    }
		}
		closedir(dir);

		if (nmatches == 0) {
		    if (sep || !listdirs || *base) {
			LispFree(dirs[i]);
			if (i + 1 < ndirs)
			    memmove(dirs + i, dirs + i + 1,
				    sizeof(char*) * (ndirs - (i + 1)));
			--ndirs;
			--i;		    /* XXX playing with for loop */
		    }
		}
		else {
		    int j;

		    length = strlen(dirs[i]);
		    if (nmatches > 1) {
			dirs = LispRealloc(dirs, sizeof(char*) *
					   (ndirs + nmatches));
			if (i + 1 < ndirs)
			    memmove(dirs + i + nmatches, dirs + i + 1,
				    sizeof(char*) * (ndirs - (i + 1)));
		    }
		    for (j = 1; j < nmatches; j++) {
			dirs[i + j] = LispMalloc(length +
						 strlen(matches[j]) + 1);
			sprintf(dirs[i + j], "%s%s", dirs[i], matches[j]);
		    }
		    dirs[i] = LispRealloc(dirs[i],
					  length + strlen(matches[0]) + 1);
		    strcpy(dirs[i] + length, matches[0]);
		    i += nmatches - 1;	/* XXX playing with for loop */
		    ndirs += nmatches - 1;

		    for (j = 0; j < nmatches; j++)
			LispFree(matches[j]);
		    LispFree(matches);
		    matches = NULL;
		    nmatches = 0;
		}
	    }
	    else {
		if (cannot_read == NOREAD_ERROR)
		    LispDestroy("%s: opendir(%s): %s",
				STRFUN(builtin), dirs[i], strerror(errno));
		else {
		    LispFree(dirs[i]);
		    if (i + 1 < ndirs)
			memmove(dirs + i, dirs + i + 1,
				sizeof(char*) * (ndirs - (i + 1)));
		    --ndirs;
		    --i;	    /* XXX playing with for loop */
		}
	    }
	}
	if (sep)
	    *sep = PATH_SEP;
	else
	    break;
    }

    for (i = 0; i < ndirs; i++) {
	object = APPLY1(Oparse_namestring, STRING2(dirs[i]));
	if (result == NIL) {
	    result = cons = CONS(object, NIL);
	    GC_PROTECT(result);
	}
	else {
	    RPLACD(cons, CONS(object, NIL));
	    cons = CDR(cons);
	}
    }
    LispFree(dirs);
    GC_LEAVE();

    return (result);
}

LispObj *
Lisp_ParseNamestring(LispBuiltin *builtin)
/*
 parse-namestring object &optional host defaults &key start end junk-allowed
 */
{
    GC_ENTER();
    LispObj *result;

    LispObj *object, *host, *defaults, *ostart, *oend, *junk_allowed;

    junk_allowed = ARGUMENT(5);
    oend = ARGUMENT(4);
    ostart = ARGUMENT(3);
    defaults = ARGUMENT(2);
    host = ARGUMENT(1);
    object = ARGUMENT(0);

    if (host == UNSPEC)
	host = NIL;
    if (defaults == UNSPEC)
	defaults = NIL;

    RETURN_COUNT = 1;
    if (STREAMP(object)) {
	if (object->data.stream.type == LispStreamFile)
	    object = object->data.stream.pathname;
	/* else just check for JUNK-ALLOWED... */
    }
    if (PATHNAMEP(object)) {
	RETURN(0) = FIXNUM(0);
	return (object);
    }

    if (host != NIL) {
	CHECK_STRING(host);
    }
    if (defaults != NIL) {
	if (!PATHNAMEP(defaults)) {
	    defaults = APPLY1(Oparse_namestring, defaults);
	    GC_PROTECT(defaults);
	}
    }

    result = NIL;
    if (STRINGP(object)) {
	LispObj *cons, *cdr;
	char *name = THESTR(object), *ptr, *str, data[PATH_MAX + 1],
	      string[PATH_MAX + 1], *namestr, *typestr, *send;
	long start, end, length, alength, namelen, typelen;

	LispCheckSequenceStartEnd(builtin, object, ostart, oend,
				  &start, &end, &length);
	alength = end - start;

	if (alength > sizeof(data) - 1)
	    LispDestroy("%s: string %s too large",
			STRFUN(builtin), STROBJ(object));
	memcpy(data, name + start, alength);
#ifndef KEEP_EXTRA_PATH_SEP
	ptr = data;
	send = ptr + alength;
	while (ptr < send) {
	    if (*ptr++ == PATH_SEP) {
		for (str = ptr; str < send && *str == PATH_SEP; str++)
		    ;
		if (str - ptr) {
		    memmove(ptr, str, alength - (str - data));
		    alength -= str - ptr;
		    send -= str - ptr;
		}
	    }
	}
#endif
	data[alength] = '\0';
	memcpy(string, data, alength + 1);

	if (PATHNAMEP(defaults))
	    defaults = defaults->data.pathname;

	/* string name */
	result = cons = CONS(NIL, NIL);
	GC_PROTECT(result);

	/* host */
	if (defaults != NIL)
	    defaults = CDR(defaults);
	cdr = defaults == NIL ? NIL : CAR(defaults);
	RPLACD(cons, CONS(cdr, NIL));
	cons = CDR(cons);

	/* device */
	if (defaults != NIL)
	    defaults = CDR(defaults);
	cdr = defaults == NIL ? NIL : CAR(defaults);
	RPLACD(cons, CONS(cdr, NIL));
	cons = CDR(cons);

	/* directory */
	if (defaults != NIL)
	    defaults = CDR(defaults);
	if (*data == PATH_SEP)
	    cdr = CONS(Kabsolute, NIL);
	else
	    cdr = CONS(Krelative, NIL);
	RPLACD(cons, CONS(cdr, NIL));
	cons = CDR(cons);
	/* directory components */
	ptr = data;
	send = data + alength;
	if (*ptr == PATH_SEP)
	    ++ptr;
	for (str = ptr; str < send; str++) {
	    if (*str == PATH_SEP)
		break;
	}
	while (str < send) {
	    *str++ = '\0';
	    if (str - ptr > NAME_MAX)
		LispDestroy("%s: directory name too long %s",
			    STRFUN(builtin), ptr);
	    RPLACD(cdr, CONS(LSTRING(ptr, str - ptr - 1), NIL));
	    cdr = CDR(cdr);
	    for (ptr = str; str < send; str++) {
		if (*str == PATH_SEP)
		    break;
	    }
	}
	if (str - ptr > NAME_MAX)
	    LispDestroy("%s: file name too long %s", STRFUN(builtin), ptr);
	if (CAAR(cons) == Krelative &&
	    defaults != NIL && CAAR(defaults) == Kabsolute) {
	    /* defaults specify directory and pathname doesn't */
	    char *tstring;
	    long dlength, tlength;
	    LispObj *dir = CDAR(defaults);

	    for (dlength = 1; CONSP(dir); dir = CDR(dir))
		dlength += STRLEN(CAR(dir)) + 1;
	    if (alength + dlength < PATH_MAX) {
		memmove(data + dlength, data, alength + 1);
		memmove(string + dlength, string, alength + 1);
		alength += dlength;
		ptr += dlength;
		send += dlength;
		CAAR(cons) = Kabsolute;
		for (dir = CDAR(defaults), cdr = CAR(cons);
		     CONSP(dir);
		     dir = CDR(dir)) {
		    RPLACD(cdr, CONS(CAR(dir), CDR(cdr)));
		    cdr = CDR(cdr);
		}
		dir = CDAR(defaults);
		data[0] = string[0] = PATH_SEP;
		for (dlength = 1; CONSP(dir); dir = CDR(dir)) {
		    tstring = THESTR(CAR(dir));
		    tlength = STRLEN(CAR(dir));
		    memcpy(data + dlength, tstring, tlength);
		    memcpy(string + dlength, tstring, tlength);
		    dlength += tlength;
		    data[dlength] = string[dlength] = PATH_SEP;
		    ++dlength;
		}
	    }
	}

	/* name */
	if (defaults != NIL)
	    defaults = CDR(defaults);
	cdr = defaults == NIL ? NIL : CAR(defaults);
	for (typelen = 0, str = ptr; str < send; str++) {
	    if (*str == PATH_TYPESEP) {
		typelen = 1;
		break;
	    }
	}
	if (*ptr)
	    cdr = LSTRING(ptr, str - ptr);
	if (STRINGP(cdr)) {
	    namestr = THESTR(cdr);
	    namelen = STRLEN(cdr);
	}
	else {
	    namestr = "";
	    namelen = 0;
	}
	RPLACD(cons, CONS(cdr, NIL));
	cons = CDR(cons);

	/* type */
	if (defaults != NIL)
	    defaults = CDR(defaults);
	cdr = defaults == NIL ? NIL : CAR(defaults);
	ptr = str + typelen;
	if (*ptr)
	    cdr = LSTRING(ptr, send - ptr);
	if (STRINGP(cdr)) {
	    typestr = THESTR(cdr);
	    typelen = STRLEN(cdr);
	}
	else {
	    typestr = "";
	    typelen = 0;
	}
	RPLACD(cons, CONS(cdr, NIL));
	cons = CDR(cons);

	/* version */
	if (defaults != NIL)
	    defaults = CDR(defaults);
	cdr = defaults == NIL ? NIL : CAR(defaults);
	RPLACD(cons, CONS(cdr, NIL));

	/* string representation, must be done here to use defaults */
	for (ptr = string + alength; ptr >= string; ptr--) {
	    if (*ptr == PATH_SEP)
		break;
	}
	if (ptr >= string)
	    ++ptr;
	else
	    ptr = string;
	*ptr = '\0';

	length = ptr - string;

	alength = namelen;
	if (alength) {
	    if (length + alength + 2 > sizeof(string))
		alength = sizeof(string) - length - 2;
	    memcpy(string + length, namestr, alength);
	    length += alength;
	}

	alength = typelen;
	if (alength) {
	    if (length + 2 < sizeof(string))
		string[length++] = PATH_TYPESEP;
	    if (length + alength + 2 > sizeof(string))
		alength = sizeof(string) - length - 2;
	    memcpy(string + length, typestr, alength);
	    length += alength;
	}
	string[length] = '\0';

	RPLACA(result,  LSTRING(string, length));
	RETURN(0) = FIXNUM(end);

	result = PATHNAME(result);
    }
    else if (junk_allowed == UNSPEC || junk_allowed == NIL)
	LispDestroy("%s: bad argument %s", STRFUN(builtin), STROBJ(object));
    else
	RETURN(0) = NIL;

    GC_LEAVE();

    return (result);
}

LispObj *
Lisp_MakePathname(LispBuiltin *builtin)
/*
 make-pathname &key host device directory name type version defaults
 */
{
    GC_ENTER();
    int length, alength;
    char *string, pathname[PATH_MAX + 1];
    LispObj *result, *cdr, *cons;

    LispObj *host, *device, *directory, *name, *type, *version, *defaults;

    defaults = ARGUMENT(6);
    version = ARGUMENT(5);
    type = ARGUMENT(4);
    name = ARGUMENT(3);
    directory = ARGUMENT(2);
    device = ARGUMENT(1);
    host = ARGUMENT(0);

    if (host != UNSPEC) {
	CHECK_STRING(host);
    }
    if (device != UNSPEC) {
	CHECK_STRING(device);
    }

    if (directory != UNSPEC) {
	LispObj *dir;

	CHECK_CONS(directory);
	dir = CAR(directory);
	CHECK_KEYWORD(dir);
	if (dir != Kabsolute && dir != Krelative)
	    LispDestroy("%s: directory type %s unknown",
			STRFUN(builtin), STROBJ(dir));
    }

    if (name != UNSPEC) {
	CHECK_STRING(name);
    }
    if (type != UNSPEC) {
	CHECK_STRING(type);
    }

    if (version != UNSPEC && version != NIL) {
	switch (OBJECT_TYPE(version)) {
	    case LispFixnum_t:
		if (FIXNUM_VALUE(version) >= 0)
		    goto version_ok;
	    case LispInteger_t:
		if (INT_VALUE(version) >= 0)
		    goto version_ok;
		break;
	    case LispDFloat_t:
		if (DFLOAT_VALUE(version) >= 0.0)
		    goto version_ok;
		break;
	    default:
		break;
	}
	LispDestroy("%s: %s is not a positive real number",
		    STRFUN(builtin), STROBJ(version));
    }
version_ok:

    if (defaults != UNSPEC && !PATHNAMEP(defaults) &&
	(host == UNSPEC || device == UNSPEC || directory == UNSPEC ||
	 name == UNSPEC || type == UNSPEC || version == UNSPEC)) {
	defaults = APPLY1(Oparse_namestring, defaults);
	GC_PROTECT(defaults);
    }

    if (defaults != UNSPEC) {
	defaults = defaults->data.pathname;
	defaults = CDR(defaults);	/* host */
	if (host == UNSPEC)
	    host = CAR(defaults);
	defaults = CDR(defaults);	/* device */
	if (device == UNSPEC)
	    device = CAR(defaults);
	defaults = CDR(defaults);	/* directory */
	if (directory == UNSPEC)
	    directory = CAR(defaults);
	defaults = CDR(defaults);	/* name */
	if (name == UNSPEC)
	    name = CAR(defaults);
	defaults = CDR(defaults);	/* type */
	if (type == UNSPEC)
	    type = CAR(defaults);
	defaults = CDR(defaults);	/* version */
	if (version == UNSPEC)
	    version = CAR(defaults);
    }

    /* string representation */
    length = 0;
    if (CONSP(directory)) {
	if (CAR(directory) == Kabsolute)
	    pathname[length++] = PATH_SEP;

	for (cdr = CDR(directory); CONSP(cdr); cdr = CDR(cdr)) {
	    CHECK_STRING(CAR(cdr));
	    string = THESTR(CAR(cdr));
	    alength = STRLEN(CAR(cdr));
	    if (alength > NAME_MAX)
		LispDestroy("%s: directory name too long %s",
			    STRFUN(builtin), string);
	    if (length + alength + 2 > sizeof(pathname))
		alength = sizeof(pathname) - length - 2;
	    memcpy(pathname + length, string, alength);
	    length += alength;
	    pathname[length++] = PATH_SEP;
	}
    }
    if (STRINGP(name)) {
	int xlength = 0;

	if (STRINGP(type))
	    xlength = STRLEN(type) + 1;

	string = THESTR(name);
	alength = STRLEN(name);
	if (alength + xlength > NAME_MAX)
	    LispDestroy("%s: file name too long %s",
			STRFUN(builtin), string);
	if (length + alength + 2 > sizeof(pathname))
	    alength = sizeof(pathname) - length - 2;
	memcpy(pathname + length, string, alength);
	length += alength;
    }
    if (STRINGP(type)) {
	if (length + 2 < sizeof(pathname))
	    pathname[length++] = PATH_TYPESEP;
	string = THESTR(type);
	alength = STRLEN(type);
	if (length + alength + 2 > sizeof(pathname))
	    alength = sizeof(pathname) - length - 2;
	memcpy(pathname + length, string, alength);
	length += alength;
    }
    pathname[length] = '\0';
    result = cons = CONS(LSTRING(pathname, length), NIL);
    GC_PROTECT(result);

    /* host */
    RPLACD(cons, CONS(host == UNSPEC ? NIL : host, NIL));
    cons = CDR(cons);

    /* device */
    RPLACD(cons, CONS(device == UNSPEC ? NIL : device, NIL));
    cons = CDR(cons);

    /* directory */
    if (directory == UNSPEC)
	cdr = CONS(Krelative, NIL);
    else
	cdr = directory;
    RPLACD(cons, CONS(cdr, NIL));
    cons = CDR(cons);

    /* name */
    RPLACD(cons, CONS(name == UNSPEC ? NIL : name, NIL));
    cons = CDR(cons);

    /* type */
    RPLACD(cons, CONS(type == UNSPEC ? NIL : type, NIL));
    cons = CDR(cons);

    /* version */
    RPLACD(cons, CONS(version == UNSPEC ? NIL : version, NIL));

    GC_LEAVE();

    return (PATHNAME(result));
}

LispObj *
Lisp_PathnameHost(LispBuiltin *builtin)
/*
 pathname-host pathname
 */
{
    return (LispPathnameField(PATH_HOST, 0));
}

LispObj *
Lisp_PathnameDevice(LispBuiltin *builtin)
/*
 pathname-device pathname
 */
{
    return (LispPathnameField(PATH_DEVICE, 0));
}

LispObj *
Lisp_PathnameDirectory(LispBuiltin *builtin)
/*
 pathname-device pathname
 */
{
    return (LispPathnameField(PATH_DIRECTORY, 0));
}

LispObj *
Lisp_PathnameName(LispBuiltin *builtin)
/*
 pathname-name pathname
 */
{
    return (LispPathnameField(PATH_NAME, 0));
}

LispObj *
Lisp_PathnameType(LispBuiltin *builtin)
/*
 pathname-type pathname
 */
{
    return (LispPathnameField(PATH_TYPE, 0));
}

LispObj *
Lisp_PathnameVersion(LispBuiltin *builtin)
/*
 pathname-version pathname
 */
{
    return (LispPathnameField(PATH_VERSION, 0));
}

LispObj *
Lisp_FileNamestring(LispBuiltin *builtin)
/*
 file-namestring pathname
 */
{
    return (LispPathnameField(PATH_NAME, 1));
}

LispObj *
Lisp_DirectoryNamestring(LispBuiltin *builtin)
/*
 directory-namestring pathname
 */
{
    return (LispPathnameField(PATH_DIRECTORY, 1));
}

LispObj *
Lisp_EnoughNamestring(LispBuiltin *builtin)
/*
 enough-pathname pathname &optional defaults
 */
{
    LispObj *pathname, *defaults;

    defaults = ARGUMENT(1);
    pathname = ARGUMENT(0);

    if (defaults != UNSPEC && defaults != NIL) {
	char *ppathname, *pdefaults, *pp, *pd;

	if (!STRINGP(pathname)) {
	    if (PATHNAMEP(pathname))
		pathname  = CAR(pathname->data.pathname);
	    else if (STREAMP(pathname) &&
		     pathname->data.stream.type == LispStreamFile)
		pathname  = CAR(pathname->data.stream.pathname->data.pathname);
	    else
		LispDestroy("%s: bad PATHNAME %s",
			    STRFUN(builtin), STROBJ(pathname));
	}

	if (!STRINGP(defaults)) {
	    if (PATHNAMEP(defaults))
		defaults  = CAR(defaults->data.pathname);
	    else if (STREAMP(defaults) &&
		     defaults->data.stream.type == LispStreamFile)
		defaults  = CAR(defaults->data.stream.pathname->data.pathname);
	    else
		LispDestroy("%s: bad DEFAULTS %s",
			    STRFUN(builtin), STROBJ(defaults));
	}

	ppathname = pp = THESTR(pathname);
	pdefaults = pd = THESTR(defaults);
	while (*ppathname && *pdefaults && *ppathname == *pdefaults) {
	    ppathname++;
	    pdefaults++;
	}
	if (*pdefaults == '\0' && pdefaults > pd)
	    --pdefaults;
	if (*ppathname && *pdefaults && *pdefaults != PATH_SEP) {
	    --ppathname;
	    while (*ppathname != PATH_SEP && ppathname > pp)
		--ppathname;
	    if (*ppathname == PATH_SEP)
		++ppathname;
	}

	return (STRING(ppathname));
    }
    else {
	if (STRINGP(pathname))
	    return (pathname);
	else if (PATHNAMEP(pathname))
	    return (CAR(pathname->data.pathname));
	else if (STREAMP(pathname)) {
	    if (pathname->data.stream.type == LispStreamFile)
		return (CAR(pathname->data.stream.pathname->data.pathname));
	}
    }
    LispDestroy("%s: bad PATHNAME %s", STRFUN(builtin), STROBJ(pathname));

    return (NIL);
}

LispObj *
Lisp_Namestring(LispBuiltin *builtin)
/*
 namestring pathname
 */
{
    return (LispPathnameField(PATH_STRING, 1));
}

LispObj *
Lisp_HostNamestring(LispBuiltin *builtin)
/*
 host-namestring pathname
 */
{
    return (LispPathnameField(PATH_HOST, 1));
}

LispObj *
Lisp_Pathnamep(LispBuiltin *builtin)
/*
 pathnamep object
 */
{
    LispObj *object;

    object = ARGUMENT(0);

    return (PATHNAMEP(object) ? T : NIL);
}

/* XXX only checks if host is a string and only checks the HOME enviroment
 * variable */
LispObj *
Lisp_UserHomedirPathname(LispBuiltin *builtin)
/*
 user-homedir-pathname &optional host
 */
{
    GC_ENTER();
    int length;
    char *home = getenv("HOME"), data[PATH_MAX + 1];
    LispObj *result;

    LispObj *host;

    host = ARGUMENT(0);

    if (host != UNSPEC && !STRINGP(host))
	LispDestroy("%s: bad hostname %s", STRFUN(builtin), STROBJ(host));

    length = 0;
    if (home) {
	length = strlen(home);
	strncpy(data, home, length);
	if (length && home[length - 1] != PATH_SEP)
	    data[length++] = PATH_SEP;
    }
    data[length] = '\0';

    result = LSTRING(data, length);
    GC_PROTECT(result);
    result = APPLY1(Oparse_namestring, result);
    GC_LEAVE();

    return (result);
}

LispObj *
Lisp_Truename(LispBuiltin *builtin)
{
    return (LispProbeFile(builtin, 0));
}

LispObj *
Lisp_ProbeFile(LispBuiltin *builtin)
{
    return (LispProbeFile(builtin, 1));
}
IABSD.fr/xenocara/app/xedit/lisp/pathname.c

Commit

IABSD.fr/xenocara /app/xedit/lisp/pathname.c
