/* * Pathnames for CLISP * Bruno Haible 1990-2008 * Logical Pathnames: Marcus Daniels 16.9.1994 * ANSI compliance, bugs: Sam Steingold 1998-2011 * German comments translated into English: Stefan Kain 2002-01-03 */ #include "lispbibl.c" #ifdef WIN32_NATIVE #include "w32shell.c" #endif /* enable the following #define to debug pathname translations setting DEBUG_TRANSLATE_PATHNAME to a larger value results in more output WARNING: PRIN1 can trigger GC! BEWARE! */ # define DEBUG_TRANSLATE_PATHNAME 1 #if DEBUG_TRANSLATE_PATHNAME #define string_concat(x) (printf("[%d]string_concat(%d)\n",__LINE__,x),(string_concat)(x)) #define DOUT(label,obj) OBJECT_OUT(obj,label) #define SDOUT(label,obj) printf("%d %s %s",__LINE__,label,STRING(obj));nobject_out(stdout,obj) #else #define DOUT(l,o) #define SDOUT(l,o) #endif /* ======================================================================== Low level functions */ /* we need realpath() (declared in ) http://www.opengroup.org/onlinepubs/009695399/functions/realpath.html which is alleged to be broken on some systems OTOH, on some other systems, notably on cygwin, we _do_ need the system implementation of realpath because otherwise we get screwed on /proc/self/exe -> lisp instead of lisp.exe and possibly other quirks */ #if defined(UNIX) && !defined(HAVE_REALPATH) /* library-function realpath implementation: [Copyright: SUN Microsystems, B. Haible] TITLE REALPATH(3) SYNOPSIS char* realpath (const char* path, char resolved_path[MAXPATHLEN]); DESCRIPTION realpath() expands all symbolic links and resolves refer- ences to '/./', '/../' and extra '/' characters in the null terminated string named by path and stores the canonicalized absolute pathname in the buffer named by resolved_path. The resulting path will have no symbolic links components, nor any '/./' or '/../' components. RETURN VALUES realpath() returns a pointer to the resolved_path on suc- cess. On failure, it returns NULL, sets errno to indicate the error, and places in resolved_path the absolute pathname of the path component which could not be resolved. */ #define realpath my_realpath /* avoid conflict with Consensys realpath declaration */ local char* realpath (const char* path, char* resolved_path) { /* Method: use getwd and readlink. */ var char mypath[MAXPATHLEN]; var int symlinkcount = 0; /* the number of symbolic links so far */ var char* resolved_limit = &resolved_path[MAXPATHLEN-1]; /* Valid pointers are those with resolved_path <= ptr <= resolved_limit. in *resolved_limit at most one null byte. (similarly with mypath.) */ var char* resolve_start; { var char* resolved_ptr = resolved_path; /* always <= resolved_limit */ /* poss. use Working-Directory: */ if (!(path[0]=='/')) { /* not an absolute pathname? */ if (getwd(resolved_path) == NULL) return NULL; resolved_ptr = resolved_path; while (*resolved_ptr) { resolved_ptr++; } if (resolved_ptr < resolved_limit) { *resolved_ptr++ = '/'; } resolve_start = resolved_ptr; } else { resolve_start = resolved_ptr = &resolved_path[0]; } /* copy the path: */ var const char* path_ptr = path; while ((resolved_ptr < resolved_limit) && *path_ptr) { *resolved_ptr++ = *path_ptr++; } /* finish with '/' and a null: */ if (resolved_ptr < resolved_limit) { *resolved_ptr++ = '/'; } *resolved_ptr = 0; } /* Now start in resolved_path at resolve_start. */ var char* from_ptr = resolve_start; var char* to_ptr = resolve_start; while ((to_ptr < resolved_limit) && (*from_ptr)) { /* so far the path in resolved_path[0]...to_ptr[-1] has the shape '/subdir1/subdir2/.../txt', whereas 'txt' is poss. empty, but no subdir is empty. */ var char next = *from_ptr++; *to_ptr++ = next; if ((next == '/') && (to_ptr > resolved_path+1)) { /* to_ptr[-1]='/' -> resolve Directory ...to_ptr[-2] : */ var char* last_subdir_end = &to_ptr[-2]; switch (*last_subdir_end) { case '/': #ifdef PATHNAME_UNIX_UNC if (to_ptr > resolved_path+2) #endif /* '//' is simplified to '/' : */ to_ptr--; break; case '.': { var char* last_subdir_ptr = &last_subdir_end[-1]; if (to_ptr > resolved_path+2) { if (*last_subdir_ptr == '.') { if ((to_ptr > resolved_path+4) && (*--last_subdir_ptr == '/')) { /* last subdir was '/../' Therefore remove the subdir in front of it: */ while ((last_subdir_ptr > resolved_path) && !(*--last_subdir_ptr == '/')); to_ptr = last_subdir_ptr+1; } } else if (*last_subdir_ptr == '/') { /* last subdir was '/./' remove: */ to_ptr = last_subdir_end; } } } break; default: /* after a normal subdir */ #ifdef HAVE_READLINK /* read symbolic link: */ to_ptr[-1]=0; /* replace '/' with 0 */ #ifdef UNIX_CYGWIN32 /* readlink() does not work right on NFS mounted directories (it returns -1,ENOENT or -1,EIO). So check for a directory first. */ var struct stat statbuf; if (lstat(resolved_path,&statbuf) < 0) return NULL; /* error */ if (S_ISDIR(statbuf.st_mode)) { /* directory, not a symbolic link */ to_ptr[-1] = '/'; /* insert the '/' again */ } else if (!S_ISLNK(statbuf.st_mode)) { /* something else, but not a directory or symbolic link. */ errno = ENOTDIR; return NULL; } else #endif { var int linklen = readlink(resolved_path,mypath,sizeof(mypath)-1); if (linklen >=0) { /* was a symbolic link */ if (++symlinkcount > MAXSYMLINKS) { errno = ELOOP_VALUE; return NULL; } { /* append the still to be resolved part of path to the link-content: */ var char* mypath_ptr = &mypath[linklen]; /* here is room */ var char* mypath_limit = &mypath[MAXPATHLEN-1]; /* up to here */ if (mypath_ptr < mypath_limit) { *mypath_ptr++ = '/'; } /* first, append a '/' */ /* then the rest: */ while ((mypath_ptr <= mypath_limit) && (*mypath_ptr = *from_ptr++)) { mypath_ptr++; } *mypath_ptr = 0; /* and conclude wit 0 */ } /* this replaces resp. completes the path: */ if (mypath[0] == '/') { /* replaces the path: */ from_ptr = &mypath[0]; to_ptr = resolved_path; while ((*to_ptr++ = *from_ptr++)); from_ptr = resolved_path; } else { /* completes the path: disrcard link-name. Therefore search for the last '/': */ { var char* ptr = &to_ptr[-1]; while ((ptr > resolved_path) && !(ptr[-1] == '/')) { ptr--; } from_ptr = ptr; } { var char* mypath_ptr = &mypath[0]; to_ptr = from_ptr; while ((to_ptr <= resolved_limit) && (*to_ptr++ = *mypath_ptr++)); } } to_ptr = from_ptr; } else { #if defined(UNIX_IRIX) if ((errno == EINVAL) || (errno == ENXIO)) #elif defined(UNIX_CYGWIN32) if ((errno == EINVAL) || (errno == EACCES)) #else if (errno == EINVAL) #endif /* no symbolic link */ to_ptr[-1] = '/'; /* insert the '/' again */ else return NULL; /* error */ } } #endif break; } } } /* go for the next subdir */ /* discard a '/' at the tail: */ if ((to_ptr[-1] == '/') #ifdef PATHNAME_UNIX_UNC && (to_ptr > resolved_path+2) #else && (to_ptr > resolved_path+1) #endif ) to_ptr--; to_ptr[0] = 0; /* conclude with 0 */ return resolved_path; /* finished */ } #endif /* Creates a new subdirectory. make_directory(pathstring); > pathstring: result of shorter_directory(...) > STACK_0: pathname */ local maygc inline void make_directory (char* pathstring) { #if defined(UNIX) begin_blocking_system_call(); if (mkdir(pathstring,0777)) { /* create sub-directory */ end_blocking_system_call(); OS_file_error(STACK_0); } end_blocking_system_call(); #elif defined(WIN32_NATIVE) begin_blocking_system_call(); if (! CreateDirectory(pathstring,NULL) ) { /* create sub-directory */ end_blocking_system_call(); OS_file_error(STACK_0); } end_blocking_system_call(); #else #error make_directory is not defined #endif } /* Deletes a subdirectory. delete_directory(pathstring); > pathstring: result of shorter_directory(...) > STACK_0: pathname */ local maygc inline void delete_directory (char* pathstring) { #if defined(UNIX) begin_blocking_system_call(); /* delete sub-directory - which might be a symlink! */ if (rmdir(pathstring) && errno == ENOTDIR && unlink(pathstring)) { end_blocking_system_call(); OS_file_error(STACK_0); } end_blocking_system_call(); #elif defined(WIN32_NATIVE) begin_blocking_system_call(); if (! RemoveDirectory(pathstring) ) { /* delete sub-directory */ end_blocking_system_call(); OS_file_error(STACK_0); } end_blocking_system_call(); #else #error delete_directory is not defined #endif } #ifdef WIN32_NATIVE /* Changes the operating system's current directory. change_directory(pathstring); > pathstring: directory, ASCIZ-String > STACK_0: pathname */ local maygc inline void change_current_directory (char* pathstring) { begin_blocking_system_call(); if (!SetCurrentDirectory(pathstring)) { end_blocking_system_call(); OS_file_error(STACK_0); } end_blocking_system_call(); } #endif /* Delete a file. delete_existing_file(pathstring); It is known that the file exists. > pathstring: file name, ASCIZ-String > STACK_0: pathname */ local maygc inline void delete_existing_file (char* pathstring) { #if defined(UNIX) begin_blocking_system_call(); if (!( unlink(pathstring) ==0)) { end_blocking_system_call(); OS_file_error(STACK_0); } end_blocking_system_call(); #elif defined(WIN32_NATIVE) begin_blocking_system_call(); if (! DeleteFile(pathstring) ) { end_blocking_system_call(); OS_file_error(STACK_0); } end_blocking_system_call(); #else #error delete_existing_file is not defined #endif } #ifdef WIN32_NATIVE #define WIN32_ERROR_NOT_FOUND (GetLastError()==ERROR_FILE_NOT_FOUND || GetLastError()==ERROR_PATH_NOT_FOUND || GetLastError()==ERROR_BAD_NETPATH) #endif /* Delete a file. delete_file_if_exists(pathstring); No error is signaled if the file does not exist. > pathstring: file name, ASCIZ-String > STACK_0: pathname < result: whether the file existed */ local maygc inline bool delete_file_if_exists (char* pathstring) { var bool exists = true; #if defined(UNIX) begin_blocking_system_call(); if (!( unlink(pathstring) ==0)) { if (!(errno==ENOENT)) { /* not found -> OK */ end_blocking_system_call(); OS_file_error(STACK_0); /* report other error */ } exists = false; } end_blocking_system_call(); #elif defined(WIN32_NATIVE) begin_blocking_system_call(); if (! DeleteFile(pathstring) ) { if (!WIN32_ERROR_NOT_FOUND) { end_blocking_system_call(); OS_file_error(STACK_0); } exists = false; } end_blocking_system_call(); #else #error delete_file_if_exists is not defined #endif return exists; } local maygc bool delete_file_if_exists_obj (object namestring) { bool ret; with_sstring_0(namestring,O(pathname_encoding),namestring_asciz, { ret = delete_file_if_exists(namestring_asciz); }); return ret; } /* Delete a file being the target of a subsequent rename. delete_file_before_rename(pathstring); No error is signaled if the file does not exist. > pathstring: file name, ASCIZ-String > STACK_0: pathname */ local maygc inline void delete_file_before_rename (char* pathstring) { #if !defined(UNIX) /* rename() on Unix does it automatically */ delete_file_if_exists(pathstring); #endif } #if defined(WIN32_NATIVE) /* The default woe32 behavior is to barf if the destination exists. Use MoveFileEx/MOVEFILE_REPLACE_EXISTING to emulate the Unix behavior of atomic overwrite. */ #if defined(MOVEFILE_REPLACE_EXISTING) static HMODULE k32 = (HMODULE)-1; typedef BOOL (WINAPI * fMoveFileEx_t) (LPCSTR src,LPCSTR dst,DWORD flags); static fMoveFileEx_t move_file_ex = (fMoveFileEx_t)-1; local BOOL move_file (char* src, char* dst) { if (k32 == (HMODULE)-1) k32 = LoadLibrary("kernel32.dll"); if (k32 && move_file_ex == (fMoveFileEx_t)-1) move_file_ex = (fMoveFileEx_t)GetProcAddress(k32,"MoveFileExA"); if (k32 && move_file_ex) return move_file_ex(src,dst,MOVEFILE_REPLACE_EXISTING); else return MoveFile(src,dst); } #else #define move_file MoveFile #endif #endif /* Rename a file. rename_existing_file(old_pathstring,new_pathstring); It is known that the old_pathstring exists. On platforms except UNIX, it is known that new_pathstring does not exist. > old_pathstring: old file name, ASCIZ-String > new_pathstring: new file name, ASCIZ-String > STACK_0: pathname */ local maygc inline void rename_existing_file (char* old_pathstring, char* new_pathstring) { #if defined(UNIX) begin_blocking_system_call(); if ( rename(old_pathstring,new_pathstring) <0) { /* rename file */ end_blocking_system_call(); OS_file_error(STACK_0); /* report error */ } end_blocking_system_call(); #elif defined(WIN32_NATIVE) begin_blocking_system_call(); if (!move_file(old_pathstring,new_pathstring) ) { end_blocking_system_call(); OS_file_error(STACK_0); } end_blocking_system_call(); #else #error rename_existing_file is not defined #endif } local maygc void rename_existing_path (object old_pathstring, object new_pathstring) { with_sstring_0(old_pathstring,O(pathname_encoding),oldnamestring_asciz, { with_sstring_0(new_pathstring,O(pathname_encoding),newnamestring_asciz, { rename_existing_file(oldnamestring_asciz,newnamestring_asciz); }); }); } /* ======================================================================== P A T H N A M E S All simple-strings occurring in pathnames are in fact normal-simple-strings. #ifdef PATHNAME_UNIX Components: HOST always NIL DEVICE always NIL DIRECTORY (Startpoint . Subdirs) whereas Startpoint = :RELATIVE | :ABSOLUTE Subdirs = () | (subdir . Subdirs) subdir = :WILD-INFERIORS (means "**" or "...", all subdirectories) or subdir = Simple-String, poss. with wildcard-character ? and * NAME NIL or Simple-String, poss. with wildcard-character ? and * (also :WILD on input) TYPE NIL or Simple-String, poss. with wildcard-character ? and * (also :WILD on input) VERSION always NIL (also :WILD or :NEWEST on input) A UNIX-filename is split in Name and Type as follows: if there is no '.' in Filename: Name = everything, Type = NIL, if there is '.' in Filename: Name = everything in front of it, Type = everything behind the last '.' . If a pathname must be completely specified (no wildcards), :WILD, :WILD-INFERIORS are not allowed, no wildcard-characters in the Strings, at NAME poss. also not NIL. External Notation: server:/sub1.typ/sub2.typ/name.typ with Defaults: /sub1.typ/sub2.typ/name.typ or name.typ or /sub1.typ/ ** /sub3.typ/x*.lisp (without Spaces!) or similar. If NAME starts with a dot, (parse-namestring (namestring pathname)) will not be the same as pathname. #endif #ifdef PATHNAME_WIN32 Components: HOST NIL or Simple-String (Wildcard-Characters are without meaning) DEVICE NIL or :WILD or "A"|...|"Z" DIRECTORY (Startpoint . Subdirs) whereas Startpoint = :RELATIVE | :ABSOLUTE Subdirs = () | (subdir . Subdirs) subdir = :WILD-INFERIORS (means "**" or "...", all Subdirectories) or subdir = Simple-String, poss. with Wildcard-Character ? and * NAME NIL or Simple-String, poss. with Wildcard-Character ? and * (also :WILD on input) TYPE NIL or Simple-String, poss. with Wildcard-Character ? and * (also :WILD on input) VERSION always NIL (also :WILD or :NEWEST on input) If HOST is non-NIL, DEVICE must be NIL. A WIN32-Filename is split into Name and Type as follows: if there is no '.' in Filename: Name = everything, Type = NIL, if there is a '.' in Filename: Name = everything in front of, Type = everything behind the last '.' . If a Pathname must be completely specified (no Wildcards), then :WILD, :WILD-INFERIORS are not allowed, no Wildcard-Characters in the Strings, at NAME poss. also not NIL. External notation: A:\sub1.typ\sub2.typ\name.typ with Defaults: \sub1.typ\sub2.typ\name.typ or name.typ or *:\sub1.typ\**\sub3.typ\x*.lisp or similar. Instead of '\' - traditionally on DOS - also '/' is allowed. If HOST is non-NIL and the DIRECTORY's Startpoint is not :ABSOLUTE, (parse-namestring (namestring pathname)) will not be the same as pathname. #endif Components of Logical Pathnames: HOST Simple-String or NIL DEVICE always NIL DIRECTORY (Startpoint . Subdirs) whereas Startpoint = :RELATIVE | :ABSOLUTE Subdirs = () | (subdir . Subdirs) subdir = :WILD-INFERIORS (means "**", all Subdirectories) or subdir = :WILD (means "*") or subdir = Simple-String, poss. with Wildcard-Character * NAME NIL or :WILD (means "*") or Simple-String, poss. with Wildcard-Character * TYPE NIL or :WILD (means "*") or Simple-String, poss. with Wildcard-Character * VERSION NIL or :NEWEST or :WILD or Integer External Notation: see CLtl2 p. 628-629. access functions without case transforms: xpathname_host(logical,pathname) xpathname_device(logical,pathname) xpathname_directory(logical,pathname) xpathname_name(logical,pathname) xpathname_type(logical,pathname) xpathname_version(logical,pathname) > pathname: pathname or logical pathname > logical: flag = logpathnamep(pathname) < result: the value of the requested component pathname_*_maybe return the appropriate slot seen from the point of view of the underlying physical file system, therefore, ever though pathname has the slot version (for ANSI compliance reasons), pathname_version_maybe() returns NIL */ #if HAS_HOST #define pathname_host_maybe(obj) (object)ThePathname(obj)->pathname_host #else #define pathname_host_maybe(obj) (unused(obj), NIL) #endif #if HAS_DEVICE #define pathname_device_maybe(obj) (object)ThePathname(obj)->pathname_device #else #define pathname_device_maybe(obj) (unused(obj), NIL) #endif #if HAS_VERSION #define pathname_version_maybe(obj) (object)ThePathname(obj)->pathname_version #else #define pathname_version_maybe(obj) (unused(obj), NIL) #endif #define xpathname_host(logical,pathname) \ (logical ? (object)TheLogpathname(pathname)->pathname_host : \ pathname_host_maybe(pathname)) #define xpathname_device(logical,pathname) \ (logical ? NIL : pathname_device_maybe(pathname)) #define xpathname_directory(logical,pathname) \ (logical ? (object)TheLogpathname(pathname)->pathname_directory : \ (object)ThePathname(pathname)->pathname_directory) #define xpathname_name(logical,pathname) \ (logical ? (object)TheLogpathname(pathname)->pathname_name : \ (object)ThePathname(pathname)->pathname_name) #define xpathname_type(logical,pathname) \ (logical ? (object)TheLogpathname(pathname)->pathname_type : \ (object)ThePathname(pathname)->pathname_type) #define xpathname_version(logical,pathname) \ (logical ? (object)TheLogpathname(pathname)->pathname_version : \ (object)ThePathname(pathname)->pathname_version) #define SUBST_RECURSE(atom_form,self_call) \ if (atomp(obj)) return atom_form; \ check_STACK(); check_SP(); \ pushSTACK(obj); \ { /* recursive call for CAR: */ \ object new_car = self_call(Car(obj)); \ pushSTACK(new_car); \ } \ { /* recursive call for CDR: */ \ object new_cdr = self_call(Cdr(STACK_1)); \ if (eq(new_cdr,Cdr(STACK_1)) && eq(STACK_0,Car(STACK_1))) { \ obj = STACK_1; skipSTACK(2); return obj; \ } else { /* (CONS new_car new_cdr) */ \ STACK_1 = new_cdr; \ {object new_cons = allocate_cons(); \ Car(new_cons) = popSTACK(); Cdr(new_cons) = popSTACK(); \ return new_cons; \ }} \ } /* Converts capital-/small letters between :LOCAL and :COMMON . common_case(string) > string: Normal-Simple-String or Symbol/Number < result: converted Normal-Simple-String or the same Symbol/Number can trigger GC Operating System with preference for small letters or Capitalize */ local maygc object common_case (object string) { if (!simple_string_p(string)) return string; var uintL len = Sstring_length(string); /* Search, if capital- or small letters (or both) occur: */ var bool all_upper = true; var bool all_lower = true; if (len > 0) { var object storage = string; sstring_un_realloc(storage); SstringDispatch(storage,X, { var const cintX* ptr = &((SstringX)TheVarobject(storage))->data[0]; var uintL count; dotimespL(count,len, { var chart ch = as_chart(*ptr++); if (!chareq(ch,up_case(ch))) all_upper = false; if (!chareq(ch,down_case(ch))) all_lower = false; if (!all_upper && !all_lower) break; }); }); } if (all_upper == all_lower) /* all_upper = all_lower = true: Nothing to convert. all_upper = all_lower = false: "Mixed case represents itself." */ return string; if (all_upper) /* all_upper = true, all_lower = false: STRING-DOWNCASE */ return string_downcase(string); else /* all_upper = false, all_lower = true: STRING-UPCASE */ return string_upcase(string); } /* the same, recursive like with SUBST: */ local object subst_common_case (object obj) { SUBST_RECURSE(common_case(obj),subst_common_case); } local bool legal_logical_word_char (chart ch) { ch = up_case(ch); var cint c = as_cint(ch); return (((c >= 'A') && (c <= 'Z')) || ((c >= '0') && (c <= '9')) || (c == '-')); } #if HAS_HOST /* UP: Determines, if a character is allowed as character in the host-part of a namestring. legal_hostchar(ch) > chart ch: Character-Code < result: true if allowed, else false NB: legal_logical_word_char(ch) implies legal_hostchar(ch). */ local bool legal_hostchar (chart ch) { #if defined(PATHNAME_WIN32) { /* This is just a guess. I do not know which characters are allowed in Windows host names. */ var cint c = as_cint(ch); return ((c >= ' ') && (c <= '~') && (c != '"') && (c != '/') && (c != ':') && (c != '<') && (c != '>') && (c != '\\')); } #else return alphanumericp(ch) || chareq(ch,ascii('-')); #endif } /* UP: check an optional HOST argument test_optional_host(host,convert) > host: Host-Argument > convert: Flag, if case-conversion is undesired < result: valid host-component can trigger GC */ local maygc object test_optional_host (object host, bool convert) { if (!boundp(host) || eq(host,S(Kunspecific))) return NIL; if (nullp(host)) goto OK; /* NIL is OK */ /* Else, host must be a String, whose characters are alphanumeric: */ if (!stringp(host)) { pushSTACK(host); /* TYPE-ERROR slot DATUM */ pushSTACK(O(type_host)); /* TYPE-ERROR slot EXPECTED-TYPE */ pushSTACK(host); pushSTACK(TheSubr(subr_self)->name); error(type_error,GETTEXT("~S: host should be NIL or a string, not ~S")); } host = coerce_normal_ss(host); /* as Normal-Simple-String */ if (convert) host = common_case(host); { var uintL len = Sstring_length(host); if (len > 0) { var const chart* charptr = &TheSnstring(host)->data[0]; dotimespL(len,len, { var chart ch = *charptr++; if (!legal_hostchar(ch)) goto badhost; }); } } OK: return host; badhost: pushSTACK(host); pushSTACK(TheSubr(subr_self)->name); error(parse_error,GETTEXT("~S: illegal hostname ~S")); } #else /* UP: check an optional HOST argument test_optional_host(host) > host: Host-Argument < result: valid host-component can trigger GC */ local maygc object test_optional_host (object host) { if (!boundp(host) || eq(host,S(Kunspecific))) return NIL; /* not specified -> NIL */ if (nullp(host)) goto OK; /* NIL is OK */ /* Else, host must be a String, whose characters are alphanumeric: */ if (!stringp(host)) { pushSTACK(host); /* TYPE-ERROR slot DATUM */ pushSTACK(O(type_host)); /* TYPE-ERROR slot EXPECTED-TYPE */ pushSTACK(host); pushSTACK(TheSubr(subr_self)->name); error(type_error,GETTEXT("~S: host should be NIL or a string, not ~S")); } host = coerce_normal_ss(host); /* as Normal-Simple-String */ { var uintL len = Sstring_length(host); if (len > 0) { var object storage = host; sstring_un_realloc(storage); SstringDispatch(storage,X, { var const cintX* ptr = &((SstringX)TheVarobject(storage))->data[0]; dotimespL(len,len, { var chart ch = as_chart(*ptr++); if (!legal_logical_word_char(ch)) goto badhost; }); }); } } OK: return host; badhost: pushSTACK(host); pushSTACK(TheSubr(subr_self)->name); error(parse_error,GETTEXT("~S: illegal hostname ~S")); } #endif /* Determines, if two characters count as equal characters in pathnames. equal_pathchar(ch1,ch2) > chart ch1,ch2: Character-Codes < result: true if equal, else false */ #if !defined(PATHNAME_WIN32) #define equal_pathchar(ch1,ch2) chareq(ch1,ch2) #else /* defined(PATHNAME_WIN32) */ /* Case-insensitive, but normally without conversion */ #define equal_pathchar(ch1,ch2) chareq(up_case(ch1),up_case(ch2)) #endif /* UP: check whether a given byte is a valid element of NAME or TYPE component in a Namestring legal_namebyte(ch) > uintB: byte < return: true if valid, else false */ local inline bool legal_namebyte (uintB ch) { #ifdef VALID_FILENAME_CHAR /* defined in config.h */ return VALID_FILENAME_CHAR || (ch=='*') || (ch=='?'); #else #ifdef PATHNAME_UNIX return ((ch>=' ') && (ch<='~') && !(ch=='/')); #endif #ifdef PATHNAME_WIN32 return ((ch >= 1) && (ch <= 127) && (ch != '"') /*&& (ch != '*')*/ && (ch != '/') && (ch != ':') && (ch != '<') && (ch != '>') /*&& (ch != '?')*/ && (ch != '\\')) || (ch == 131) || (ch >= 160); #endif #endif } /* UP: check whether the character is a valid element of NAME or TYPE component in a Namestring legal_namechar(ch) > chart ch: character-code < return: true if valid, else false */ local bool legal_namechar (chart ch) { #ifdef ENABLE_UNICODE var uintB buf[4]; /* are there characters longer than 4 bytes?! */ var uintL char_len = cslen(O(pathname_encoding),&ch,1); cstombs(O(pathname_encoding),&ch,1,buf,char_len); while (char_len > 0) { char_len--; if (!legal_namebyte(buf[char_len])) return false; } return true; #else return legal_namebyte(as_cint(ch)); #endif } /* Determines, if a character is a wildcard for a single character. singlewild_char_p(ch) > chart ch: Character-Code < result: true if yes, else false */ #define singlewild_char_p(ch) chareq(ch,ascii('?')) #define multiwild_char_p(ch) chareq(ch,ascii('*')) #define wild_char_p(ch) (multiwild_char_p(ch) || singlewild_char_p(ch)) /* Converts an object into a pathname. */ local object coerce_xpathname (object obj); /* later */ /* Converts an object into a non-logical pathname. */ local object coerce_pathname (object obj); /* later */ /* Returns a default-pathname. */ local object defaults_pathname (void); /* later */ /* checks a default-pathname. test_default_pathname(defaults) > defaults: defaults-argument < result: value of the defaults-argument, a pathname can trigger GC */ local maygc object test_default_pathname (object defaults) { if (missingp(defaults)) /* not specified -> take value of *DEFAULT-PATHNAME-DEFAULTS* : */ return defaults_pathname(); else /* specified -> turn into a pathname: */ return coerce_xpathname(defaults); } /* : "for functions that manipulate or inquire about files in the file system, the pathname argument to such a function is merged with *DEFAULT-PATHNAME-DEFAULTS* before accessing the file system" When pathname comes from a file stream, this is NOT done because that pathname has already been "transfered from the world of the abstract Lisp pathname algebra to the real world of computer file system" Another option is to ensure that all slots of *DEFAULT-PATHNAME-DEFAULTS* are non-NIL (use :UNSPECIFIC instead): then merge_defaults() becomes an idempotent operation -- assuming trivial directory or non-ANSI merging. merge_defaults(pathname) > pathname: a pathname < result: a pathname derived from it, with *DEFAULT-PATHNAME-DEFAULTS* merged in. can trigger GC */ local maygc object merge_defaults (object pathname) { pushSTACK(pathname); pushSTACK(defaults_pathname()); funcall(L(merge_pathnames),2); return value1; } /* error-message because of illegal pathname-argument. error_pathname_designator(thing); ( error_... ) > thing: (erroneous) argument */ local _Noreturn void error_pathname_designator (object thing) { pushSTACK(thing); /* TYPE-ERROR slot DATUM */ pushSTACK(O(type_designator_pathname)); /* TYPE-ERROR slot EXPECTED-TYPE */ pushSTACK(O(type_designator_pathname)); pushSTACK(thing); pushSTACK(TheSubr(subr_self)->name); error(type_error,GETTEXT("~S: Argument ~S should be a pathname designator ~S")); } /* Tracks a chain of Synonym-Streams, so long as a File-Stream is reached. as_file_stream(stream) > stream: Builtin-Stream < stream: File-Stream */ local object as_file_stream (object stream) { var object s = stream; while (1) { if (TheStream(s)->strmtype == strmtype_file) return s; if (!(TheStream(s)->strmtype == strmtype_synonym)) break; s = Symbol_value(TheStream(stream)->strm_synonym_symbol); if (!builtin_stream_p(s)) break; } error_pathname_designator(stream); } /* Signal an error if a file-stream does not have a file-name associated with it. test_file_stream_named(stream) > stream: File-Stream */ #define test_file_stream_named(stream) \ do { if (nullp(TheStream(stream)->strm_file_truename)) \ error_file_stream_unnamed(stream); \ } while(0) local _Noreturn void error_file_stream_unnamed (object stream) { pushSTACK(stream); /* FILE-ERROR slot PATHNAME */ pushSTACK(stream); pushSTACK(TheSubr(subr_self)->name); error(file_error,GETTEXT("~S: Filename for ~S is unknown")); } #if defined(UNIX) #define slash '/' #elif defined(WIN32_NATIVE) #define slash '\\' #else #error slash is not defined #endif /* physical slash */ #ifdef PATHNAME_WIN32 #define pslashp(c) (chareq(c,ascii('\\')) || chareq(c,ascii('/'))) #define cpslashp(c) ((c) == '\\' || (c) == '/') #else /* PATHNAME_UNIX */ #define pslashp(c) chareq(c,ascii(slash)) #define cpslashp(c) ((c) == slash) #endif #define colonp(c) chareq(c,ascii(':')) #define dotp(c) chareq(c,ascii('.')) /* UP: add a character to an ASCII string and return as a Lisp string can trigger GC */ #ifdef ENABLE_UNICODE local /*maygc*/ object asciz_add_char (const char* chars, uintL len, char ch, object encoding) #else #define asciz_add_char(chars,len,ch,encoding) asciz_add_char_(chars,len,ch) local /*maygc*/ object asciz_add_char_ (const char* chars, uintL len, char ch) #endif { #ifdef ENABLE_UNICODE GCTRIGGER1(encoding); #else GCTRIGGER(); #endif var DYNAMIC_ARRAY(buf,char,len+1); begin_system_call(); memcpy(buf,chars,len); end_system_call(); buf[len] = ch; var object s = n_char_to_string(buf,len+1,encoding); FREE_DYNAMIC_ARRAY(buf); return s; } /* UP: Converts a Unix-Directory-Specification into a pathname. asciz_dir_to_pathname(path,encoding) > const char* path: path as ASCIZ-String > encoding: Encoding < result: as a pathname without name and type can trigger GC */ #ifdef ENABLE_UNICODE local /*maygc*/ object asciz_dir_to_pathname(const char* path, object encoding) #else #define asciz_dir_to_pathname(path,encoding) asciz_dir_to_pathname_(path) local /*maygc*/ object asciz_dir_to_pathname_(const char* path) #endif { #ifdef ENABLE_UNICODE GCTRIGGER1(encoding); #else GCTRIGGER(); #endif var object pathname; var uintL len = asciz_length(path); /* string length */ /* if the String does not end with a '/' already, a '/' is added: */ if ((len>0) && cpslashp(path[len-1])) pathname = n_char_to_string(path,len,encoding); else pathname = asciz_add_char(path,len,slash,encoding); /* and convert into a pathname: */ return coerce_pathname(pathname); } /* Type for PARSE-NAMESTRING: State while the string is being parsed character by character. */ typedef struct { uintL index; /* index (incl. offset) */ object FNindex; /* index as a fixnum */ uintL count; /* number of the remaining characters */ } zustand; /* "state" */ /* Skip s characters. */ #define Z_SHIFT(z,s) \ do { (z).index += (s); (z).FNindex = fixnum_inc((z).FNindex,(s)); (z).count -= (s); } while(0) /* Tests whether the current character at Z satisfies pred. */ #define Z_AT_SLASH(z,pred,st) \ (((z).count != 0) && pred(schar(st,(z).index))) /* Replace this string with a substring. */ #define Z_SUB(z,s) ((s) = subsstring((s),(z).index,(z).index+(z).count), (z).index = 0) /* Parsing of logical pathnames. */ /* separator between subdirs */ #define semicolonp(c) (chareq(c,ascii(';'))) #define lslashp(c) semicolonp(c) /* Copy LEN characters in string ORIG starting at ORIG_OFFSET to string DEST, starting at DEST_OFFSET, up-casing all characters. LEN is > 0. */ local void copy_upcase (object dest, uintL dest_offset, object orig, uintL orig_offset, uintL len) { sstring_un_realloc(orig); SstringDispatch(orig,X1, { var cintX1* ptr1 = &((SstringX1)TheVarobject(orig))->data[orig_offset]; sstring_un_realloc(dest); SstringDispatch(dest,X2, { var cintX2* ptr2 = &((SstringX2)TheVarobject(dest))->data[dest_offset]; dotimespL(len,len, { *ptr2++ = as_cint(up_case(as_chart(*ptr1++))); }); }); }); } /* Parses the name/type/version part (if subdirp=false) or a subdir part (if subdirp=true) of a logical pathname. parse_logical_word(&z,subdirp) > STACK_2: storage vector, a normal-simple-string > zustand z: start state < zustand z: updated < result: a normal-simple-string or :WILD or :WILD-INFERIORS or NIL can trigger GC */ local maygc object parse_logical_word (zustand* z, bool subdirp) { ASSERT(sstring_normal_p(STACK_2)); var zustand startz = *z; /* start-state */ var chart ch; /* Is there a sequence of alphanumeric characters or '*', no two '*' adjacent (except "**", if subdirp), and, if subdirp, a ';' ? */ var bool last_was_star = false; var bool seen_starstar = false; while (z->count) { ch = schar(STACK_2,z->index); /* next character */ if (!legal_logical_word_char(ch)) { if (multiwild_char_p(ch)) { if (last_was_star) { if (subdirp && (z->index - startz.index == 1)) seen_starstar = true; else break; /* adjacent '*' are forbidden */ } else last_was_star = true; } else break; } /* skip character: */ Z_SHIFT(*z,1); } var uintL len = z->index - startz.index; if (subdirp) { if ((z->count == 0) || !lslashp(ch)) { *z = startz; return NIL; /* no ';' -> no subdir */ } /* skip character ';' : */ Z_SHIFT(*z,1); } if (len==0) return NIL; else if ((len==1) && multiwild_char_p(schar(STACK_2,startz.index))) return S(Kwild); else if ((len==2) && seen_starstar) return S(Kwild_inferiors); else { var object result = allocate_string(len); copy_upcase(result,0,STACK_2,startz.index,len); return result; } } /* Test whether a string is a digit sequence. all_digits(string) > string: a normal-simple-string < true if the string consists entirely of digits, else false */ local bool all_digits (object string) { var uintL len = Sstring_length(string); if (len > 0) { var object storage = string; sstring_un_realloc(storage); SstringDispatch(storage,X, { var const cintX* ptr = &((SstringX)TheVarobject(storage))->data[0]; dotimespL(len,len, { var cintX c = *ptr++; if (!((c >= '0') && (c <= '9'))) return false; }); }); } return true; } /* test whether the string contains semicolons (and the rest being valid!), thus appearing to be a logical pathname > string: storage vector, a normal-simple-string < result: true if the string contains semicolons */ local bool looks_logical_p (object string) { var uintL len = Sstring_length(string); var bool logical_p = false; if (len > 0) { SstringDispatch(string,X, { var const cintX* charptr = &((SstringX)TheVarobject(string))->data[0]; do { var chart ch = up_case(as_chart(*charptr++)); if (!legal_logical_word_char(ch)) { if (semicolonp(ch)) logical_p = true; else if (!colonp(ch) && !dotp(ch) && !multiwild_char_p(ch)) return false; /* invalid logical pathname char */ } } while (--len); }); } return logical_p; } /* Attempt to parse a logical host name string, starting at a given state. parse_logical_host_prefix(&z,string) > string: storage vector, a normal-simple-string > state z: start state < state z: updated to point past the colon after the logical host < result: logical host, or NIL can trigger GC */ local maygc object parse_logical_host_prefix (zustand* zp, object string) { ASSERT(sstring_normal_p(string)); var object host; var uintL startindex = zp->index; var chart ch; /* a sequence of alphanumeric characters and then ':' */ while (1) { if (zp->count==0) return NIL; /* string already ended -> no host */ ch = schar(string,zp->index); /* next character */ if (!legal_logical_word_char(ch)) break; /* go past alphanumeric character: */ Z_SHIFT(*zp,1); } if (!colonp(ch)) return NIL; /* no ':' -> no host */ { /* make host-string: */ var uintL len = zp->index - startindex; pushSTACK(string); host = allocate_string(len); string = popSTACK(); /* and fill it: */ if (len > 0) copy_upcase(host,0,string,startindex,len); } /* skip ':' */ Z_SHIFT(*zp,1); return host; } /* CLHS for MAKE-PATHNAME: "Whenever a pathname is constructed the components may be canonicalized if appropriate." simplify the subdirectory list strings are coerced to normal simple strings the list should start with a valid startpoint (not checked!) > dir : pathname directory list < dir : the same list, destructively modified: ".." or :back ==> :up ... x "foo" :up y ... ==> ... x y ... ... x ""/"." y ... ==> ... x y ... :absolute :up ==> error :wild-inferiors :up ==> error can trigger GC */ local maygc object simplify_directory (object dir) { if (!consp(dir)) return dir; DOUT("simplify_directory:< ",dir); pushSTACK(dir); { /* kill ".", ".."->:up, coerce to normal simple strings */ var object curr = dir; while (consp(curr) && consp(Cdr(curr))) { var object next = Cdr(curr); var object here = Car(next); if (stringp(here)) { if (vector_length(here)==0 || string_equal(here,O(dot_string))) { Cdr(curr) = Cdr(next); /* drop "." and "" */ continue; } else if (string_equal(here,O(wild_string))) { Car(next) = S(Kwild); curr = next; continue; } else if (string_equal(here,O(wildwild_string))) { Car(next) = S(Kwild_inferiors); curr = next; continue; } else if (!consp(next)) break; if (string_equal(here,O(dotdot_string))) Car(next) = S(Kup); /* ".." --> :UP */ else { /* coerce to normal */ pushSTACK(next); var object element = coerce_normal_ss(here); next = popSTACK(); Car(next) = element; } } else if (eq(here,S(Kback))) Car(next) = S(Kup); /* :BACK --> :UP (ANSI) */ curr = next; } } dir = popSTACK(); /* collapse "foo/../" (quadratic algorithm) */ var bool changed_p; do { changed_p = false; var object curr = dir; while (consp(curr) && consp(Cdr(curr))) { var object next = Cdr(curr); var object here = Car(next); var object next_next = Cdr(next); if (consp(next_next)) { var object next_here = Car(next_next); /* :BACK has been converted to :UP */ if (!eq(here,S(Kup)) && eq(next_here,S(Kup))) { if (eq(here,S(Kwild_inferiors)) || eq(here,S(Kabsolute))) { goto error_absolute_up; } else { Cdr(curr) = Cdr(next_next); /* collapse ( "foo" :UP ) */ changed_p = true; } } else curr = next; } else curr = next; } } while (changed_p); if (eq(Car(dir),S(Kabsolute)) && consp(Cdr(dir))) if (eq(Car(Cdr(dir)),S(Kup))) goto error_absolute_up; DOUT("simplify_directory:> ",dir); return dir; error_absolute_up: /* */ pushSTACK(O(empty_string)); /* FILE-ERROR slot PATHNAME */ pushSTACK(dir); pushSTACK(S(Kdirectory)); pushSTACK(TheSubr(subr_self)->name); error(file_error,GETTEXT("~S: Illegal ~S argument ~S")); } /* Parses a logical pathname. parse_logical_pathnamestring(z) > STACK_1: storage vector, a normal-simple-string > STACK_0: freshly allocated logical pathname > state z: start state < STACK_0: same logical pathname, filled < result: number of remaining characters can trigger GC */ local maygc uintL parse_logical_pathnamestring (zustand z) { DOUT("parse_logical_pathnamestring:<0",STACK_0); DOUT("parse_logical_pathnamestring:<1",STACK_1); { /* parse Host-Specification: */ var zustand startz = z; var object host = parse_logical_host_prefix(&z,STACK_1); if (nullp(host)) { z = startz; /* back to the start */ host = STACK_(3+2); /* Default-Host */ } else { /* enter host: */ TheLogpathname(STACK_0)->pathname_host = host; } } { /* enter Directory-Start: */ var object new_cons = allocate_cons(); /* new Cons for Startpoint */ TheLogpathname(STACK_0)->pathname_directory = new_cons; pushSTACK(new_cons); /* new (last (pathname-directory Pathname)) */ } /* stack layout: data-vector, pathname, (last (pathname-directory Pathname)). parse subdirectories: If ";" is the first char, it is turned into :RELATIVE (otherwise :ABSOLUTE) as the first subdir for a reason that escapes me, ANSI CL specifies that "foo:;bar;baz.zot" is a :RELATIVE logical pathname while "foo:/bar/baz.zot" is an :ABSOLUTE physical pathname. see "19.3.1.1.3 The Directory part of a Logical Pathname Namestring" http://www.lisp.org/HyperSpec/Body/sec_19-3-1-1-3.html */ if (Z_AT_SLASH(z,lslashp,STACK_2)) { Z_SHIFT(z,1); Car(STACK_0) = S(Krelative); } else { Car(STACK_0) = S(Kabsolute); } while (1) { /* try to parse the next subdir */ var object subdir = parse_logical_word(&z,true); if (nullp(subdir)) break; /* lengthen (pathname-directory pathname) by Subdir: */ pushSTACK(subdir); var object new_cons = allocate_cons(); /* new Cons */ Car(new_cons) = popSTACK(); /* = (cons subdir NIL) */ Cdr(STACK_0) = new_cons; /* lengthens (pathname-directory Pathname) */ STACK_0 = new_cons; /* new (last (pathname-directory Pathname)) */ } { /* parse Name: */ var object name = parse_logical_word(&z,false); TheLogpathname(STACK_1)->pathname_name = name; if ((z.count > 0) && dotp(schar(STACK_2,z.index))) { var zustand z_name = z; /* skip Character '.' : */ Z_SHIFT(z,1); /* parse Type: */ var object type = parse_logical_word(&z,false); TheLogpathname(STACK_1)->pathname_type = type; if (!nullp(type)) { if ((z.count > 0) && dotp(schar(STACK_2,z.index))) { var zustand z_type = z; /* skip Character '.' : */ Z_SHIFT(z,1); /* parse Version: */ var object version = parse_logical_word(&z,false); if (eq(version,S(Kwild))) { } else if (equal(version,Symbol_name(S(Knewest)))) { version = S(Knewest); } else if (stringp(version) && all_digits(version)) { pushSTACK(version); funcall(L(parse_integer),1); version = value1; /* version: string -> integer */ } else { version = NIL; } TheLogpathname(STACK_1)->pathname_version = version; if (nullp(version)) z = z_type; /* restore character '.' */ } else { TheLogpathname(STACK_1)->pathname_version = NIL; } } else { z = z_name; /* restore character '.' */ TheLogpathname(STACK_1)->pathname_version = NIL; } } else { TheLogpathname(STACK_1)->pathname_type = NIL; TheLogpathname(STACK_1)->pathname_version = NIL; } } skipSTACK(1); TheLogpathname(STACK_0)->pathname_directory = simplify_directory(TheLogpathname(STACK_0)->pathname_directory); DOUT("parse_logical_pathnamestring:>0",STACK_0); DOUT("parse_logical_pathnamestring:>1",STACK_1); return z.count; } /* recognition of a logical host, cf. CLtL2 p. 631 (defun logical-host-p (host) (and (simple-string-p host) (gethash host sys::*logical-pathname-translations*) ; :test #'equalp ! t)) */ local bool logical_host_p (object host) { return (simple_string_p(host) /* No need to string-upcase host, because it's tested via EQUALP. */ && !eq(gethash(host,Symbol_value(S(logpathname_translations)),false), nullobj)); } #define string2wild(str) (equal(str,O(wild_string)) ? S(Kwild) : (object)(str)) #define wild2string(obj) (eq(obj,S(Kwild)) ? (object)O(wild_string) : (obj)) #ifdef PATHNAME_NOEXT /* can trigger GC */ local maygc void fix_parse_namestring_dot_file (void) { /* make sure *PARSE-NAMESTRING-DOT-FILE* is valid */ Symbol_value(S(parse_namestring_dot_file)) = S(Ktype); /*CLISP default*/ pushSTACK(NIL); pushSTACK(S(parse_namestring_dot_file)); pushSTACK(S(parse_namestring_dot_file)); pushSTACK(Symbol_value(S(parse_namestring_dot_file))); STACK_3 = CLSTEXT("The variable ~S had an illegal value.\n" "~S has been reset to ~S."); funcall(S(warn),4); } /* auxiliary function for PARSE-NAMESTRING: splits a string (at the last dot) into Name and Type. split_name_type(skip); > STACK_0: Normal-Simple-String > skip: 1 if a dot at the beginning should not trigger the splitting, else 0 < STACK_1: Name < STACK_0: Type decrements STACK by 1 can trigger GC */ local maygc void split_name_type (uintL skip) { if (skip == 0) { if (eq(Symbol_value(S(parse_namestring_dot_file)),S(Ktype))) { /* OK */ } else if (eq(Symbol_value(S(parse_namestring_dot_file)),S(Kname))) { skip = 1; /* always have a name! */ } else fix_parse_namestring_dot_file(); } var object string = STACK_0; var uintL length = Sstring_length(string); /* Search for the last dot: */ var uintL index = length; if (index > skip) { SstringDispatch(string,X, { var const cintX* ptr = &((SstringX)TheVarobject(string))->data[index]; do { if (*--ptr == '.') goto punkt; index--; } while (index > skip); }); } /* no dot found -> Type := NIL */ { pushSTACK(NIL); } goto name_type_ok; punkt: /* dot found at index */ /* type := (substring string index) */ pushSTACK(subsstring(string,index,length)); /* name := (substring string 0 (1- index)) */ STACK_1 = subsstring(STACK_1,0,index-1); name_type_ok: STACK_0 = string2wild(STACK_0); STACK_1 = string2wild(STACK_1); } #endif /* (PARSE-NAMESTRING thing [host [defaults [:start] [:end] [:junk-allowed]]]), CLTL p. 414 */ LISPFUN(parse_namestring,seclass_rd_sig,1,2,norest,key,3, (kw(start),kw(end),kw(junk_allowed)) ) { /* stack layout: thing, host, defaults, start, end, junk-allowed. */ var bool junk_allowed; var bool parse_logical = false; DOUT("parse-namestring:[thng]",STACK_5); DOUT("parse-namestring:[host]",STACK_4); DOUT("parse-namestring:[dflt]",STACK_3); DOUT("parse-namestring:[beg]",STACK_2); DOUT("parse-namestring:[end]",STACK_1); DOUT("parse-namestring:[junk]",STACK_0); { /* 1. check junk-allowed: */ var object obj = popSTACK(); /* junk-allowed-Argument */ junk_allowed = !missingp(obj); } /* stack layout: thing, host, defaults, start, end. 2. default-value for start is 0: */ if (!boundp(STACK_1)) STACK_1 = Fixnum_0; { /* 3. check host: */ var object host = STACK_3; #if HAS_HOST host = test_optional_host(host,false); #else host = test_optional_host(host); #endif if (nullp(host)) { /* host := (PATHNAME-HOST defaults) */ var object defaults = test_default_pathname(STACK_2); if (logpathnamep(defaults)) parse_logical = true; host = xpathname_host(parse_logical,defaults); } else if (logical_host_p(host)) { parse_logical = true; host = string_upcase(host); } STACK_3 = host; } /* 4. thing must be a String: */ DOUT("parse-namestring:[thng]",STACK_4); DOUT("parse-namestring:[host]",STACK_3); DOUT("parse-namestring:[dflt]",STACK_2); var object thing = STACK_4; if (xpathnamep(thing)) { /* Pathname? */ value1 = thing; /* 1. value thing */ done: DOUT("parse-namestring:[done]",value1); value2 = STACK_1; mv_count=2; /* 2. value start */ skipSTACK(5); return; } if (builtin_stream_p(thing)) { /* Stream? */ thing = as_file_stream(thing); test_file_stream_named(thing); value1 = TheStream(thing)->strm_file_name; /* 1. value: Filename */ goto done; /* 2. value like above */ } /* thing should now be at least a String or a Symbol: */ var bool thing_symbol = false; if (!stringp(thing)) { if (!symbolp(thing) || !nullpSv(parse_namestring_ansi)) error_pathname_designator(thing); thing = Symbol_name(thing); /* Symbol -> use symbol name */ thing_symbol = true; STACK_4 = thing; /* and write back into the Stack */ } /* thing = STACK_4 is now a String. it will be traversed. */ var zustand z; /* running state */ { var object string; /* String thing */ { /* check boundaries, with thing, start, end as arguments: */ var stringarg arg; pushSTACK(thing); pushSTACK(STACK_(1+1)); pushSTACK(STACK_(0+2)); test_string_limits_ro(&arg); string = arg.string; z.index = arg.offset+arg.index; /* z.index = start-argument, */ z.count = arg.len; /* z.count = number of characters. */ z.FNindex = fixnum(arg.index); /* z.FNindex = start-Index as Fixnum. */ } if (!parse_logical) { /* Check whether *PARSE-NAMESTRING-ANSI* is true and the string starts with a logical hostname. */ if (!nullpSv(parse_namestring_ansi)) { /* Coerce string to be a normal-simple-string. */ #ifdef HAVE_SMALL_SSTRING SstringCase(string,{ Z_SUB(z,string); },{ Z_SUB(z,string); },{},{ Z_SUB(z,string); }); #endif pushSTACK(string); var zustand tmp = z; var object host = parse_logical_host_prefix(&tmp,string); string = popSTACK(); DOUT("parse-namestring:",string); DOUT("parse-namestring:",host); if (!nullp(host) /* Test whether the given hostname is valid. This is not strictly what ANSI specifies, but is better than giving an error for Win32 pathnames like "C:\\FOOBAR". */ && logical_host_p(host)) parse_logical = true; else /* ANSI CL specifies that we should look at the entire string, using parse_logical_pathnamestring, not only parse_logical_host_prefix. */ parse_logical = looks_logical_p(string); } } if (thing_symbol && !parse_logical) { #if defined(PATHNAME_UNIX) || defined(PATHNAME_WIN32) /* operating system with preference for small letters */ Z_SUB(z,string); /* yes -> convert with STRING-DOWNCASE */ pushSTACK(string); nstring_downcase(string,0,Sstring_length(string)); string = popSTACK(); sstring_un_realloc(string); #endif } /* Coerce string to be a normal-simple-string. */ #ifdef HAVE_SMALL_SSTRING SstringCase(string,{ Z_SUB(z,string); },{ Z_SUB(z,string); },{},{ Z_SUB(z,string); }); #endif pushSTACK(string); } if (parse_logical) { pushSTACK(allocate_logpathname()); /* stack layout: ..., data-vector, pathname. */ var uintL remaining = parse_logical_pathnamestring(z); z.index += z.count-remaining; z.FNindex = fixnum_inc(z.FNindex,z.count-remaining); z.count = remaining; } else { pushSTACK(allocate_pathname()); /* stack layout: ..., data-vector, pathname. separator between subdirs is on WIN32 both '\' and '/': */ #if HAS_HOST { /* parse Host-Specification: */ var object host; { var zustand startz = z; /* start-state */ var chart ch; #if defined(PATHNAME_WIN32) /* Look for two slashes, then a sequence of characters. */ if (z.count==0) goto no_hostspec; ch = TheSnstring(STACK_1)->data[z.index]; if (!pslashp(ch)) goto no_hostspec; Z_SHIFT(z,1); if (z.count==0) goto no_hostspec; ch = TheSnstring(STACK_1)->data[z.index]; if (!pslashp(ch)) goto no_hostspec; Z_SHIFT(z,1); while (z.count) { ch = TheSnstring(STACK_1)->data[z.index]; if (!legal_hostchar(ch)) break; /* Skip past valid host char. */ Z_SHIFT(z,1); } /* Create host string. */ if (z.index - startz.index - 2 == 0) goto no_hostspec; host = subsstring(STACK_1,startz.index+2,z.index); /* Note: The next character in the string is not a letter or '*'; therefore the device of the resulting pathname will be NIL. */ goto hostspec_ok; #else /* is it a sequence of alphanumeric characters and then a ':' resp. '::' ? */ while (1) { if (z.count==0) goto no_hostspec; /* string already through -> no Host */ ch = TheSnstring(STACK_1)->data[z.index]; /* next character */ if (!alphanumericp(ch)) break; /* skip alphanumeric character: */ Z_SHIFT(z,1); } if (!colonp(ch)) goto no_hostspec; /* no ':' -> no host */ /* build host-string: */ host = subsstring(STACK_1,startz.index,z.index); /* skip character ':' : */ Z_SHIFT(z,1); goto hostspec_ok; #endif no_hostspec: /* no host-specification */ z = startz; /* back to start */ host = STACK_(3+2); /* Default-Host */ } hostspec_ok: /* enter host: */ ThePathname(STACK_0)->pathname_host = host; } #endif /* HAS_HOST */ #if HAS_DEVICE #ifdef PATHNAME_WIN32 { /* parse one-letter Device-Specification: */ var object device = NIL; /* Device := NIL */ /* parse Drive-Specification: Is there a letter ('*','A'-'Z','a'-'z') and then a ':' ? */ { var zustand startz = z; /* start-state */ var chart ch; if (z.count==0) goto no_drivespec; /* string already through ? */ ch = TheSnstring(STACK_1)->data[z.index]; /* next character */ ch = up_case(ch); /* as capital letter */ if (multiwild_char_p(ch)) { /* ch = '*' -> Device := :WILD */ device = S(Kwild); } else if ((as_cint(ch) >= 'A') && (as_cint(ch) <= 'Z')) { /* 'A' <= ch <= 'Z' -> Device := "ch" */ var object string = allocate_string(1); /* String of length 1 */ TheSnstring(string)->data[0] = ch; /* with ch as sole letter */ device = string; } else goto no_device; /* Device OK, skip character: */ Z_SHIFT(z,1); if (z.count==0) goto no_drivespec; /* string already through ? */ ch = TheSnstring(STACK_1)->data[z.index]; /* next character */ ch = up_case(ch); /* as capital letter */ no_device: /* concluded with colon? */ if (!colonp(ch)) goto no_drivespec; /* skip character: */ Z_SHIFT(z,1); goto drivespec_ok; no_drivespec: /* parsing a Drive-Specification did not succeed. */ z = startz; /* restore start-state */ device = NIL; /* Device := NIL */ } drivespec_ok: /* enter Device */ ThePathname(STACK_0)->pathname_device = device; } #endif /* PATHNAME_WIN32 */ #endif /* HAS_DEVICE */ /* enter Directory-Start: */ ThePathname(STACK_0)->pathname_directory = NIL; pushSTACK(NIL); /* new (last (pathname-directory Pathname)) */ /* stack layout: ..., Datenvektor, Pathname, (last (pathname-directory Pathname)). parse subdirectories: */ { #if defined(PATHNAME_UNIX) /* if there is a '~' immediately, a username is read up to the next '/' or string-end and the Home-Directory of this user is inserted: */ if ((z.count != 0) && chareq(schar(STACK_2,z.index),ascii('~'))) { /* there is a '~' immediately. skip character: */ Z_SHIFT(z,1); var object userhomedir; /* Pathname of the User-Homedir */ /* search next '/' : */ var uintL charcount = 0; if (z.count > 0) { SstringDispatch(STACK_2,X, { var const cintX* charptr = &((SstringX)TheVarobject(STACK_2))->data[z.index]; var uintL count; dotimespL(count,z.count, { if (*charptr++ == '/') break; charcount++; }); }); } /* Username has charcount characters */ if (charcount==0) { userhomedir = O(user_homedir); /* only '~' -> User-Homedir */ } else { /* build username: */ var object username = subsstring(STACK_2,z.index,z.index+charcount); /* fetch his/her Home-Directory from the password-file: */ with_sstring_0(username,O(misc_encoding),username_asciz, { begin_system_call(); errno = 0; var struct passwd * userpasswd = getpwnam(username_asciz); if (userpasswd == (struct passwd *)NULL) { /* unsuccessful? */ if (!(errno==0)) { OS_error(); } /* report error */ end_system_call(); /* else: error */ pushSTACK(username); pushSTACK(S(parse_namestring)); error(parse_error,GETTEXT("~S: there is no user named ~S")); } end_system_call(); userhomedir = /* homedir as pathname */ asciz_dir_to_pathname(userpasswd->pw_dir,O(misc_encoding)); }); } /* copy directory from the pathname userhomedir: (copy-list dir) = (nreconc (reverse dir) nil), after it memorize its last Cons. */ userhomedir = reverse(ThePathname(userhomedir)->pathname_directory); userhomedir = nreconc(userhomedir,NIL); ThePathname(STACK_1)->pathname_directory = userhomedir; while (mconsp(Cdr(userhomedir))) { userhomedir = Cdr(userhomedir); } STACK_0 = userhomedir; /* skip username-characters: */ Z_SHIFT(z,charcount); /* if the string is through: finished, otherwise a '/' follows immediately , it will be skipped: */ if (z.count==0) { /* Name and Type := NIL */ pushSTACK(NIL); pushSTACK(NIL); goto after_name_type; } /* skip character: */ Z_SHIFT(z,1); } else #endif /* PATHNAME_UNIX */ #if defined(PATHNAME_UNIX) && 0 /* What is this needed for, except for $HOME ? If a '$' follows immediately, an Environment-Variable is read up to the next '/' or string-end and its value is inserted: */ if ((z.count != 0) && chareq(TheSnstring(STACK_2)->data[z.index],ascii('$'))) { /* A '$' follows immediately. skip character: */ Z_SHIFT(z,1); var object envval_dir; /* search next '/' : */ var uintL charcount = 0; { var const chart* charptr = &TheSnstring(STACK_2)->data[z.index]; var uintL count; dotimesL(count,z.count, { if (chareq(*charptr++,ascii('/'))) break; charcount++; }); } { /* Environment-Variable has charcount characters. */ var object envvar = subsstring(STACK_2,z.index,z.index+charcount); /* fetch its value: */ with_sstring_0(envvar,O(misc_encoding),envvar_asciz, { begin_system_call(); var const char* envval = getenv(envvar_asciz); end_system_call(); if (envval==NULL) { pushSTACK(envvar); pushSTACK(S(parse_namestring)); error(parse_error, GETTEXT("~S: there is no environment variable ~S")); } envval_dir = /* value of the variable as pathname */ asciz_dir_to_pathname(envval,O(misc_encoding)); }); } /* copy directory from the pathname envval_dir: (copy-list dir) = (nreconc (reverse dir) nil), afterwards memorize its last Cons. */ envval_dir = reverse(ThePathname(envval_dir)->pathname_directory); envval_dir = nreconc(envval_dir,NIL); ThePathname(STACK_1)->pathname_directory = envval_dir; while (mconsp(Cdr(envval_dir))) { envval_dir = Cdr(envval_dir); } STACK_0 = envval_dir; /* skip envvar-characters: */ Z_SHIFT(z,charcount); /* if the string is through: finished, otherwise a '/' follows immediately , it will be skipped: */ if (z.count==0) { /* Name and Type := NIL */ pushSTACK(NIL); pushSTACK(NIL); goto after_name_type; } /* skip character: */ Z_SHIFT(z,1); } else #endif /* PATHNAME_UNIX & 0 */ #if defined(PATHNAME_UNIX) || defined(PATHNAME_WIN32) #if defined(UNIX_CYGWIN32) if (z.count > 1 && !nullpSv(device_prefix) && colonp(schar(STACK_2,z.index+1))) { /* if string starts with 'x:', treat it as a device */ var chart ch = down_case(schar(STACK_2,z.index)); if ((as_cint(ch) >= 'a') && (as_cint(ch) <= 'z')) { pushSTACK(allocate_string(1)); /* drive */ TheSnstring(STACK_0)->data[0] = ch; var object new_cons = allocate_cons(); Car(new_cons) = popSTACK(); /* drive */ ThePathname(STACK_1)->pathname_directory = new_cons; STACK_0 = new_cons; Z_SHIFT(z,2); if (Z_AT_SLASH(z,pslashp,STACK_2)) Z_SHIFT(z,1); } else goto continue_parsing_despite_colon; } else continue_parsing_despite_colon: #endif /* if 1st char is a slash, start with :ABSOLUTE (otherwise :RELATIVE): */ if (Z_AT_SLASH(z,pslashp,STACK_2)) { Z_SHIFT(z,1); var object new_cons = allocate_cons(); Car(new_cons) = S(Kabsolute); ThePathname(STACK_1)->pathname_directory = new_cons; STACK_0 = new_cons; } #endif while (1) { /* try to parse another subdirectory. */ #ifdef PATHNAME_NOEXT { var uintL z_start_index = z.index; /* index at the start */ while (1) { var chart ch; if (z.count == 0) break; ch = schar(STACK_2,z.index); /* next character */ if (!legal_namechar(ch)) /* valid character ? */ break; /* yes -> part of the name skip character: */ Z_SHIFT(z,1); } /* reached end of the name. Name := substring of STACK_2 from z_start_index (inclusive) to z.index (exclusive). */ var object string = subsstring(STACK_2,z_start_index,z.index); /* name finished. */ pushSTACK(string); } /* if a '/' resp. '\' follows immediately, then it was a subdirectory, else the pathname is finished: */ if (!Z_AT_SLASH(z,pslashp,STACK_3)) /* no -> it was the name and no subdir. */ break; /* a '/' resp. '\' follows. skip character: */ Z_SHIFT(z,1); /* stack layout: ..., data-vector, pathname, (last (pathname-directory Pathname)), subdir. */ /* was it '**' or '...' ? */ if (equal(STACK_0,O(wildwild_string)) || equal(STACK_0,O(dotdotdot_string))) { STACK_0 = S(Kwild_inferiors); /* replace with :WILD-INFERIORS */ } #endif /* PATHNAME_NOEXT */ if (nullp(STACK_1)) { var object new_cons = allocate_cons(); Car(new_cons) = S(Krelative); ThePathname(STACK_2)->pathname_directory = new_cons; STACK_1 = new_cons; } /* lengthen (pathname-directory pathname) by subdir STACK_0: */ var object new_cons = allocate_cons(); /* new Cons */ Car(new_cons) = popSTACK(); /* = (cons subdir NIL) */ Cdr(STACK_0) = new_cons; /* lengthened (pathname-directory Pathname) */ STACK_0 = new_cons; /* new (last (pathname-directory Pathname)) */ } #ifdef PATHNAME_NOEXT /* stack layout: ..., data-vector, pathname, (last (pathname-directory Pathname)), string. */ split_name_type(0); /* split string STACK_0 in name and type */ after_name_type: /* stack layout: ..., data-vector, pathname, (last (pathname-directory Pathname)), name, type. */ { /* enter name and type in pathname: */ var object type = popSTACK(); var object name = popSTACK(); skipSTACK(1); /* directory is already entered */ /* replace name="" with name=NIL: */ if (equal(name,O(empty_string))) name = NIL; var object pathname = STACK_0; ThePathname(pathname)->pathname_name = name; ThePathname(pathname)->pathname_type = type; } #endif #ifdef WIN32_NATIVE var object pathname = STACK_0; var object dir = ThePathname(pathname)->pathname_directory; var object dev = Symbol_value(S(device_prefix)); if (nullp(ThePathname(pathname)->pathname_device) /* actually, we already know that dir is a cons */ && consp(dir) && eq(Car(dir),S(Kabsolute)) /* Cdr(dir) might not be a cons, e.g., "/foo" == #S(pathname :directory (:absolute) :name "foo") */ && consp(Cdr(dir)) && consp(Cdr(Cdr(dir))) && stringp(dev) && stringp(Car(Cdr(dir))) && string_eqcomp_ci(Car(Cdr(dir)),0,dev,0,vector_length(dev))) { /* path = (:ABSOLUTE "cygdrive" "drive" "dir1" ...) ===> path = (:ABSOLUTE "dir1" ...); device = "DRIVE" */ var object device = Car(Cdr(Cdr(dir))); Cdr(dir) = Cdr(Cdr(Cdr(dir))); device = string_upcase(device); ThePathname(STACK_0)->pathname_device = device; } #endif #ifdef UNIX_CYGWIN32 var object dir = ThePathname(STACK_0)->pathname_directory; if (consp(dir) && stringp(Car(dir))) { /* dir = ("c" ...) --> (:absolute *device-prefix* "c" ...)*/ pushSTACK(S(Kabsolute)); pushSTACK(Symbol_value(S(device_prefix))); dir = listof(2); Cdr(Cdr(dir)) = ThePathname(STACK_0)->pathname_directory; ThePathname(STACK_0)->pathname_directory = dir; } #endif ThePathname(STACK_0)->pathname_directory = simplify_directory(ThePathname(STACK_0)->pathname_directory); } } /* Pathname is finished. stack layout: ..., data-vector, pathname. */ if (!junk_allowed) /* Check whether no more characters remain */ if (!(z.count == 0)) { pushSTACK(z.FNindex); /* last index */ pushSTACK(STACK_(4+2+1)); /* thing */ pushSTACK(S(parse_namestring)); error(parse_error, GETTEXT("~S: syntax error in filename ~S at position ~S")); } /* Check that if a :host argument (or :host component of the :defaults argument) was present and the parsed pathname has a host component, they agree; and set the :host component of the result otherwise */ if (!missingp(STACK_(3+2))) { if (parse_logical) { var object parsed_host = TheLogpathname(STACK_0)->pathname_host; if (!nullp(parsed_host)) { if (!equal(STACK_(3+2),parsed_host)) { pushSTACK(STACK_0); pushSTACK(parsed_host); pushSTACK(STACK_(3+2+2)); pushSTACK(S(parse_namestring)); error(error_condition,GETTEXT("~S: hosts ~S and ~S of ~S should coincide")); } } else TheLogpathname(STACK_0)->pathname_host = STACK_(3+2); } else { #if HAS_HOST var object parsed_host = ThePathname(STACK_0)->pathname_host; if (!nullp(parsed_host)) { if (!equal(STACK_(3+2),parsed_host)) { pushSTACK(STACK_0); pushSTACK(parsed_host); pushSTACK(STACK_(3+2+2)); pushSTACK(S(parse_namestring)); error(error_condition,GETTEXT("~S: hosts ~S and ~S of ~S should coincide")); } } else ThePathname(STACK_0)->pathname_host = STACK_(3+2); #endif } } value1 = STACK_0; /* pathname as 1st value */ value2 = z.FNindex; /* index as 2nd value */ mv_count=2; /* 2 values */ DOUT("parse-namestring:[end ret]",value1); skipSTACK(5+2); return; } #undef colonp #undef Z_SUB #undef Z_AT_SLASH #undef Z_SHIFT /* UP: Converts an object into a pathname. coerce_xpathname(object) > object: object < result: (PATHNAME Objekt) can trigger GC */ local maygc object coerce_xpathname (object obj) { if (xpathnamep(obj)) { /* nothing to do for pathnames. */ return obj; } else { /* else: call PARSE-NAMESTRING: */ pushSTACK(obj); funcall(L(parse_namestring),1); return value1; } } LISPFUNNR(pathname,1) { /* (PATHNAME pathname), CLTL p. 413 */ VALUES1(coerce_xpathname(popSTACK())); } #define PATH_VALUE(slot,common) do { \ object ret = ThePathname(pathname)->slot; \ value1 = eq(STACK_0,S(Kcommon)) ? common(ret) : ret; \ } while(0) #define LOG_PATH_VALUE(slot) \ if (logpathnamep(pathname)) value1 = TheLogpathname(pathname)->slot; else /* (PATHNAME-HOST pathname [:case]), CLTL p. 417, CLtL2 p. 644 */ LISPFUN(pathnamehost,seclass_read,1,0,norest,key,1, (kw(case))) { var object pathname = coerce_xpathname(STACK_1); LOG_PATH_VALUE(pathname_host) #if HAS_HOST PATH_VALUE(pathname_host,common_case); #else value1 = NIL; #endif mv_count = 1; skipSTACK(2); } /* (PATHNAME-DEVICE pathname [:case]), CLTL p. 417, CLtL2 p. 644 */ LISPFUN(pathnamedevice,seclass_read,1,0,norest,key,1, (kw(case))) { var object pathname = coerce_xpathname(STACK_1); if (logpathnamep(pathname)) { /* http://www.lisp.org/HyperSpec/Body/sec_19-3-2-1.html */ value1 = S(Kunspecific); } else #if HAS_DEVICE PATH_VALUE(pathname_device,common_case); #else value1 = NIL; #endif mv_count = 1; skipSTACK(2); } #define PATH_SLOT(slot,common) \ object pathname = coerce_xpathname(STACK_1); \ LOG_PATH_VALUE(slot) PATH_VALUE(slot,common); \ mv_count = 1; skipSTACK(2) /* (PATHNAME-DIRECTORY pathname [:case]), CLTL p. 417, CLtL2 p. 644 */ LISPFUN(pathnamedirectory,seclass_read,1,0,norest,key,1, (kw(case))) { PATH_SLOT(pathname_directory,subst_common_case); } /* (PATHNAME-NAME pathname [:case]), CLTL p. 417, CLtL2 p. 644 */ LISPFUN(pathnamename,seclass_read,1,0,norest,key,1, (kw(case))) { PATH_SLOT(pathname_name,common_case); } /* (PATHNAME-TYPE pathname [:case]), CLTL p. 417, CLtL2 p. 644 */ LISPFUN(pathnametype,seclass_read,1,0,norest,key,1, (kw(case))) { PATH_SLOT(pathname_type,common_case); } /* (PATHNAME-VERSION pathname), CLTL p. 417, CLtL2 p. 644 */ LISPFUNNR(pathnameversion,1) { var object pathname = coerce_xpathname(popSTACK()); VALUES1(xpathname_version(logpathnamep(pathname),pathname)); } /* Converts obj to a pathname. If obj is a string, it is even converted to a logical pathname. can trigger GC */ local maygc object parse_as_logical (object obj) { /* The value of (PARSE-NAMESTRING obj nil empty-logical-pathname) is always a logical pathname, if obj is a string. (But not if it is a stream!) */ pushSTACK(obj); pushSTACK(NIL); pushSTACK(O(empty_logical_pathname)); funcall(L(parse_namestring),3); return value1; } /* Handler: Signals a TYPE-ERROR with the same error message as the current condition. */ local void signal_type_error (void* sp, gcv_object_t* frame, object label, object condition) { var gcv_object_t* thing_ = (gcv_object_t*)sp; /* (SYS::ERROR-OF-TYPE 'TYPE-ERROR :DATUM thing :EXPECTED-TYPE '(AND STRING (SATISFIES SYSTEM::VALID-LOGICAL-PATHNAME-STRING-P)) "~A" condition) */ pushSTACK(S(type_error)); pushSTACK(S(Kdatum)); pushSTACK(*thing_); pushSTACK(S(Kexpected_type)); pushSTACK(O(type_logical_pathname_string)); pushSTACK(O(tildeA)); pushSTACK(condition); funcall(L(error_of_type),7); } LISPFUNNS(logical_pathname,1) { /* (LOGICAL-PATHNAME thing), CLtL2 p. 631 */ var object thing = STACK_0; if (logpathnamep(thing)) { /* nothing to do for logical pathnames. */ VALUES1(thing); } else if (pathnamep(thing)) { /* normal pathnames cannot be converted into logical pathnames. */ pushSTACK(thing); /* TYPE-ERROR slot DATUM */ pushSTACK(O(type_logical_pathname)); /* TYPE-ERROR slot EXPECTED-TYPE */ pushSTACK(thing); pushSTACK(S(logical_pathname)); error(type_error,GETTEXT("~S: argument ~S is not a logical pathname, string, stream or symbol")); } else if (builtin_stream_p(thing)) { /* Stream? */ thing = as_file_stream(thing); test_file_stream_named(thing); var object pathname = TheStream(thing)->strm_file_name; if (!logpathnamep(pathname)) { /* Normal pathnames cannot be converted into logical pathnames. */ pushSTACK(pathname); /* TYPE-ERROR slot DATUM */ pushSTACK(O(type_logical_pathname)); /* TYPE-ERROR slot EXPECTED-TYPE */ pushSTACK(thing); pushSTACK(S(logical_pathname)); error(type_error,GETTEXT("~S: the stream ~S was not opened with a logical pathname")); } VALUES1(pathname); } else { /* ANSI CL requires that we transform PARSE-ERROR into TYPE-ERROR. */ var gcv_object_t* thing_ = &STACK_0; make_HANDLER_frame(O(handler_for_parse_error), &signal_type_error,thing_); var object pathname = parse_as_logical(thing); unwind_HANDLER_frame(); /* Check that a host was given. This makes it hard to create relative logical pathnames, but it is what ANSI CL specifies. */ if (nullp(TheLogpathname(pathname)->pathname_host)) { pushSTACK(TheLogpathname(pathname)->pathname_host); /* TYPE-ERROR slot DATUM */ pushSTACK(S(string)); /* TYPE-ERROR slot EXPECTED-TYPE */ pushSTACK(STACK_(0+2)); pushSTACK(S(logical_pathname)); error(type_error,GETTEXT("~S: argument ~S does not contain a host specification")); } VALUES1(pathname); } skipSTACK(1); } /* forward declaration */ local object use_default_dir (object pathname); /* (TRANSLATE-LOGICAL-PATHNAME pathname &key [:absolute]), CLtL2 p. 631 */ LISPFUN(translate_logical_pathname,seclass_default,1,0,norest,key,1, (kw(absolute))) { var bool absolute_p = !missingp(STACK_0); var object pathname; skipSTACK(1); /* drop :ABSOLUTE */ /* It is not clear from the ANSI CL spec how the argument shall be coerced to a pathname. But the examples in the spec indicate that if the argument is a string, it should be converted to a logical pathname, by calling LOGICAL-PATHNAME, not by calling PATHNAME. */ if (stringp(STACK_0)) { funcall(L(logical_pathname),1); pathname = value1; } else { pathname = coerce_xpathname(popSTACK()); } if (logpathnamep(pathname)) { /* Conversion of a logical into a normal pathname: (let ((ht (make-hash-table :key-type 'logical-pathname :value-type '(eql t) :test #'equal))) (loop (when (gethash pathname ht) (error "Translation loop")) (setf (gethash pathname ht) t) (let ((host (or (pathname-host pathname) "SYS"))) (unless (logical-host-p host) (error "No translation for host")) (let* ((translations (gethash host sys::*logical-pathname-translations*)) (translation (assoc pathname translations :test #'pathname-match-p))) (unless (and translation (consp translation) (consp (cdr translation))) (error "No translation for pathname")) (setq pathname (translate-pathname pathname (first translation) (second translation))))) (unless (sys::logical-pathname-p pathname) (return))) pathname) */ pushSTACK(pathname); DOUT("translate-logical-pathname: <",pathname); pushSTACK(S(Ktest)); pushSTACK(L(equal)); funcall(L(make_hash_table),2); pushSTACK(value1); /* stack layout: pathname, ht. */ while (1) { if (!nullp(shifthash(STACK_0,STACK_1,T,true))) { /* STACK_1 = pathname; -- FILE-ERROR slot PATHNAME */ STACK_0 = STACK_1; pushSTACK(S(translate_logical_pathname)); error(file_error,GETTEXT("~S: endless loop while resolving ~S")); } if (nullp(TheLogpathname(STACK_1)->pathname_host)) { /* replace host NIL with default-host: */ var object newp = allocate_logpathname(); var object oldp = STACK_1; TheLogpathname(newp)->pathname_host = O(default_logical_pathname_host); /* Default "SYS" */ TheLogpathname(newp)->pathname_directory = TheLogpathname(oldp)->pathname_directory; TheLogpathname(newp)->pathname_name = TheLogpathname(oldp)->pathname_name; TheLogpathname(newp)->pathname_type = TheLogpathname(oldp)->pathname_type; TheLogpathname(newp)->pathname_version = TheLogpathname(oldp)->pathname_version; STACK_1 = newp; } var object host = TheLogpathname(STACK_1)->pathname_host; DOUT("translate-logical-pathname:",host); var object translations = gethash(host,Symbol_value(S(logpathname_translations)),false); if (eq(translations,nullobj)) { /* STACK_1 = pathname; -- FILE-ERROR slot PATHNAME */ STACK_0 = STACK_1; pushSTACK(host); pushSTACK(S(translate_logical_pathname)); error(file_error,GETTEXT("~S: unknown logical host ~S in ~S")); } /* (ASSOC pathname translations :test #'pathname-match-p): */ pushSTACK(STACK_1); pushSTACK(translations); DOUT("translate-logical-pathname:[path_name_s1]",STACK_1); DOUT("translate-logical-pathname:",translations); pushSTACK(S(Ktest)); pushSTACK(L(pathname_match_p)); funcall(L(assoc),4); if (atomp(value1) || matomp(Cdr(value1))) { /* STACK_1 = pathname; -- FILE-ERROR slot PATHNAME */ STACK_0 = STACK_1; pushSTACK(S(translate_logical_pathname)); error(file_error,GETTEXT("~S: No replacement rule for ~S is known.")); } /* (TRANSLATE-PATHNAME pathname (first rule) (second rule) :MERGE NIL):*/ pushSTACK(STACK_1); pushSTACK(Car(value1)); pushSTACK(Car(Cdr(value1))); pushSTACK(S(Kmerge)); pushSTACK(NIL); funcall(L(translate_pathname),5); STACK_1 = pathname = value1; DOUT("translate-logical-pathname:",pathname); if (!logpathnamep(pathname)) break; } DOUT("translate-logical-pathname: >",pathname); skipSTACK(2); } if (absolute_p) pathname = use_default_dir(pathname); /* insert default-directory */ VALUES1(pathname); } /* UP: Change an object into a non-logical pathname. coerce_pathname(object) > object: object < return: (TRANSLATE-LOGICAL-PATHNAME (PATHNAME Objekt)) can trigger GC */ local maygc object coerce_pathname (object obj) { obj = coerce_xpathname(obj); if (pathnamep(obj)) { return obj; } else if (logpathnamep(obj)) { /* call TRANSLATE-LOGICAL-PATHNAME: */ pushSTACK(obj); funcall(L(translate_logical_pathname),1); return value1; } else NOTREACHED; } /* UP: Pushes substrings for STRING_CONCAT on the STACK, that together yield the string for a subdirectory (car path) . subdir_namestring_parts(path,logicalp) > path: a Cons > logicalp: boolean < result: number of strings pushed on the stack changes STACK */ #define SUBDIR_PUSHSTACK(subdir) \ do { if (eq(subdir,S(Kwild_inferiors))) pushSTACK(O(wildwild_string)); \ else if (eq(subdir,S(Kwild))) pushSTACK(O(wild_string)); \ else if (eq(subdir,S(Kup)) || eq(subdir,S(Kback))) \ pushSTACK(O(dotdot_string)); \ else if (stringp(subdir)) pushSTACK(subdir); \ else NOTREACHED; \ } while(0) local uintC subdir_namestring_parts (object path,bool logp) { var object subdir = Car(path); #if defined(PATHNAME_UNIX) || defined(PATHNAME_WIN32) SUBDIR_PUSHSTACK(subdir); return 1; #endif } /* UP: Pushes substrings for STRING_CONCAT on the STACK, that together yield the String for the host of the Pathname pathname. host_namestring_parts(pathname) > pathname: non-logical pathname < result: number of strings pushed on the stack changes STACK */ local uintC host_namestring_parts (object pathname) { var bool logp = logpathnamep(pathname); var object host = xpathname_host(logp,pathname); if (nullp(host)) { return 0; /* no String */ } else { #ifdef PATHNAME_WIN32 if (!logp) { pushSTACK(O(backslashbackslash_string)); pushSTACK(host); return 2; } #endif pushSTACK(host); pushSTACK(O(colon_string)); /* ":" */ return 2; } } /* UP: Pushes substrings for STRING_CONCAT on the STACK, that together yield the String for the Device and Directory of the Pathname pathname. directory_namestring_parts(pathname) > pathname: non-logical pathname < result: number of strings pushed on the stack changes STACK */ local uintC directory_namestring_parts (object pathname) { var uintC stringcount = 0; /* number of strings so far = 0 */ var bool logp = logpathnamep(pathname); #if defined(PATHNAME_WIN32) { /* Device: */ var object device = xpathname_device(logp,pathname); if (!(nullp(device))) { /* NIL -> no string */ var object string = wild2string(device); pushSTACK(string); stringcount++; /* and count */ pushSTACK(O(colon_string)); stringcount++; /* ":" */ } } #endif #if defined(PATHNAME_WIN32) || defined(PATHNAME_UNIX) if (stringcount == 0) /* only if there's no device already */ /* no check for both host and device being present: this can never happen in CLISP */ stringcount += host_namestring_parts(pathname); #endif { /* Directory: */ var object directory = xpathname_directory(logp,pathname); if (logp) { if (consp(directory) && eq(Car(directory),S(Krelative))) { pushSTACK(O(semicolon_string)); stringcount++; /* ";" on the Stack */ } } else { #if defined(PATHNAME_WIN32) #define push_slash pushSTACK(O(backslash_string)) #elif defined(PATHNAME_UNIX) #define push_slash pushSTACK(O(slash_string)) #else #error what is the directory separator on your platform? #endif if (!mconsp(directory)) return stringcount; /* no directory */ /* is the first subdir = :ABSOLUTE or = :RELATIVE ? */ if (eq(Car(directory),S(Kabsolute))) { push_slash; stringcount++; /* "/" */ } else if (nullp(Cdr(directory))) { /* (:RELATIVE) ==> "./" */ pushSTACK(O(dot_string)); stringcount++; /* "." */ push_slash; stringcount++; /* "/" */ return stringcount; } } directory = Cdr(directory); /* skip */ /* other subdirs on the stack: */ while (consp(directory)) { stringcount += subdir_namestring_parts(directory,logp); if (logp) { pushSTACK(O(semicolon_string)); stringcount++; /* ";" */ } else { #ifdef PATHNAME_WIN32 pushSTACK(O(backslash_string)); stringcount++; /* "\\" */ #endif #ifdef PATHNAME_UNIX pushSTACK(O(slash_string)); stringcount++; /* "/" */ #endif } directory = Cdr(directory); } } #undef push_slash return stringcount; } /* UP: Pushes substrings for STRING_CONCAT on the STACK, that together yield the string for Name and Type of the pathname. nametype_namestring_parts(name,type,version) > name, type, poss. version: components of the pathname < result: number of the strings pushed on the stack can trigger GC changes STACK */ local maygc uintC nametype_namestring_parts (object name, object type, object version) { var uintC stringcount = 0; /* Name: */ if (!nullp(name)) { /* name=NIL -> do not print */ var object string = wild2string(name); pushSTACK(string); stringcount++; /* and count */ } /* Type: */ if (!nullp(type)) { /* type=NIL -> do not print */ pushSTACK(O(dot_string)); /* "." */ stringcount++; /* and count */ var object string = wild2string(type); pushSTACK(string); stringcount++; /* and count */ } if (!nullp(version)) { /* version=NIL -> do not print */ pushSTACK(O(dot_string)); /* "." */ stringcount++; /* and count */ if (eq(version,S(Knewest))) /* http://www.lisp.org/HyperSpec/Body/sec_19-3-1.html */ pushSTACK(Symbol_name(S(Knewest))); /* :NEWEST -> "NEWEST" */ else if (eq(version,S(Kwild))) pushSTACK(O(wild_string)); else /* version (integer >0) ==> string: (sys::decimal-string version) */ pushSTACK(decimal_string(version)); stringcount++; /* and count */ } return stringcount; } /* UP: Pushes substrings for STRING_CONCAT on the STACK, that together yield the string for name and type of the pathname. file_namestring_parts(pathname) > pathname: non-logical pathname < result: number of the strings pushed on the stack can trigger GC changes STACK */ local maygc uintC file_namestring_parts (object pathname) { if (logpathnamep(pathname)) return nametype_namestring_parts (TheLogpathname(pathname)->pathname_name, TheLogpathname(pathname)->pathname_type, TheLogpathname(pathname)->pathname_version); else /* do not print version when the underlying physical file system does not support it */ return nametype_namestring_parts(ThePathname(pathname)->pathname_name, ThePathname(pathname)->pathname_type, pathname_version_maybe(pathname)); } /* UP: Converts pathname into string. whole_namestring(pathname) > pathname: non-logical pathname < result: Normal-Simple-String can trigger GC */ local maygc object whole_namestring (object pathname) { var uintC stringcount = 0; stringcount += directory_namestring_parts(pathname); stringcount += file_namestring_parts(pathname); return string_concat(stringcount); } /* UP: Returns the string for the directory of a pathname. directory_namestring(pathname) > pathname: non-logical pathname < result: Normal-Simple-String can trigger GC */ local maygc object directory_namestring (object pathname) { /* The function DIRECTORY-NAMESTRING is totally underspecified. It could return a. just the string for the directory portion, b. the string for the device + directory portions, c. the string for the host + device + directory portions. Before we used hosts, we have traditionally returned (b). Now, with hosts, we still return (b) since HOST-NAMESTRING returns the host part, while there is no way to return just the device This makes most sense, given that CLHS says that programs should not attempt to concatenate the resulting string with anything. */ return string_concat(directory_namestring_parts(pathname)); } /* UP: Returns the string identifying a file in its directory. file_namestring(pathname) > pathname: non-logical pathname < result: normal-simple-string can trigger GC */ local maygc inline object file_namestring (object pathname) { return string_concat(file_namestring_parts(pathname)); } LISPFUNNR(file_namestring,1) { /* (FILE-NAMESTRING pathname), CLTL p. 417 */ VALUES1(file_namestring(coerce_xpathname(popSTACK()))); } LISPFUNNR(directory_namestring,1) { /* (DIRECTORY-NAMESTRING pathname), CLTL p. 417 */ VALUES1(directory_namestring(coerce_xpathname(popSTACK()))); } LISPFUNNR(host_namestring,1) { /* (HOST-NAMESTRING pathname), CLTL p. 417 */ var object pathname = coerce_xpathname(popSTACK()); VALUES1(xpathname_host(logpathnamep(pathname),pathname)); } /* UP: check an optional VERSION argument. test_optional_version(def); > STACK_0: VERSION-Argument > def: default value for it < result: valid version-component */ local object test_optional_version (object def) { var object version = STACK_0; if (!boundp(version)) { STACK_0 = def; /* not specified -> Default */ } else if (nullp(version)) { /* NIL is OK */ } else if (eq(version,S(Kwild))) { /* :WILD is OK */ } else if (eq(version,S(Knewest))) { /* :NEWEST is OK */ } else if (posfixnump(version) && !eq(version,Fixnum_0)) {/*Fixnum>0 is OK*/ } else if (pathnamep(version)) { /* Pathname -> its Version */ STACK_0 = ThePathname(version)->pathname_version; } else if (logpathnamep(version)) { /* Logical Pathname -> its Version */ STACK_0 = TheLogpathname(version)->pathname_version; } else { /* None of the desired cases -> error: */ pushSTACK(version); /* TYPE-ERROR slot DATUM */ pushSTACK(O(type_version)); /* TYPE-ERROR slot EXPECTED-TYPE */ pushSTACK(version); pushSTACK(TheSubr(subr_self)->name); error(type_error,GETTEXT("~S: :VERSION-argument should be NIL or a positive fixnum or :WILD or :NEWEST, not ~S")); } return STACK_0; } #ifdef PATHNAME_WIN32 /* the operating system manages a default-drive. the operating system manages a default-directory on each drive. This can change, if another floppy disk is inserted. */ /* a default-drive is kept: DEFAULT_DRIVE = O(default_drive). */ /* the variable *DEFAULT-PATHNAME-DEFAULTS* contains (as pathname) the default value for each MERGE-operation. It is the one, which the system "interpretes into" the pathnames entered by the user. It is kept up to date with the DEFAULT_DRIVE: On initialization the current device (in terms of DOS), on change of DEFAULT_DRIVE via CD. */ #endif /* PATHNAME_WIN32 */ #ifdef PATHNAME_UNIX /* The variable *DEFAULT-PATHNAME-DEFAULTS* contains (as pathname) the default value for each MERGE-operation. It is the one, which the system "interpretes into" the pathnames entered by the user. */ #endif #ifdef UNIX /* the operating system manages a default-directory ("working directory") for this process. It can be changed with chdir and queried with getwd. See CHDIR(2) and GETWD(3). */ #endif /* UP: Re-calculation of *DEFAULT-PATHNAME-DEFAULTS* */ #ifdef PATHNAME_WIN32 /* from DEFAULT_DRIVE */ #endif /* recalc_defaults_pathname(); < result: value of *DEFAULT-PATHNAME-DEFAULTS*, a pathname can trigger GC */ local maygc object recalc_defaults_pathname (void) { #ifdef PATHNAME_WIN32 /* execute (MAKE-PATHNAME :DEVICE default-drive) : */ pushSTACK(S(Kdevice)); pushSTACK(O(default_drive)); funcall(L(make_pathname),2); #endif #ifdef PATHNAME_UNIX /* execute (MAKE-PATHNAME) : */ funcall(L(make_pathname),0); #endif /* and assign *DEFAULT-PATHNAME-DEFAULTS* : */ return Symbol_value(S(default_pathname_defaults)) = value1; } /* UP: Returns the default-pathname. defaults_pathname() < result: value of *DEFAULT-PATHNAME-DEFAULTS*, a pathname can trigger GC */ local maygc object defaults_pathname (void) { var object pathname = Symbol_value(S(default_pathname_defaults)); /* value of *DEFAULT-PATHNAME-DEFAULTS* */ if (xpathnamep(pathname)) { /* is a pathname -> OK */ return pathname; } else { /* else warning: */ pushSTACK(CLSTEXT("The value of ~S was not a pathname. ~:*~S is being reset.")); pushSTACK(S(default_pathname_defaults)); funcall(S(warn),2); /* and re-calculate: */ return recalc_defaults_pathname(); } } /* merge two directories > p_directory: pathname directory list > d_directory: defaults directory list > p_log: flag, whether pathname is logical > wildp: flag, from MERGE-PATHNAMES > called_from_make_pathname: flag, from MERGE-PATHNAMES < result: merges directory list can trigger GC */ local maygc object merge_dirs (object p_directory, object d_directory, bool p_log, bool wildp, bool called_from_make_pathname) { var object new_subdirs = p_directory; #if DEBUG_TRANSLATE_PATHNAME printf("[%d] merge_dirs: log: %d; wild: %d; cfmp: %d\n", __LINE__,p_log,wildp,called_from_make_pathname); #endif SDOUT("merge_dirs:",p_directory); SDOUT("merge_dirs:",d_directory); if (called_from_make_pathname) { if (!boundp(p_directory)) /* pathname-subdirs not given? */ new_subdirs = d_directory; /* use defaults-subdirs */ } else if (!wildp) { if (nullp(p_directory) /* is pathname-subdirs trivial? */ || (eq(Car(p_directory),p_log ? S(Kabsolute) : S(Krelative)) && matomp(Cdr(p_directory)))) { new_subdirs = d_directory; /* use defaults-subdirs */ } else if (eq(Car(p_directory),S(Krelative)) /* PATHNAME = :ABSOLUTE ==> merge is not needed */ && consp(d_directory) /* DEFAULT = NIL ==> nothing to merge */ && (eq(Car(d_directory),S(Kabsolute)) || !nullpSv(merge_pathnames_ansi))) { /* (append defaults-subdirs (cdr pathname-subdirs)) = (nreconc (reverse defaults-subdirs) (cdr pathname-subdirs)) : */ pushSTACK(Cdr(p_directory)); var object temp = reverse(d_directory); new_subdirs = simplify_directory(nreconc(temp,popSTACK())); } } return new_subdirs; } /* (MERGE-PATHNAMES pathname [defaults [default-version]] [:wild]), CLTL p. 415 Definition assuming that HAS_HOST and HAS_DEVICE are exclusive: (defun merge-pathnames (pathname &optional (defaults *default-pathname-defaults*) default-version) (setq pathname (pathname pathname)) (setq defaults (pathname defaults)) (multiple-value-call #'make-pathname #if HAS_HOST (if (or (equal (pathname-host pathname) (pathname-host defaults)) (null (pathname-host pathname))) (values :host (or (pathname-host pathname) (pathname-host defaults)) #endif #if HAS_DEVICE (if (or (equal (pathname-device pathname) (pathname-device defaults)) (null (pathname-device pathname))) (values :device (or (pathname-device pathname) (pathname-device defaults)) #endif :directory (let ((pathname-dir (pathname-directory pathname)) (defaults-dir (pathname-directory defaults))) (if (eq (car pathname-dir) ':RELATIVE) (cond ((null (cdr pathname-dir)) defaults-dir) ((or *merge-pathnames-ansi* (not (eq (car defaults-dir) ':RELATIVE))) ; <---- (append defaults-dir (cdr pathname-dir))) (t pathname-dir)) pathname-dir))) (values #if HAS_HOST :host (pathname-host pathname) #endif #if HAS_DEVICE :device (pathname-device pathname) #endif :directory (pathname-directory pathname))) :name (or (pathname-name pathname) (pathname-name defaults)) :type (or (pathname-type pathname) (pathname-type defaults)))) If HAS_HOST and HAS_DEVICE are both true, the semantics are more complicated; see CLHS for details. If the :WILD argument is specified, :WILD components are replaced, instead of missing components. Explanation of the "<----" line: Roger Kehr asks why in CLISP (merge-pathnames (make-pathname :directory '(:relative "x")) (make-pathname :directory '(:relative "y"))) => #"x/" where he expects to get #"y/x/". Bruno: There are two reasons for this behaviour: 1. An informal one: I found the latter behaviour confusing and changed CLISP to do it the former way. It seems to work better this way. 2. A formal one: MERGE-PATHNAMES is used to specify default components for pathnames, so there is some analogy between (MERGE-PATHNAMES a b) and (or a b). Obviously putting in the same default a second time should do the same as putting it in once: (or a b b) is the same as (or a b), so (MERGE-PATHNAMES (MERGE-PATHNAMES a b) b) should be the same as (MERGE-PATHNAMES a b). (This question actually matters because in Common Lisp there is no distinction between "pathnames with defaults merged-in" and "pathnames with defaults not yet applied". For example, you do not know whether COMPILE-FILE will merge in some defaults.) Now, (MERGE-PATHNAMES (MERGE-PATHNAMES '#"x/" '#"y/") '#"y/") and (MERGE-PATHNAMES '#"x/" '#"y/") are equal in CLISP's implementation, but not in implementations that strictly follow the Common Lisp spec. In fact, the above twice-default = once-default rule holds for all pathnames in CLISP. */ LISPFUN(merge_pathnames,seclass_read,1,2,norest,key,1, (kw(wild))) { /* :wild #'make-pathname causes NIL components to be considered specified, only # components are considered unspecified. */ var bool called_from_make_pathname = eq(STACK_0,L(make_pathname)); /* :wild t causes only wild components to be considered unspecified. */ var bool wildp = !missingp(STACK_0); skipSTACK(1); #define SPECIFIED(obj) \ !(called_from_make_pathname ? !boundp(obj) : \ (wildp ? eq(obj,S(Kwild)) : nullp(obj))) #define NAMETYPE_MATCH(acc,slot) \ { var object tmp = x##slot(p_log,p); \ acc(newp)->slot = (SPECIFIED(tmp) ? tmp : (object)x##slot(d_log,d)); \ } /* check pathname (STACK_2) and defaults (STACK_1): (coerce defaults 'pathname): */ STACK_1 = test_default_pathname(STACK_1); /* (coerce pathname 'pathname): */ if (logpathnamep(STACK_1)) { if (!xpathnamep(STACK_2)) { /* pathname */ STACK_2 = parse_as_logical(STACK_2); DOUT("merge-pathnames:[log_pathname]",STACK_2); } } else STACK_2 = coerce_xpathname(STACK_2); /* pathname */ var bool d_log = logpathnamep(STACK_1); var bool p_log = logpathnamep(STACK_2); { /* check default-version (STACK_0): */ var object v = test_optional_version(unbound); var object p_version = xpathname_version(p_log,STACK_2); var object d_version = xpathname_version(d_log,STACK_1); var object p_name = xpathname_name(p_log,STACK_2); if (SPECIFIED(p_version)) v = p_version; if (missingp(v) && !SPECIFIED(p_name) && SPECIFIED(d_version)) v = d_version; if (!boundp(v)) v = S(Knewest); STACK_0 = STACK_1; STACK_1 = STACK_2; STACK_2 = v; DOUT("merge-pathnames:",v); } /* stack layout: default-version, pathname, defaults. */ /* do the merge */ DOUT("merge-pathnames:[defaults]",STACK_0); DOUT("merge-pathnames:[pathname]",STACK_1); if (d_log || p_log) { /* MERGE-PATHNAMES for logical pathnames */ var object newp = allocate_logpathname(); /* fetch new pathname */ var object d = popSTACK(); /* defaults */ var object p = popSTACK(); /* pathname */ { /* match hosts: */ var object p_host = xpathname_host(p_log,p); var object d_host = xpathname_host(d_log,d); TheLogpathname(newp)->pathname_host = p_host; /* initially, new-host := pathname-host */ if (equal(p_host,d_host)) goto lmatch_directories; if (wildp ? !boundp(p_host) : nullp(p_host)) { /* pathname-host not specified, but defaults-host specified: */ TheLogpathname(newp)->pathname_host = d_host; /* new-host := defaults-host */ goto lmatch_directories; } } { /* directories do not match: new-directory := pathname-directory */ var object dir = xpathname_directory(p_log,p); TheLogpathname(newp)->pathname_directory = (!SPECIFIED(dir) ? xpathname_directory(d_log,d) : dir); goto ldirectories_OK; } lmatch_directories: { /* match directories: */ pushSTACK(p); pushSTACK(d); pushSTACK(newp); TheLogpathname(STACK_0)->pathname_directory = merge_dirs(xpathname_directory(p_log,p), xpathname_directory(d_log,d), p_log,wildp,called_from_make_pathname); newp = popSTACK(); d = popSTACK(); p = popSTACK(); } ldirectories_OK: /* the directories are OK now */ NAMETYPE_MATCH(TheLogpathname,pathname_name); NAMETYPE_MATCH(TheLogpathname,pathname_type); TheLogpathname(newp)->pathname_version = popSTACK(); DOUT("merge-pathnames:[ret]",newp); VALUES1(newp); return; } /* not both are logical pathnames -> first, convert into normal pathnames: */ STACK_1 = coerce_pathname(STACK_1); STACK_0 = coerce_pathname(STACK_0); var object newp = allocate_pathname(); /* fetch new pathname */ var object d = popSTACK(); /* defaults */ var object p = popSTACK(); /* pathname */ #if HAS_HOST { /* match hosts: */ var object p_host = ThePathname(p)->pathname_host; var object d_host = ThePathname(d)->pathname_host; ThePathname(newp)->pathname_host = p_host; /* initially, new-host := pathname-host */ /* both hosts equal -> match devices: */ if (equal(p_host,d_host)) goto match_devices; if (!(wildp ? false : nullp(p_host))) goto notmatch_devices; #ifdef PATHNAME_WIN32 var object p_device = ThePathname(p)->pathname_device; /* On Win32, a non-null p_device implicitly designates p_host as the local machine. It must not be overridden by d_host. */ if (SPECIFIED(p_device)) goto notmatch_devices; #endif /* pathname-host not specified, but defaults-host specified: */ ThePathname(newp)->pathname_host = d_host; /* new-host := defaults-host */ goto match_devices; } #endif /* HAS_HOST */ match_devices: #if HAS_DEVICE { /* match devices: */ var object p_device = ThePathname(p)->pathname_device; var object d_device = ThePathname(d)->pathname_device; ThePathname(newp)->pathname_device = p_device; /* initially, new-device := pathname-device */ /* both devices equal -> match directories: */ if (equal(p_device,d_device)) goto match_directories; if (!SPECIFIED(p_device)) { /* pathname-device not given, but defaults-device is given: */ ThePathname(newp)->pathname_device = d_device; /* new-device := defaults-device */ goto match_directories; } goto notmatch_directories; } #endif /* HAS_DEVICE */ match_directories: { /* match directories: */ var object tmp; pushSTACK(p); pushSTACK(d); pushSTACK(newp); tmp = merge_dirs(ThePathname(p)->pathname_directory, ThePathname(d)->pathname_directory, false,wildp,called_from_make_pathname); newp = popSTACK(); d = popSTACK(); p = popSTACK(); ThePathname(newp)->pathname_directory = tmp; } goto directories_OK; /* do not match devices: */ notmatch_devices: #if HAS_DEVICE { /* new-device := pathname-device : */ ThePathname(newp)->pathname_device = ThePathname(p)->pathname_device; } #endif notmatch_directories: { /* directories do not match: new-directory := pathname-directory */ var object dir = xpathname_directory(p_log,p); ThePathname(newp)->pathname_directory = (missingp(dir) ? xpathname_directory(d_log,d) : dir); } directories_OK: /* the directories are OK now */ NAMETYPE_MATCH(ThePathname,pathname_name); NAMETYPE_MATCH(ThePathname,pathname_type); ThePathname(newp)->pathname_version = popSTACK(); DOUT("merge-pathnames:[ret]",newp); VALUES1(newp); } #undef SPECIFIED #undef NAMETYPE_MATCH /* (ENOUGH-NAMESTRING pathname [defaults]), CLTL p. 417 Definition assuming that HAS_HOST and HAS_DEVICE are exclusive: (defun enough-namestring (pathname &optional (defaults *default-pathname-defaults*)) (setq pathname (pathname pathname)) (setq defaults (pathname defaults)) (namestring (multiple-value-call #'make-pathname #if HAS_HOST (if (equal (pathname-host pathname) (pathname-host defaults)) (values :host nil #endif #if HAS_DEVICE (if (equal (pathname-device pathname) (pathname-device defaults)) (values :device nil #endif :directory (let ((pathname-dir (pathname-directory pathname)) (defaults-dir (pathname-directory defaults))) (if (equal pathname-dir defaults-dir) (list ':RELATIVE) (if (and (not (eq (car pathname-dir) ':RELATIVE)) (not (eq (car defaults-dir) ':RELATIVE)) (equal (subseq pathname-dir 0 (min (length pathname-dir) (length defaults-dir))) defaults-dir ) ) (cons ':RELATIVE (nthcdr (length defaults-dir) pathname-dir)) pathname-dir ) ) ) ) (values #if HAS_HOST :host (pathname-host pathname) #endif #if HAS_DEVICE :device (pathname-device pathname) #endif :directory (pathname-directory pathname))) :name (if (equal (pathname-name pathname) (pathname-name defaults)) nil (pathname-name pathname)) :type (if (equal (pathname-type pathname) (pathname-type defaults)) nil (pathname-type pathname))))) If HAS_HOST and HAS_DEVICE are both true, the semantics are more complicated; see CLHS for details. */ #define SET_NEWP(slot,value) \ if (log2) TheLogpathname(newp)->slot = value; \ else ThePathname(newp)->slot = value; LISPFUN(enough_namestring,seclass_read,1,1,norest,nokey,0,NIL) { /* check pathname and defaults: turn pathname into a Pathname: */ STACK_1 = coerce_xpathname(STACK_1); var bool log2 = logpathnamep(STACK_1); /* turn defaults into a Pathname: */ STACK_0 = test_default_pathname(STACK_0); var bool log1 = logpathnamep(STACK_0); /* fetch new Pathname: */ var object newp = (log2 ? allocate_logpathname() : allocate_pathname()); pushSTACK(newp); /* stack layout: pathname, defaults, new. */ #if HAS_HOST { /* compare hosts: */ var object p_host = xpathname_host(log2,STACK_2); /* pathname-host */ var object d_host = xpathname_host(log1,STACK_1); /* defaults-host */ if (equal(p_host,d_host)) { /* both hosts equal? */ SET_NEWP(pathname_host,NIL); /* new-host := NIL */ #endif #if HAS_DEVICE { /* compare devices: */ var object p_device = xpathname_device(log2,STACK_2); var object d_device = xpathname_device(log1,STACK_1); if (equal(p_device,d_device)) { /* both devices equal? */ if (!log2) ThePathname(newp)->pathname_device = NIL; #endif { var object p_directory = xpathname_directory(log2,STACK_2); var object d_directory = xpathname_directory(log1,STACK_1); var object new_subdirs; /* compare pathname-subdirs and defaults-subdirs: */ if (equal(p_directory,d_directory)) { /* ==> use NIL : */ new_subdirs = NIL; } else { /* Does neither pathname-subdirs nor defaults-subdirs start with :RELATIVE ? */ if ( consp(p_directory) && (eq(Car(p_directory),S(Kabsolute))) && consp(d_directory) && (eq(Car(d_directory),S(Kabsolute)))) { /* yes -> test, if defaults-subdirs is a starting piece of the list pathname-subdirs: */ var object Lp = p_directory; var object Ld = d_directory; /* Is Ld a starting piece of Lp ? */ while (1) { if (atomp(Ld)) { /* Ld finished -> yes */ new_subdirs = Lp; /* new-subdirs := (cons :RELATIVE new-subdirs) : */ pushSTACK(new_subdirs); new_subdirs = allocate_cons(); Cdr(new_subdirs) = popSTACK(); Car(new_subdirs) = S(Krelative); goto subdirs_ok; } if (atomp(Lp)) break; /* Lp finished -> no */ if (!equal(Car(Ld),Car(Lp))) /* different list-elements? */ break; /* -> no */ Ld = Cdr(Ld); Lp = Cdr(Lp); /* advance lists */ } } new_subdirs = p_directory; /* new-subdirs := pathname-subdirs */ } subdirs_ok: /* new-subdirs is the new subdir-list. */ /* new-directory := new-subdirs : */ newp = STACK_0; SET_NEWP(pathname_directory,new_subdirs); } #if HAS_DEVICE } else { /* different devices (Note for PATHNAME_WIN32: If we have different devices, the common host must have been NIL.) new-device := pathname-device new-directory := pathname-directory */ if (log2) { TheLogpathname(newp)->pathname_directory = TheLogpathname(STACK_2)->pathname_directory; } else { ThePathname(newp)->pathname_device = p_device; ThePathname(newp)->pathname_directory = ThePathname(STACK_2)->pathname_directory; } } } #endif #if HAS_HOST } else { /* different hosts */ /* new-host := pathname-host new-device := pathname-device new-directory := pathname-directory */ if (log2) { TheLogpathname(newp)->pathname_host = p_host; TheLogpathname(newp)->pathname_directory = TheLogpathname(STACK_2)->pathname_directory; } else { ThePathname(newp)->pathname_host = p_host; #if HAS_DEVICE ThePathname(newp)->pathname_device = ThePathname(STACK_2)->pathname_device; #endif ThePathname(newp)->pathname_directory = ThePathname(STACK_2)->pathname_directory; } } } #endif { /* fill in name: */ var object p_name = xpathname_name(log2,STACK_2); /* pathname-name */ var object d_name = xpathname_name(log1,STACK_1); /* defaults-name */ var object r_name = (equal(p_name,d_name) ? NIL : p_name); SET_NEWP(pathname_name,r_name); } { /* fill in type: */ var object p_type = xpathname_type(log2,STACK_2); /* pathname-type */ var object d_type = xpathname_type(log1,STACK_1); /* defaults-type */ var object r_type = (equal(p_type,d_type) ? NIL : p_type); SET_NEWP(pathname_type,r_type); } skipSTACK(3); /* build (namestring new) : */ with_saved_back_trace_subr(L(namestring),STACK STACKop -1,-1, VALUES1(whole_namestring(newp)); ); } #undef SET_NEWP /* UP: checks, if object is an admissible name: :WILD or a Simple-String made of valid characters, without adjacent '*'. legal_logical_word(object) > object: if a simple-string, a normal-simple-string */ local bool legal_logical_word (object obj) { if (eq(obj,S(Kwild))) return true; if (!simple_string_p(obj)) return false; ASSERT(sstring_normal_p(obj)); var uintL len = Sstring_length(obj); if (len==0) return false; /* empty word is forbidden */ SstringDispatch(obj,X, { var const cintX* charptr = &((SstringX)TheVarobject(obj))->data[0]; var bool last_was_star = false; dotimespL(len,len, { var chart cc = as_chart(*charptr++); if (!(legal_logical_word_char(cc) || multiwild_char_p(cc))) return false; if (multiwild_char_p(cc)) { if (last_was_star) return false; /* adjacent '*' are forbidden */ last_was_star = true; } else { last_was_star = false; } }); }); return true; } #ifdef PATHNAME_NOEXT /* UP: checks, if object is an admissible name: a Simple-String made of valid characters legal_name(object) > object: any object */ #define legal_name(obj) check_name(obj,NULL) /* also, return the _BASE ONE_ index of the first dot in the string */ local bool check_name (object obj, uintL *dot_pos_) { if (dot_pos_) *dot_pos_ = 0; if (!stringp(obj)) return false; var uintL len, offset; obj = unpack_string_ro(obj,&len,&offset); if (len > 0) { SstringDispatch(obj,X, { var const cintX* start = ((SstringX)TheVarobject(obj))->data + offset; var const cintX* charptr = start; do { var chart cc = as_chart(*charptr++); if (!legal_namechar(cc)) return false; if (dot_pos_ && *dot_pos_==0 && dotp(cc)) *dot_pos_ = charptr - start; } while(--len); }); } return true; } /* UP: checks, if object is an admissible name: a Simple-String made of valid characters, without '.' legal_type(object) > object: if a simple-string, a normal-simple-string */ local bool legal_type (object obj); #ifdef PATHNAME_NOEXT local bool legal_type (object obj) { if (!simple_string_p(obj)) return false; ASSERT(sstring_normal_p(obj)); var uintL len = Sstring_length(obj); if (len > 0) { SstringDispatch(obj,X, { var const cintX* charptr = &((SstringX)TheVarobject(obj))->data[0]; dotimespL(len,len, { var chart cc = as_chart(*charptr++); if (dotp(cc) || !legal_namechar(cc)) return false; }); }); } return true; } /* Check that the namestring for path will be parsed into a similar object used by pr_orecord() in io.d can trigger GC */ global maygc bool namestring_correctly_parseable_p (gcv_object_t *path_) { /* #p".foo" can be either :name ".foo" or :type "foo" */ var object name = ThePathname(*path_)->pathname_name; var object type = ThePathname(*path_)->pathname_type; var uintL dot_position; check_name(name,&dot_position); /* we know it's valid! */ if (eq(Symbol_value(S(parse_namestring_dot_file)),S(Ktype))) { parse_namestring_dot_file_type: /* ".foo" ==> :type "foo" */ if (nullp(type) && dot_position>0) return false; /* name has '.' => bad */ } else if (eq(Symbol_value(S(parse_namestring_dot_file)),S(Kname))) { /* ".foo" ==> :name ".foo" */ if (nullp(name) && !nullp(type)) return false; /* has dots _inside_ the name, and type=nil */ if (nullp(type) && dot_position>1) return false; } else { fix_parse_namestring_dot_file(); /* set to :TYPE */ name = ThePathname(*path_)->pathname_name; /* restore after posible GC */ type = ThePathname(*path_)->pathname_type; goto parse_namestring_dot_file_type; } /* name cannot be "": it is replaced with NIL by MAKE-PATHNAME; */ #if HAS_VERSION /* when the underlying physical file system DOES support version, we are confident - for no good reason so far! - that we will be able to print the pathname properly */ return true; #else /* when the underlying physical file system does NOT support version, pathname version is not printed, so cannot be read back! */ return nullp(ThePathname(*path_)->pathname_version); #endif } #endif #endif /* PATHNAME_NOEXT */ local object copy_pathname (object pathname); /* check whether the list is a valid directory list */ local bool directory_list_valid_p (bool logical, object dirlist) { { /* CAR must be either :RELATIVE or :ABSOLUTE ? */ var object startpoint = Car(dirlist); if (!(eq(startpoint,S(Krelative)) || eq(startpoint,S(Kabsolute)))) return false; } dirlist = Cdr(dirlist); /* check subdir list: */ while (consp(dirlist)) { /* check the next subdir = POP(dirlist); */ var object subdir = Car(dirlist); dirlist = Cdr(dirlist); if (logical) { if (!(eq(subdir,S(Kwild_inferiors)) || eq(subdir,S(Kwild)) || legal_logical_word(subdir) || eq(subdir,S(Kup)))) return false; } else { #ifdef PATHNAME_NOEXT #if defined(PATHNAME_UNIX) || defined(PATHNAME_WIN32) if (!(eq(subdir,S(Kwild_inferiors)) || eq(subdir,S(Kwild)) || legal_name(subdir) || eq(subdir,S(Kup)))) return false; #endif #endif } } return true; } #define COERCE_PATHNAME_SLOT(slot,obj,stack_res) \ stack_res = ThePathname(coerce_pathname(obj))->pathname_##slot /* (MAKE-PATHNAME [:host] [:device] [:directory] [:name] [:type] [:version] [:defaults] [:case]), CLTL p. 416, CLtL2 p. 643 */ LISPFUN(make_pathname,seclass_read,0,0,norest,key,8, (kw(defaults),kw(case),kw(host),kw(device),kw(directory), kw(name),kw(type),kw(version)) ) { /* stack layout: defaults, case, host, device, directory, name, type, version. */ var bool logical = false; var bool convert = eq(STACK_6,S(Kcommon)); /* 0. check defaults (STACK_7): */ if (boundp(STACK_7)) { if (!nullpSv(parse_namestring_ansi) && stringp(STACK_7) && looks_logical_p(STACK_7)) STACK_7 = parse_as_logical(STACK_7); else STACK_7 = coerce_xpathname(STACK_7); } /* 1. check host: */ if (logpathnamep(STACK_5)) { STACK_5 = TheLogpathname(STACK_5)->pathname_host; logical = true; } if (!boundp(STACK_5)) { var object d_path = defaults_pathname(); STACK_5 = (!boundp(STACK_7) ? xpathname_host(logpathnamep(d_path),d_path) : xpathname_host(logpathnamep(STACK_7),STACK_7)); } else { #if HAS_HOST STACK_5 = test_optional_host(STACK_5,convert); #else STACK_5 = test_optional_host(STACK_5); #endif } if (!nullp(STACK_5) && logical_host_p(STACK_5)) { logical = true; STACK_5 = string_upcase(STACK_5); } DOUT("make-pathname:[version]",STACK_0); DOUT("make-pathname:[type]",STACK_1); DOUT("make-pathname:[name]",STACK_2); DOUT("make-pathname:[directory]",STACK_3); DOUT("make-pathname:[device]",STACK_4); DOUT("make-pathname:[host]",STACK_5); DOUT("make-pathname:[case]",STACK_6); DOUT("make-pathname:[defaults]",STACK_7); #if HAS_DEVICE { /* 2. check device: */ var object device = STACK_4; if (!boundp(device)) { if (!boundp(STACK_7)) /* no defaults? */ STACK_4 = NIL; /* -> use NIL */ } else { if (stringp(device)) STACK_4 = device = coerce_normal_ss(device); if (convert) STACK_4 = device = common_case(device); if (nullp(device)) /* = NIL ? */ goto device_ok; else if (logical) { if (logpathnamep(device) /* Pathname -> its device */ || (eq(device,S(Kunspecific)))) { /* :UNSPECIFIC -> NIL */ STACK_4 = NIL; goto device_ok; } } #ifdef PATHNAME_WIN32 else if (eq(device,S(Kwild))) /* = :WILD ? */ goto device_ok; else if (simple_string_p(device)) { /* Simple-String ? */ if (Sstring_length(device) == 1) { /* of length 1 ? */ var chart ch = schar(device,0); if ((as_cint(ch) >= 'A') && (as_cint(ch) <= 'Z')) /* with letters >='A' and <='Z' ? */ goto device_ok; } } #endif else if (xpathnamep(device)) { /* Pathname -> its Device */ COERCE_PATHNAME_SLOT(device,device,STACK_4); goto device_ok; } /* None of the desired cases -> error: */ pushSTACK(STACK_4); pushSTACK(S(Kdevice)); goto error_arg; device_ok: ; #ifdef PATHNAME_WIN32 if (!nullp(STACK_5) && !nullp(STACK_4)) { pushSTACK(STACK_4); pushSTACK(STACK_(5+1)); pushSTACK(TheSubr(subr_self)->name); error(error_condition, GETTEXT("~S: on host ~S, device ~S is invalid, should be NIL")); } #endif } } #else /* HAS_DEVICE */ { var object device = STACK_4; if (boundp(device)) { /* specified ? */ if (!(nullp(device) || eq(device,S(Kunspecific)) || xpathnamep(device))) { /* NIL or :UNSPECIFIC or Pathname -> OK */ /* None of the desired cases -> error: */ pushSTACK(STACK_4); pushSTACK(S(Kdevice)); goto error_arg; } } } #endif { /* 3. check directory: */ DOUT("make-pathname:[directory]",STACK_3); var object directory = STACK_3; if (!boundp(directory) && boundp(STACK_7)) { /* not specified but defaults is supplied */ goto directory_ok; } else if (missingp(directory)) { /* not specified or NIL */ STACK_3 = NIL; /* default_directory == NIL */ goto directory_ok; } else if (eq(directory,S(Kwild)) || eq(directory,S(Kwild_inferiors))) { directory = S(Kwild_inferiors); goto directory_add_absolute; } else if (stringp(directory)) { if (!legal_name(directory)) goto directory_bad; STACK_3 = directory = coerce_normal_ss(directory); directory_add_absolute: pushSTACK(S(Kabsolute)); pushSTACK(directory); directory = listof(2); STACK_3 = directory; goto directory_ok; } else if (consp(directory)) { /* a Cons? */ STACK_3 = directory = simplify_directory(copy_list(directory)); if (convert) STACK_3 = directory = subst_common_case(directory); if (!directory_list_valid_p(logical,directory)) goto directory_bad; else goto directory_ok; } else if (logical) { if (logpathnamep(directory)) { /* Pathname -> its Directory */ STACK_3 = TheLogpathname(directory)->pathname_directory; goto directory_ok; } } else if (xpathnamep(directory)) { /* Pathname -> its Directory */ COERCE_PATHNAME_SLOT(directory,directory,STACK_3); goto directory_ok; } /* None of the desired cases -> error: */ directory_bad: { pushSTACK(STACK_3); pushSTACK(S(Kdirectory)); } goto error_arg; directory_ok: ; } { /* 4. check name: */ DOUT("make-pathname:[name]",STACK_2); var object name = STACK_2; if (stringp(name)) STACK_2 = name = coerce_normal_ss(name); if (convert) STACK_2 = name = common_case(name); if (!boundp(name)) { /* not specified */ if (!boundp(STACK_7)) /* no defaults? */ STACK_2 = NIL; /* -> use NIL */ } else if (equal(name,O(empty_string))) { /* name = "" ? */ STACK_2 = NIL; /* -> use NIL */ } else if (nullp(name)) { /* NIL is OK */ } else if (logical) { if (legal_logical_word(name)) { /* OK */ } else if (logpathnamep(name)) { /* Pathname -> its Name */ STACK_2 = TheLogpathname(name)->pathname_name; } else { /* None of the desired cases -> error: */ pushSTACK(STACK_2); pushSTACK(S(Kname)); goto error_arg; } } #ifdef PATHNAME_NOEXT else if (eq(name,S(Kwild))) { /* :WILD is OK */ } #endif else if (legal_name(name)) { /* admissible Name is OK */ STACK_2 = name = coerce_normal_ss(name); } else if (xpathnamep(name)) { /* Pathname -> its Name */ COERCE_PATHNAME_SLOT(name,name,STACK_2); } else { /* None of the desired cases -> error: */ pushSTACK(STACK_2); pushSTACK(S(Kname)); goto error_arg; } } { /* 5. check type: */ DOUT("make-pathname:[type]",STACK_1); var object type = STACK_1; if (stringp(type)) STACK_1 = type = coerce_normal_ss(type); if (convert) STACK_1 = type = common_case(type); if (!boundp(type)) { if (!boundp(STACK_7)) /* no Defaults ? */ STACK_1 = NIL; /* -> use NIL */ } else if (nullp(type)) { /* NIL is OK */ } else if (logical) { if (legal_logical_word(type)) { /* OK */ } else if (logpathnamep(type)) { /* Pathname -> its Type */ STACK_1 = TheLogpathname(type)->pathname_type; } else { /* None of the desired cases -> error: */ pushSTACK(STACK_1); pushSTACK(S(Ktype)); goto error_arg; } } #ifdef PATHNAME_NOEXT else if (eq(type,S(Kwild))) { /* :WILD is OK */ } #endif else if (legal_type(type)) { } else if (xpathnamep(type)) { /* Pathname -> its Type */ COERCE_PATHNAME_SLOT(type,type,STACK_1); } else { /* None of the desired cases -> error: */ pushSTACK(STACK_1); pushSTACK(S(Ktype)); goto error_arg; } } /* 6. check version: */ { STACK_0 = test_optional_version(!boundp(STACK_7) ? NIL : unbound); } DOUT("make-pathname:[ver]",STACK_0); DOUT("make-pathname:[ver]",STACK_7); { /* 7. build Pathname: */ var object pathname; if (logical) { pathname = allocate_logpathname(); /* new Logical Pathname */ TheLogpathname(pathname)->pathname_version = popSTACK(); TheLogpathname(pathname)->pathname_type = popSTACK(); TheLogpathname(pathname)->pathname_name = popSTACK(); TheLogpathname(pathname)->pathname_directory = popSTACK(); skipSTACK(1); TheLogpathname(pathname)->pathname_host = popSTACK(); } else { pathname = allocate_pathname(); /* new Pathname */ ThePathname(pathname)->pathname_version = popSTACK(); ThePathname(pathname)->pathname_type = popSTACK(); ThePathname(pathname)->pathname_name = popSTACK(); ThePathname(pathname)->pathname_directory = popSTACK(); #if HAS_DEVICE ThePathname(pathname)->pathname_device = popSTACK(); #else skipSTACK(1); #endif #if HAS_HOST ThePathname(pathname)->pathname_host = popSTACK(); #else skipSTACK(1); #endif } STACK_0 = pathname; /* forget case */ DOUT("make-pathname:[pathname]",STACK_0); DOUT("make-pathname:[defaults]",STACK_1); pathname = popSTACK(); /* 8. poss. merge in Defaults: */ var object defaults = popSTACK(); if (!boundp(defaults)) { /* no defaults given -> pathname is the value */ value1 = pathname; } else { /* (MERGE-PATHNAMES pathname defaults [nil] :wild #'make-pathname) */ pushSTACK(pathname); pushSTACK(defaults); pushSTACK(unbound); pushSTACK(S(Kwild)); pushSTACK(L(make_pathname)); funcall(L(merge_pathnames),5); } mv_count=1; DOUT("make-pathname:[ret]",value1); return; } error_arg: /* error-message: */ pushSTACK(TheSubr(subr_self)->name); error(error_condition,GETTEXT("~S: Illegal ~S argument ~S")); } #undef COERCE_PATHNAME_SLOT /* (MAKE-LOGICAL-PATHNAME [:host] [:device] [:directory] [:name] [:type] [:version] [:defaults] [:case]), like MAKE-PATHNAME, except that a Logical Pathname is built. */ LISPFUN(make_logical_pathname,seclass_read,0,0,norest,key,8, (kw(defaults),kw(case),kw(host),kw(device), kw(directory),kw(name),kw(type),kw(version)) ) { /* A logical pathname as :HOST-Argument for MAKE-PATHNAME enforces a logical pathname as result. */ if (boundp(STACK_5)) STACK_5 = string_upcase(STACK_5); /* host */ else STACK_5 = NIL; { var object obj = allocate_logpathname(); TheLogpathname(obj)->pathname_host = STACK_5; STACK_5 = obj; } /* PATHNAME-DEVICE for LOGICAL-PATHNAME returns :UNSPECIFIC, so MAKE-LOGICAL-PATHNAME must accept :DEVICE :UNSPECIFIC */ if (eq(STACK_4,S(Kunspecific))) STACK_4 = NIL; /* device */ /* continue at MAKE-PATHNAME. */ C_make_pathname(); } /* (USER-HOMEDIR-PATHNAME [host]), CLTL p. 418 */ LISPFUN(user_homedir_pathname,seclass_default,0,1,norest,nokey,0,NIL) { DOUT("user-homedir-pathname:[host]",STACK_0); #if HAS_HOST STACK_0 = test_optional_host(STACK_0,false); /* check Host */ if (!nullp(STACK_0)) { #if defined(PATHNAME_WIN32) { /* This is very primitive. Does Windows have the notion of homedirs on remote hosts?? */ var object pathname = allocate_pathname(); /* new Pathname */ ThePathname(pathname)->pathname_host = popSTACK(); #if HAS_DEVICE ThePathname(pathname)->pathname_device = NIL; #endif ThePathname(pathname)->pathname_directory = O(directory_absolute); ThePathname(pathname)->pathname_name = NIL; ThePathname(pathname)->pathname_type = NIL; ThePathname(pathname)->pathname_version = NIL; VALUES1(pathname); } #else #error user-homedir-pathname: HAS_HOST & !WIN32 #endif } else { /* no host given */ skipSTACK(1); VALUES1(O(user_homedir)); /* User-Homedir-Pathname */ } #else /* HAS_HOST */ test_optional_host(popSTACK()); /* check Host and ignore */ VALUES1(O(user_homedir)); /* User-Homedir-Pathname */ #endif DOUT("user-homedir-pathname:[ret]",value1); } /* UP: copies a pathname. copy_pathname(pathname) > pathname: non-logical pathname < result: copy of the pathname, with the same components can trigger GC */ local maygc object copy_pathname (object pathname) { pushSTACK(pathname); var object newp = allocate_pathname(); pathname = popSTACK(); #if HAS_HOST ThePathname(newp)->pathname_host = ThePathname(pathname)->pathname_host; #endif #if HAS_DEVICE ThePathname(newp)->pathname_device = ThePathname(pathname)->pathname_device; #endif ThePathname(newp)->pathname_directory = ThePathname(pathname)->pathname_directory; ThePathname(newp)->pathname_name = ThePathname(pathname)->pathname_name; ThePathname(newp)->pathname_type = ThePathname(pathname)->pathname_type; ThePathname(newp)->pathname_version = ThePathname(pathname)->pathname_version; return newp; } /* * Wildcards * ========= */ /* UP: check whether the object is wild name(object) > object: normal simple-string or symbol < return: true when the object is wild */ #define DEF_WILD_CHECKER(name,char_wild_p) \ local bool name (object obj, bool dirp) { \ if (simple_string_p(obj)) { \ var uintL len = Sstring_length(obj); \ if (len > 0) { \ SstringDispatch(obj,X, { \ const cintX* charptr = &((SstringX)TheVarobject(obj))->data[0]; \ dotimespL(len,len, { \ chart ch = as_chart(*charptr++); \ if (char_wild_p(ch)) \ return true; \ }); \ }); \ } \ return false; \ } else \ return eq(obj,S(Kwild)) || (dirp && eq(obj,S(Kwild_inferiors))); \ } #ifdef PATHNAME_NOEXT DEF_WILD_CHECKER(wild_p,wild_char_p) #endif DEF_WILD_CHECKER(word_wild_p,multiwild_char_p) /* UP: checks, if the host-component of a pathname contains wildcards. has_host_wildcards(pathname) > pathname: pathname < result: true if (PATHNAME-HOST pathname) contains wildcards. */ local bool has_host_wildcards (object pathname); /* host can not contain wildcards. */ #define has_host_wildcards(pathname) (unused (pathname), false) /* UP: checks, if the device-component of a pathname contains wildcards. has_device_wildcards(pathname) > pathname: pathname < result: true if (PATHNAME-DEVICE pathname) contains wildcards. */ local bool has_device_wildcards (object pathname) { #ifdef PATHNAME_WIN32 if (logpathnamep(pathname)) return false; /* check device: = :WILD ? */ return eq(ThePathname(pathname)->pathname_device,S(Kwild)); #else return false; #endif } /* UP: checks, if the directory-component of a pathname contains wildcards. has_directory_wildcards(pathname) > pathname: pathname < result: true if (PATHNAME-DIRECTORY pathname) contains wildcards. */ local bool has_directory_wildcards (object pathname) { /* check directory: */ if (logpathnamep(pathname)) { var object directory = TheLogpathname(pathname)->pathname_directory; for (;consp(directory); directory = Cdr(directory)) if (word_wild_p(Car(directory),true)) return true; return false; } var object directory = ThePathname(pathname)->pathname_directory; for (;consp(directory); directory = Cdr(directory)) if (wild_p(Car(directory),true)) return true; return false; } /* UP: checks, if the name-component of a pathname contains wildcards. has_name_wildcards(pathname) > pathname: pathname < result: true if (PATHNAME-NAME pathname) contains wildcards. */ local bool has_name_wildcards (object pathname) { /* check name: */ if (logpathnamep(pathname)) return word_wild_p(TheLogpathname(pathname)->pathname_name,false); #ifdef PATHNAME_NOEXT return wild_p(ThePathname(pathname)->pathname_name,false); #endif return false; } /* UP: checks, if the type-component of a pathname contains wildcards. has_type_wildcards(pathname) > pathname: pathname < result: true if (PATHNAME-TYPE pathname) contains wildcards. */ local bool has_type_wildcards (object pathname) { /* check type: */ if (logpathnamep(pathname)) return word_wild_p(TheLogpathname(pathname)->pathname_type,false); #ifdef PATHNAME_NOEXT return wild_p(ThePathname(pathname)->pathname_type,false); #endif return false; } /* UP: checks, if the version-component of a pathname contains wildcards. has_version_wildcards(pathname) > pathname: pathname < result: true if (PATHNAME-VERSION pathname) contains wildcards. */ local bool has_version_wildcards (object pathname) { /* check version: */ return eq(S(Kwild),xpathname_version(logpathnamep(pathname),pathname)); } /* UP: checks, if any component of a pathname contains wildcards. has_some_wildcards(pathname) > pathname: pathname < result: true if pathname contains wildcards. */ local bool has_some_wildcards (object pathname) { if (has_host_wildcards(pathname)) return true; if (has_device_wildcards(pathname)) return true; if (has_directory_wildcards(pathname)) return true; if (has_name_wildcards(pathname)) return true; if (has_type_wildcards(pathname)) return true; if (has_version_wildcards(pathname)) return true; return false; } /* UP: checks, if a pathname contains no wildcards. check_no_wildcards(pathname); > pathname: pathname */ local void check_no_wildcards (object pathname) { if (!has_some_wildcards(pathname)) /* no wildcards found. */ return; /* error-message, if the pathname contains wildcards: */ pushSTACK(pathname); /* FILE-ERROR slot PATHNAME */ pushSTACK(pathname); pushSTACK(TheSubr(subr_self)->name); error(file_error,GETTEXT("~S: wildcards are not allowed here: ~S")); } LISPFUN(wild_pathname_p,seclass_rd_sig,1,1,norest,nokey,0,NIL) { /* (WILD-PATHNAME-P pathname [field-key]), CLtL2 p. 623 */ var object pathname = coerce_xpathname(STACK_1); var object key = STACK_0; var bool erg; if (missingp(key)) { erg = has_some_wildcards(pathname); } else if (eq(key,S(Khost))) { erg = has_host_wildcards(pathname); } else if (eq(key,S(Kdevice))) { erg = has_device_wildcards(pathname); } else if (eq(key,S(Kdirectory))) { erg = has_directory_wildcards(pathname); } else if (eq(key,S(Kname))) { erg = has_name_wildcards(pathname); } else if (eq(key,S(Ktype))) { erg = has_type_wildcards(pathname); } else if (eq(key,S(Kversion))) { erg = has_version_wildcards(pathname); } else { pushSTACK(key); /* TYPE-ERROR slot DATUM */ pushSTACK(O(type_pathname_field_key)); /* TYPE-ERROR slot EXPECTED-TYPE */ pushSTACK(NIL); pushSTACK(S(Kversion)); pushSTACK(S(Ktype)); pushSTACK(S(Kname)); pushSTACK(S(Kdirectory)); pushSTACK(S(Kdevice)); pushSTACK(S(Khost)); pushSTACK(key); pushSTACK(TheSubr(subr_self)->name); error(type_error, GETTEXT("~S: argument ~S should be ~S, ~S, ~S, ~S, ~S, ~S or ~S")); } VALUES_IF(erg); /* boolean value */ skipSTACK(2); } /* Wildcard Matching ================= */ /* For the purposes of wildcard matching, according to CLHS, non-present components (i.e. NIL or a directory = (:RELATIVE)) are treated as wild. */ /* UP: Matches a Wildcard-String ("Pattern") with a "Sample". > pattern : Normal-Simple-String, with wildcards '?' for exactly 1 character '*' for arbitrary many characters > sample : Normal-Simple-String, that has to be matched recursive implementation because of backtracking: */ local bool wildcard_match_ab (uintL m_count, const chart* m_ptr, uintL b_count, const chart* b_ptr); local bool wildcard_match (object pattern, object sample) { if (eq(pattern,S(Kwild)) || eq(pattern,S(Kwild_inferiors))) return true; if (eq(pattern,S(Kup)) || eq(pattern,S(Kback))) return false; ASSERT(sstring_normal_p(pattern)); ASSERT(sstring_normal_p(sample)); return wildcard_match_ab( /* m_count = */ Sstring_length(pattern), /* m_ptr = */ &TheSnstring(pattern)->data[0], /* b_count = */ Sstring_length(sample), /* b_ptr = */ &TheSnstring(sample)->data[0] ); } local bool wildcard_match_ab (uintL m_count, const chart* m_ptr, uintL b_count, const chart* b_ptr) { var chart c; while (1) { if (m_count==0) return (b_count==0); /* "" matches only "" */ m_count--; c = *m_ptr++; /* next match-character */ if (singlewild_char_p(c)) { /* wildcard '?' */ if (b_count==0) return false; /* at least one character still has to come */ b_count--; b_ptr++; /* it will be ignored */ } else if (multiwild_char_p(c)) break; /* wildcard '*' later */ else { /* everything else must match exactly: */ if (b_count==0) return false; b_count--; if (!equal_pathchar(*b_ptr++,c)) return false; } } /* Wildcard '*': Search next non-wildcard-character and also count the '?' (because a sequence '*??*???***?' matches everything, that is as least as long as the sequence of question marks). The '?' can also be utilized immediately, because '*??*???***?' is equivalent to '??????*' . */ while (1) { if (m_count==0) return true; /* wildcard at the end matches the rest. */ m_count--; c = *m_ptr++; /* next match-character */ if (singlewild_char_p(c)) { /* question mark: move forward, process instantly */ if (b_count==0) return false; b_count--; b_ptr++; } else if (!multiwild_char_p(c)) break; } /* c = next non-wildcard-character. Search it. */ while (1) { if (b_count==0) return false; /* c not found */ b_count--; if (equal_pathchar(*b_ptr++,c)) { if (wildcard_match_ab(m_count,m_ptr,b_count,b_ptr)) return true; } } } /* UPs: matches a pathname-component ("Sample") and a pathname-component ("Pattern") at a time. */ local bool host_match (object pattern, object sample, bool logical); local bool device_match (object pattern, object sample, bool logical); local bool directory_match (object pattern, object sample, bool logical); local bool nametype_match (object pattern, object sample, bool logical); local bool version_match (object pattern, object sample, bool logical); local bool host_match (object pattern, object sample, bool logical) {/* logical is ignored */ if (nullp(pattern)) return true; return equal(pattern,sample); } local bool device_match (object pattern, object sample, bool logical) { #if HAS_DEVICE if (logical) { return true; } if (nullp(pattern)) return true; #ifdef PATHNAME_WIN32 if (eq(pattern,S(Kwild))) return true; if (eq(sample,S(Kwild))) return false; #endif #ifdef PATHNAME_WIN32 return equalp(pattern,sample); #else return equal(pattern,sample); #endif #else return true; #endif } local bool nametype_match_aux (object pattern, object sample, bool logical) { /* logical is ignored */ if (eq(pattern,S(Kwild))) return true; if (eq(sample,S(Kwild))) return false; if (nullp(pattern)) { if (nullp(sample)) return true; else return false; } if (nullp(sample)) return false; return wildcard_match(pattern,sample); } local bool subdir_match (object pattern, object sample, bool logical) { /* logical is ignored */ if (eq(pattern,sample)) return true; if (eq(pattern,S(Kwild))) return true; if (!simple_string_p(pattern) || !simple_string_p(sample)) return false; return wildcard_match(pattern,sample); } /* recursive implementation because of backtracking: */ local bool directory_match_ab (object m_list, object b_list, bool logical); local bool directory_match_ab (object m_list, object b_list, bool logical) { /* Algorithm analogous to wildcard_match_ab. */ var object item; while (1) { if (atomp(m_list)) { return atomp(b_list); } item = Car(m_list); m_list = Cdr(m_list); if (eq(item,S(Kwild_inferiors))) break; if (atomp(b_list)) return false; if (!subdir_match(item,Car(b_list),logical)) return false; b_list = Cdr(b_list); } while (1) { if (atomp(m_list)) return true; item = Car(m_list); m_list = Cdr(m_list); if (!eq(item,S(Kwild_inferiors))) break; } while (1) { if (atomp(b_list)) return false; if (subdir_match(item,Car(b_list),logical)) { b_list = Cdr(b_list); if (directory_match_ab(m_list,b_list,logical)) return true; } else { b_list = Cdr(b_list); } } } local inline bool directory_trivial_p (object dir) { return nullp(dir) || (consp(dir) ? (eq(Car(dir),S(Krelative)) && nullp(Cdr(dir))) : false); } local bool directory_match (object pattern, object sample, bool logical) { if (nullp(pattern)) /* compare pattern with directory_default */ return true; if (missingp(sample)) return true; /* match startpoint: */ if (!eq(Car(pattern),Car(sample))) return false; pattern = Cdr(pattern); sample = Cdr(sample); /* match subdirs: */ return directory_match_ab(pattern,sample,logical); } local bool nametype_match (object pattern, object sample, bool logical) { if (missingp(pattern)) return true; return nametype_match_aux(pattern,sample,logical); } local bool version_match (object pattern, object sample, bool logical) { /* logical is ignored */ SDOUT("version_match:",pattern); SDOUT("version_match:",sample); if (!boundp(sample)) return true; if (nullp(pattern) || eq(pattern,S(Kwild))) return true; if (eq(sample,S(Kwild))) return false; return eql(pattern,sample); } LISPFUNNS(pathname_match_p,2) { /* (PATHNAME-MATCH-P pathname wildname), CLtL2 p. 623 */ /* stack layout: pathname, wildname. */ var bool logical = false; STACK_1 = coerce_xpathname(STACK_1); STACK_0 = coerce_xpathname(STACK_0); if (logpathnamep(STACK_1) && logpathnamep(STACK_0)) { logical = true; } else { /* not both logical pathnames -> first convert into normal pathnames: */ STACK_1 = coerce_pathname(STACK_1); STACK_0 = coerce_pathname(STACK_0); } DOUT("pathname-match-p:[s0]",STACK_0); DOUT("pathname-match-p:[s1]",STACK_1); var object wildname = popSTACK(); var object pathname = popSTACK(); if (!host_match(xpathname_host(logical,wildname), xpathname_host(logical,pathname), logical)) goto no; if (!device_match(xpathname_device(logical,wildname), xpathname_device(logical,pathname), logical)) goto no; if (!directory_match(xpathname_directory(logical,wildname), xpathname_directory(logical,pathname), logical)) goto no; if (!nametype_match(xpathname_name(logical,wildname), xpathname_name(logical,pathname), logical)) goto no; if (!nametype_match(xpathname_type(logical,wildname), xpathname_type(logical,pathname), logical)) goto no; if (!version_match(xpathname_version(logical,wildname), xpathname_version(logical,pathname), logical)) goto no; yes: VALUES1(T); return; no: VALUES1(NIL); return; } /* (TRANSLATE-PATHNAME sample pattern1 pattern2) implemented as follows: 1. (PATHNAME-MATCH-P sample pattern1) while checking, extract text items from the substitution pattern (:WILD -> "*"). 2. Put the text items into pattern2 until pattern2 is full or all the text items are used up 3. finally, (MERGE-PATHNAMES modified_pattern2 sample). */ /* UP: Compare a wildcard string ("Pattern") with "Sample". wildcard_diff(pattern,sample,previous,solutions); > pattern: normal simple string, with substitution characters '?' for exactly 1 character '*' for as many characters as desired > sample: normal simple string, to compare with > previous: the already known result of comparison (reversed list of normal simple strings, NILs and lists) > solutions: address of a list in the STACK, onto which the results of the comparisons (reversed list of normal simple strings and lists) have to be consed can trigger GC */ /* Here you need not Lisp or C, but PROLOG! (PUSH previous solutions) */ #define push_solution() do { \ var object new_cons = allocate_cons(); \ Car(new_cons) = *previous; \ Cdr(new_cons) = *solutions; \ *solutions = new_cons; \ } while(0) /* (PUSH (CONS new_piece previous) solutions) */ #define push_solution_with(new_piece) do { \ pushSTACK(new_piece); \ {var object new_cons = allocate_cons(); \ Car(new_cons) = STACK_0; Cdr(new_cons) = *previous; \ STACK_0 = new_cons; \ new_cons = allocate_cons(); \ Car(new_cons) = popSTACK(); Cdr(new_cons) = *solutions; \ *solutions = new_cons; \ }} while(0) /* recursive implementation because of backtracking: */ local maygc void wildcard_diff_ab (object pattern, object sample, uintL m_index, uintL b_index, const gcv_object_t* previous, gcv_object_t* solutions) { var chart cc; while (1) { if (m_index == Sstring_length(pattern)) { if (b_index == Sstring_length(sample)) push_solution(); return; } cc = schar(pattern,m_index++); if (multiwild_char_p(cc)) break; if (b_index == Sstring_length(sample)) return; if (singlewild_char_p(cc)) { /* recursive call to wildcard_diff_ab(), with extended previous: */ cc = schar(sample,b_index++); pushSTACK(pattern); pushSTACK(sample); { var object new_string = allocate_string(1); TheS32string(new_string)->data[0] = as_cint(cc); pushSTACK(new_string); } { var object new_cons = allocate_cons(); Car(new_cons) = STACK_0; Cdr(new_cons) = *previous; STACK_0 = new_cons; /* (CONS ... previous) */ } wildcard_diff_ab(STACK_2,STACK_1,m_index,b_index,&STACK_0,solutions); skipSTACK(3); return; } else { if (!equal_pathchar(schar(sample,b_index++),cc)) return; } } var uintL b_start_index = b_index; while (1) { /* to reduce consing, intercept cases when wildcard_diff_ab() does nothing */ if (m_index == Sstring_length(pattern) ? b_index == Sstring_length(sample) : (cc = schar(pattern,m_index), wild_char_p(cc) || (b_index < Sstring_length(sample) && equal_pathchar(schar(sample,b_index),cc)))) { /* wildcard_diff_ab() recursive call, with extended previous: */ pushSTACK(pattern); pushSTACK(sample); /* (SUBSTRING sample b_start_index b_index) */ pushSTACK(subsstring(sample,b_start_index,b_index)); var object new_cons = allocate_cons(); Car(new_cons) = STACK_0; Cdr(new_cons) = *previous; STACK_0 = new_cons; /* (CONS ... previous) */ wildcard_diff_ab(STACK_2,STACK_1,m_index,b_index,&STACK_0,solutions); skipSTACK(1); sample = popSTACK(); pattern = popSTACK(); } if (b_index == Sstring_length(sample)) break; b_index++; } } local maygc void wildcard_diff (object pattern, object sample, const gcv_object_t* previous, gcv_object_t* solutions) { ASSERT(sstring_normal_p(pattern)); ASSERT(sstring_normal_p(sample)); wildcard_diff_ab(pattern,sample,0,0,previous,solutions); } #if DEBUG_TRANSLATE_PATHNAME>1 /* all arguments to *_diff are on stack - this should be safe */ #define DEBUG_DIFF(f) \ printf("\n* " #f " [logical: %d]\n",logical); \ DOUT("",pattern); DOUT("",sample); DOUT("",*previous); DOUT("",*solutions) #else #define DEBUG_DIFF(f) #endif /* UPs: compares a pathname-component ("Sample") and a pathname-component ("Pattern") at a time. can trigger GC */ local maygc void host_diff (object pattern, object sample, bool logical, const gcv_object_t* previous, gcv_object_t* solutions); local maygc void device_diff (object pattern, object sample, bool logical, const gcv_object_t* previous, gcv_object_t* solutions); local maygc void directory_diff (object pattern, object sample, bool logical, const gcv_object_t* previous, gcv_object_t* solutions); local maygc void nametype_diff (object pattern, object sample, bool logical, const gcv_object_t* previous, gcv_object_t* solutions); local maygc void version_diff (object pattern, object sample, bool logical, const gcv_object_t* previous, gcv_object_t* solutions); local maygc void host_diff (object pattern, object sample, bool logical, const gcv_object_t* previous, gcv_object_t* solutions) { DEBUG_DIFF(host_diff); if (logical) { if (nullp(pattern)) { push_solution_with(sample); return; } if (!equal(pattern,sample)) return; } else { #if HAS_HOST if (nullp(pattern)) { push_solution_with(sample); return; } if (!equal(pattern,sample)) return; #endif } #if HAS_HOST push_solution_with(S(Khost)); #else push_solution(); #endif } local maygc void device_diff (object pattern, object sample, bool logical, const gcv_object_t* previous, gcv_object_t* solutions) { DEBUG_DIFF(device_diff); if (logical) { #if HAS_DEVICE push_solution_with(S(Kdevice)); #else push_solution(); #endif return; } #if HAS_DEVICE #ifdef PATHNAME_WIN32 if (nullp(pattern) || eq(pattern,S(Kwild))) { var object string = wild2string(sample); push_solution_with(string); return; } if (eq(sample,S(Kwild))) return; #endif #ifdef PATHNAME_WIN32 if (nullp(pattern)) { var object string = wild2string(sample); push_solution_with(string); return; } if (!equalp(pattern,sample)) return; #else if (!equal(pattern,sample)) return; #endif push_solution_with(S(Kdevice)); #else /* HAS_DEVICE */ push_solution(); #endif } local maygc void nametype_diff_aux (object pattern, object sample, bool logical, const gcv_object_t* previous, gcv_object_t* solutions) { unused(logical); if (eq(pattern,S(Kwild))) { var object string = wild2string(sample); push_solution_with(string); return; } if (eq(sample,S(Kwild))) return; if (nullp(pattern)) { if (nullp(sample)) push_solution(); return; } if (nullp(sample)) return; wildcard_diff(pattern,sample,previous,solutions); } local maygc void subdir_diff (object pattern, object sample, bool logical, const gcv_object_t* previous, gcv_object_t* solutions) { DEBUG_DIFF(subdir_diff); if (eq(pattern,sample)) { if (eq(sample,S(Kwild))) push_solution_with(O(wild_string)); else push_solution(); return; } unused(logical); if (eq(pattern,S(Kwild))) { var object string = wild2string(sample); push_solution_with(string); return; } if (eq(sample,S(Kwild))) return; if (!simple_string_p(pattern) || !simple_string_p(sample)) return; wildcard_diff(pattern,sample,previous,solutions); } /* recursive implementation because of backtracking: */ local maygc void directory_diff_ab (object m_list, object b_list, bool logical, const gcv_object_t* previous, gcv_object_t* solutions) { /* algorithm analogous to wildcard_diff_ab. */ var object item; if (atomp(m_list)) { if (atomp(b_list)) push_solution(); return; } item = Car(m_list); m_list = Cdr(m_list); if (!eq(item,S(Kwild_inferiors))) { if (atomp(b_list)) return; pushSTACK(NIL); pushSTACK(m_list); pushSTACK(Cdr(b_list)); subdir_diff(item,Car(b_list),logical,previous,&STACK_2); /* call directory_diff_ab() recursively, with extended previous: */ while (mconsp(STACK_2)) { pushSTACK(Car(STACK_2)); directory_diff_ab(STACK_(1+1),STACK_(0+1),logical,&STACK_0,solutions); skipSTACK(1); STACK_2 = Cdr(STACK_2); } skipSTACK(3); } else { pushSTACK(b_list); /* b_start_list := b_list */ while (1) { /* to reduce consing, intercept cases when directory_diff_ab() does nothing: */ if (atomp(m_list) ? atomp(b_list) : (eq(Car(m_list),S(Kwild_inferiors)) || !atomp(b_list))) { /* call directory_diff_ab() recursively, with extended previous: */ pushSTACK(m_list); pushSTACK(b_list); pushSTACK(STACK_2); pushSTACK(b_list); funcall(L(ldiff),2); /* (LDIFF b_start_list b_list) */ pushSTACK(value1); { /* (:DIRECTORY subdir1 ... subdirn) */ var object new_piece = allocate_cons(); Car(new_piece) = S(Kdirectory); Cdr(new_piece) = STACK_0; STACK_0 = new_piece; } { var object new_cons = allocate_cons(); Car(new_cons) = STACK_0; Cdr(new_cons) = *previous; STACK_0 = new_cons; /* (CONS ... previous) */ directory_diff_ab(STACK_2,STACK_1,logical,&STACK_0,solutions); skipSTACK(1); b_list = popSTACK(); m_list = popSTACK(); } } if (atomp(b_list)) break; b_list = Cdr(b_list); } skipSTACK(1); } } local maygc void directory_diff (object pattern, object sample, bool logical, const gcv_object_t* previous, gcv_object_t* solutions) { DEBUG_DIFF(directory_diff); if (missingp(sample)) { push_solution_with(pattern); return; } if (directory_trivial_p(pattern)) { /* compare with directory_default */ /* Augment the solution with the sample list - starting with :ABSOLUTE or :RELATIVE, it will not fit for "**". */ push_solution_with(sample); return; } /* compare startpoint: */ if (!eq(Car(pattern),Car(sample))) return; pattern = Cdr(pattern); sample = Cdr(sample); /* compare subdirs: */ directory_diff_ab(pattern,sample,logical,previous,solutions); } local maygc void nametype_diff (object pattern, object sample, bool logical, const gcv_object_t* previous, gcv_object_t* solutions) { DEBUG_DIFF(nametype_diff); if (!boundp(sample)) { push_solution_with(pattern); return; } if (nullp(pattern)) { var object string = wild2string(sample); push_solution_with(string); return; } nametype_diff_aux(pattern,sample,logical,previous,solutions); } local maygc void version_diff (object pattern, object sample, bool logical, const gcv_object_t* previous, gcv_object_t* solutions) { /* logical is ignored */ DEBUG_DIFF(version_diff); if (!boundp(sample)) { push_solution_with(pattern); return; } if (nullp(pattern) || eq(pattern,S(Kwild))) { push_solution_with(sample); return; } if (eq(sample,S(Kwild))) return; if (!eql(pattern,sample)) return; push_solution(); } #undef push_solution_with #undef push_solution #undef DEBUG_DIFF /* Each substitution is a list of Normal-Simple-Strings or Lists. (The Lists come into being with :WILD-INFERIORS in directory_diff().) A Normal-Simple-String fits only with '?' or '*' or :WILD, A List fits only with :WILD-INFERIORS. */ /* On insertion of pieces of normal pathnames in logical pathnames: Conversion to capital letters. logical_case(string) > string: Normal-Simple-String or Symbol/Number < result: converted Normal-Simple-String or the same Symbol/Number can trigger GC */ local maygc object logical_case (object string) { if (!simple_string_p(string)) return string; return string_upcase(string); } /* The same, recursive like with SUBST: */ local maygc object subst_logical_case (object obj) { SUBST_RECURSE(logical_case(obj),subst_logical_case); } /* On insertion of pieces of logical pathnames in normal pathnames: Conversion to capital letters. customary_case(string) > string: Normal-Simple-String or Symbol/Number < result: converted Normal-Simple-String or the same Symbol/Number can trigger GC */ local maygc object customary_case (object string) { if (!simple_string_p(string)) return string; #if defined(PATHNAME_UNIX) || defined(PATHNAME_WIN32) /* operating system with preference for lowercase letters */ return string_downcase(string); #endif } /* The same, recursive like with SUBST: */ local maygc object subst_customary_case (object obj) { SUBST_RECURSE(customary_case(obj),subst_customary_case); } #undef SUBST_RECURSE /* Apply substitution SUBST to the PATTERN. translate_pathname(&subst,pattern) */ local object translate_pathname (object* subst, object pattern); /* Pop the CAR of *subst and return it. */ #define RET_POP(subst) \ { var object ret = Car(*subst); *subst = Cdr(*subst); return ret; } /* is the value trivial enough to ensure a trivial action? */ #define TRIVIAL_P(val) (simple_string_p(val)||nullp(val)) /* is the value simple enough to ensure a simple action? */ #define SIMPLE_P(val) (TRIVIAL_P(val)||eq(val,S(Kwild))) /* translate_host(&subst,pattern,logical) etc. returns the appropriate replacement for host etc.; shortens subst; returns nullobj on failure can trigger GC */ local maygc object translate_host (gcv_object_t* subst, object pattern, bool logical); local maygc object translate_device (gcv_object_t* subst, object pattern, bool logical); local maygc object translate_subdir (gcv_object_t* subst, object pattern, bool logical); local maygc object translate_directory (gcv_object_t* subst, object pattern, bool logical); local maygc object translate_nametype (gcv_object_t* subst, object pattern, bool logical); local maygc object translate_version (gcv_object_t* subst, object pattern, bool logical); #if DEBUG_TRANSLATE_PATHNAME /* all arguments to translate_* should be on stack - this should be safe */ #define DEBUG_TRAN(f) \ printf("\n* " #f " [logical: %d]\n",logical); \ DOUT("",*subst); DOUT("",pattern) #else #define DEBUG_TRAN(f) #endif local maygc object translate_host (gcv_object_t* subst, object pattern, bool logical) { DEBUG_TRAN(translate_host); #define TRAN_HOST(subst,pattern) \ if (nullp(pattern) && mconsp(*subst)) { \ if (TRIVIAL_P(Car(*subst))) { \ RET_POP(subst); \ } else if (eq(Car(*subst),S(Khost))) { \ *subst = Cdr(*subst); \ return pattern; \ } else \ return nullobj; \ } if (logical) { TRAN_HOST(subst,pattern); } else { #if HAS_HOST TRAN_HOST(subst,pattern); #endif } #if HAS_HOST if (eq(Car(*subst),S(Khost))) *subst = Cdr(*subst); #endif return pattern; #undef TRAN_HOST } local maygc object translate_device (gcv_object_t* subst, object pattern, bool logical) { DEBUG_TRAN(translate_device); #if HAS_DEVICE if (logical) { if (eq(Car(*subst),S(Kdevice))) { *subst = Cdr(*subst); } return pattern; } #ifdef PATHNAME_WIN32 if (nullp(pattern) && mconsp(*subst)) #else if ((nullp(pattern) || eq(pattern,S(Kwild))) && mconsp(*subst)) #endif { if (TRIVIAL_P(Car(*subst))) { RET_POP(subst); } else if (eq(Car(*subst),S(Kdevice))) { *subst = Cdr(*subst); return pattern; } else return nullobj; } if (eq(Car(*subst),S(Kdevice))) *subst = Cdr(*subst); #endif return pattern; } local maygc object translate_nametype_aux (gcv_object_t* subst, object pattern, bool logical) { DEBUG_TRAN(translate_nametype_aux); if (eq(pattern,S(Kwild)) && mconsp(*subst)) { if (TRIVIAL_P(Car(*subst))) { var object erg = Car(*subst); *subst = Cdr(*subst); return erg; } else return nullobj; } if (simple_string_p(pattern)) { pushSTACK(pattern); /* save pattern */ var gcv_object_t* pattern_ = &STACK_0; var uintL len = Sstring_length(pattern); var uintL index = 0; var uintL stringcount = 0; /* number of strings on the stack */ while (1) { var uintL last_index = index; var chart cc; /* search next wildcard-character: */ pattern = *pattern_; while (index != len) { cc = schar(pattern,index); if ((multiwild_char_p(cc) /* wildcard for arbitrary many characters */ || (!logical && singlewild_char_p(cc))) /* wildcard for exactly one character */ && mconsp(*subst)) break; index++; } /* Next (SUBSTRING pattern last_index index) on the stack: */ pushSTACK(subsstring(pattern,last_index,index)); stringcount++; /* finished? */ if (index == len) break; /* replace wildcard: */ if (TRIVIAL_P(Car(*subst))) { var object s = Car(*subst); pushSTACK(nullp(s) ? (object)O(empty_string) : s); *subst = Cdr(*subst); stringcount++; } else { skipSTACK(stringcount+1); return nullobj; } index++; } value1 = string_concat(stringcount); skipSTACK(1); /* skip pattern */ return value1; } return pattern; } local maygc object translate_subdir (gcv_object_t* subst, object pattern, bool logical) { DEBUG_TRAN(translate_subdir); return translate_nametype_aux(subst,pattern,logical); } local maygc object translate_directory (gcv_object_t* subst, object pattern, bool logical) { DEBUG_TRAN(translate_directory); /* compare pattern with directory_default: */ if (nullp(pattern) && mconsp(*subst)) { var object list = Car(*subst); *subst = Cdr(*subst); return listp(list) ? copy_list(list) : nullobj; } /* if subst is :relative while pattern is :absolute, nothing is to be done */ if (eq(Car(pattern),S(Kabsolute)) && mconsp(*subst) && directory_trivial_p(Car(*subst))) { *subst = Cdr(*subst); return copy_list(pattern); } var uintL itemcount = 0; /* number of items on the stack */ /* Startpoint: */ pushSTACK(Car(pattern)); pattern = Cdr(pattern); itemcount++; /* subdirs: */ while (consp(pattern)) { var object item = Car(pattern); pattern = Cdr(pattern); if (eq(item,S(Kwild_inferiors))) { if (mconsp(*subst)) { if (consp(Car(*subst)) && eq(Car(Car(*subst)),S(Kdirectory))) { var object list = Cdr(Car(*subst)); *subst = Cdr(*subst); while (consp(list)) { pushSTACK(Car(list)); list = Cdr(list); itemcount++; } } else { skipSTACK(itemcount); return nullobj; } } else { pushSTACK(item); itemcount++; } } else { pushSTACK(pattern); /* save pattern */ item = translate_subdir(subst,item,logical); if (eq(item,nullobj)) { skipSTACK(itemcount+1); return nullobj; } pattern = STACK_0; STACK_0 = item; itemcount++; } } return listof(itemcount); } local maygc object translate_nametype (gcv_object_t* subst, object pattern, bool logical) { DEBUG_TRAN(translate_nametype); if (nullp(pattern) && mconsp(*subst)) { if (SIMPLE_P(Car(*subst))) { RET_POP(subst); } else return nullobj; } return translate_nametype_aux(subst,pattern,logical); } local object translate_version (gcv_object_t* subst, object pattern, bool logical) { /* logical is ignored */ DEBUG_TRAN(translate_version); if ((nullp(pattern) || eq(pattern,S(Kwild))) && mconsp(*subst)) { var object erg = Car(*subst); if (nullp(erg) || integerp(erg) || eq(erg,S(Kwild)) || eq(erg,S(Knewest))) { *subst = Cdr(*subst); return erg; } else return nullobj; } return pattern; } #undef SIMPLE_P #undef TRIVIAL_P #undef RET_POP #undef DEBUG_TRAN local maygc object translate_pathname (gcv_object_t* subst, object pattern) { var bool logical = false; var object item; pushSTACK(*subst); /* save subst for the error message */ pushSTACK(pattern); if (logpathnamep(pattern)) logical = true; #define GET_ITEM(what,xwhat,where,skip) do { \ item = translate_##what(subst,xpathname_##xwhat(logical,where),logical); \ if (eq(item,nullobj)) { skipSTACK(skip); goto subst_error; } \ DOUT(#what " > ",item); pushSTACK(S(K##xwhat)); pushSTACK(item); \ } while(0) #define GET_ITEM_S(y,x,w) GET_ITEM(y,x,STACK_(w),w) /* build together arguments for MAKE-PATHNAME: */ GET_ITEM(host,host,pattern,0); #if HAS_DEVICE GET_ITEM_S(device,device,2); #endif GET_ITEM_S(directory,directory,2+2*HAS_DEVICE); GET_ITEM_S(nametype,name,2+2*HAS_DEVICE+2); GET_ITEM_S(nametype,type,2+2*HAS_DEVICE+4); GET_ITEM_S(version,version,2+2*HAS_DEVICE+6); /* All replacement pieces must be consumed! */ if (mconsp(*subst)) { skipSTACK(2+2*HAS_DEVICE+8); goto subst_error; } /* call (MAKE-PATHNAME ...) resp. (SYS::MAKE-LOGICAL-PATHNAME ...) : */ if (logical) funcall(L(make_logical_pathname),2+2*HAS_DEVICE+8); else funcall(L(make_pathname),2+2*HAS_DEVICE+8); skipSTACK(2); return value1; subst_error: /* Error because of nullobj. */ /* stack layout: subst, pattern. */ pushSTACK(STACK_1); pushSTACK(S(translate_pathname)); error(error_condition,GETTEXT("~S: replacement pieces ~S do not fit into ~S")); } #undef GET_ITEM #undef GET_ITEM_S /* (TRANSLATE-PATHNAME sample pattern1 pattern2 [:all] [:merge] [:absolute]), CLtL2 p. 624 :absolute = T --> convert the resulting pathnames to absolute :all = T --> return a list of all fitting pathnames :all = NIL --> Error, if more than one pathname fits :merge = NIL --> skip last MERGE-PATHNAMES step */ LISPFUN(translate_pathname,seclass_default,3,0,norest,key,3, (kw(all),kw(merge),kw(absolute))) { /* stack layout: sample, pattern1, pattern2, all, merge, absolute. */ var bool absolute_p = !missingp(STACK_0); var bool logical = false; /* sample and pattern are logical pathnames */ var bool logical2 = false; /* pattern2 is a logical pathname */ skipSTACK(1); /* drop absolute */ STACK_4 = coerce_xpathname(STACK_4); STACK_3 = coerce_xpathname(STACK_3); STACK_2 = coerce_xpathname(STACK_2); if (logpathnamep(STACK_4) && logpathnamep(STACK_3)) { logical = true; } else { /* not both logical pathnames -> first convert into normal pathnames: */ STACK_4 = coerce_pathname(STACK_4); STACK_3 = coerce_pathname(STACK_3); } if (logpathnamep(STACK_2)) logical2 = true; /* 1. step: construct list of all fitting substitutions. */ pushSTACK(NIL); pushSTACK(NIL); host_diff(xpathname_host(logical,STACK_(3+2)), xpathname_host(logical,STACK_(4+2)), logical,&STACK_1,&STACK_0); while (mconsp(STACK_0)) { pushSTACK(Car(STACK_0)); pushSTACK(NIL); device_diff(xpathname_device(logical,STACK_(3+4)), xpathname_device(logical,STACK_(4+4)), logical,&STACK_1,&STACK_0); while (mconsp(STACK_0)) { pushSTACK(Car(STACK_0)); pushSTACK(NIL); directory_diff(xpathname_directory(logical,STACK_(3+6)), xpathname_directory(logical,STACK_(4+6)), logical,&STACK_1,&STACK_0); while (mconsp(STACK_0)) { pushSTACK(Car(STACK_0)); pushSTACK(NIL); nametype_diff(xpathname_name(logical,STACK_(3+8)), xpathname_name(logical,STACK_(4+8)), logical,&STACK_1,&STACK_0); while (mconsp(STACK_0)) { pushSTACK(Car(STACK_0)); pushSTACK(NIL); nametype_diff(xpathname_type(logical,STACK_(3+10)), xpathname_type(logical,STACK_(4+10)), logical,&STACK_1,&STACK_0); while (mconsp(STACK_0)) { pushSTACK(Car(STACK_0)); version_diff(xpathname_version(logical,STACK_(3+11)), xpathname_version(logical,STACK_(4+11)), logical,&STACK_0,&STACK_10); skipSTACK(1); STACK_0 = Cdr(STACK_0); } skipSTACK(2); STACK_0 = Cdr(STACK_0); } skipSTACK(2); STACK_0 = Cdr(STACK_0); } skipSTACK(2); STACK_0 = Cdr(STACK_0); } skipSTACK(2); STACK_0 = Cdr(STACK_0); } skipSTACK(1); /* stack layout: ..., solutions. */ if (matomp(STACK_0)) { pushSTACK(STACK_(3+1)); pushSTACK(STACK_(4+1+1)); pushSTACK(S(translate_pathname)); error(error_condition,GETTEXT("~S: ~S is not a specialization of ~S")); } /* 2.,3. step: */ pushSTACK(NIL); /* pathnames := '() */ while (mconsp(STACK_1)) { /* traverse solutions */ var object solutions = STACK_1; STACK_1 = Cdr(solutions); { /* reverse list solution */ var object solution = reverse(Car(solutions)); /* 2. step: insert substitution in pattern2. */ /* convert capital-/small letters suitably: */ if (!logical) { if (logical2) solution = subst_logical_case(solution); } else { if (!logical2) solution = subst_customary_case(solution); } pushSTACK(solution); STACK_0 = translate_pathname(&STACK_0,STACK_(2+1+2)); } /* 3. step: (MERGE-PATHNAMES modified_pattern2 sample :WILD T) */ if (!nullp(STACK_(0+1+2)) /* query :MERGE-Argument */ && has_some_wildcards(STACK_0)) {/*MERGE-PATHNAMES may be unnecessary*/ pushSTACK(STACK_(4+1+2)); pushSTACK(unbound); pushSTACK(S(Kwild)); pushSTACK(T); funcall(L(merge_pathnames),5); pushSTACK(value1); } /* step 4: merge in default pathname */ #if defined(PATHNAME_UNIX) || defined(PATHNAME_WIN32) if (absolute_p) { STACK_0 = use_default_dir(STACK_0); /* insert default-directory */ /* (because Unix does not know the default-directory of LISP and Win32 is multitasking) */ } #endif { /* (PUSH pathname pathnames) */ var object new_cons = allocate_cons(); Car(new_cons) = popSTACK(); Cdr(new_cons) = STACK_0; STACK_0 = new_cons; } } /* 4. step: (DELETE-DUPLICATES pathnames :TEST #'EQUAL) */ pushSTACK(S(Ktest)); pushSTACK(L(equal)); funcall(L(delete_duplicates),3); /* stack layout: ..., nil. */ if (missingp(STACK_(1+1))) { /* query :ALL-Argument */ if (mconsp(Cdr(value1))) { pushSTACK(value1); pushSTACK(STACK_(2+2)); pushSTACK(STACK_(3+3)); pushSTACK(STACK_(4+4)); pushSTACK(S(translate_pathname)); error(error_condition,GETTEXT("(~S ~S ~S ~S) is ambiguous: ~S")); } value1 = Car(value1); } mv_count=1; skipSTACK(5+1); } /* (ABSOLUTE-PATHNAME pathname) converts pathname to a physical pathname, if necessary, and makes it absolute (using clisp's notion of default directory). */ LISPFUNN(absolute_pathname,1) { VALUES1(use_default_dir(coerce_pathname(popSTACK()))); } /* Converts an object into an absolute physical pathname and returns its namestring (merge in default-directory). physical_namestring(thing) > thing: an object < result: the namestring of the pathname denoted by thing can trigger GC */ modexp maygc object physical_namestring (object thing) { return whole_namestring(use_default_dir(coerce_pathname(thing))); } /* UP: tests, if the name of a pathname is =NIL. namenullp(pathname) > pathname: non-logical pathname local bool namenullp (object pathname); local bool namenullp(pathname) { return nullp(ThePathname(pathname)->pathname_name); } */ #define namenullp(path) (nullp(ThePathname(path)->pathname_name)) /* error, if directory does not exist > obj: pathname or (better) erroneous component */ local _Noreturn void error_dir_not_exists (object obj) { pushSTACK(obj); /* FILE-ERROR slot PATHNAME */ pushSTACK(obj); pushSTACK(TheSubr(subr_self)->name); error(file_error,GETTEXT("~S: Directory ~S does not exist")); } /* error, if a file already exits > STACK_0: pathname */ local _Noreturn void error_file_exists (void) { /* STACK_0 = FILE-ERROR slot PATHNAME */ pushSTACK(STACK_0); /* pathname */ pushSTACK(TheSubr(subr_self)->name); error(file_error,GETTEXT("~S: File ~S already exists")); } /* error, if the pathname is a directory */ local _Noreturn void error_directory (object pathname) { pushSTACK(pathname); /* FILE-ERROR slot PATHNAME */ pushSTACK(whole_namestring(pathname)); pushSTACK(TheSubr(subr_self)->name); error(file_error,GETTEXT("~S: ~S names a directory, not a file")); } #ifdef PATHNAME_WIN32 /* An "absolute pathname" is a pathname, whose device is a checked String and directory does not contain :RELATIVE, :CURRENT, :PARENT. */ /* UP: returns a namestring of a pathname for the operating system. OSnamestring(dir_namestring) > STACK_0: non-logical pathname > dir_namestring: directory-namestring (for DOS) < result: namestring (for DOS) can trigger GC */ local maygc object OSnamestring (object dir_namestring) { var uintC stringcount; pushSTACK(dir_namestring); /* Directory-Namestring as the first String */ stringcount = file_namestring_parts(STACK_(0+1)); /* filename Strings */ return string_concat(1+stringcount); /* concatenate */ } /* UP: tests, if a drive exists. > uintB drive: drive-(capital-)letter < bool result: if this drive exists and is responsive */ local maygc bool good_drive (uintB drive); #ifdef WIN32_NATIVE local maygc bool good_drive (uintB drive) { var char rootpath[4]; var DWORD result; rootpath[0] = drive; rootpath[1] = ':'; rootpath[2] = '\\'; rootpath[3] = '\0'; begin_blocking_system_call(); result = GetDriveType(rootpath); switch (result) { case DRIVE_UNKNOWN: end_blocking_system_call(); return false; case DRIVE_NO_ROOT_DIR: /* Distinguish NFS mounts from nonassigned drive letters: */ result = GetFileAttributes(rootpath); end_blocking_system_call(); return !(result==0xFFFFFFFF); default: end_blocking_system_call(); return true; } } #if 0 /* The following fails to recognize some (but not all) NFS mounts on WinNT. */ local maygc bool good_drive_notsogood (uintB drive) { var DWORD drives_bitmask; begin_blocking_system_call(); drives_bitmask = GetLogicalDrives(); end_blocking_system_call(); return ((drives_bitmask & ((DWORD)1 << (drive-'A'))) != 0); } #endif #endif /* WIN32_NATIVE */ /* UP: returns the current drive. < char drive: drive-(capital-)letter */ local maygc char default_drive (void) { #ifdef WIN32_NATIVE var DWORD path_buflen = _MAX_PATH; var char* path_buffer = (char*)alloca(path_buflen); var DWORD result; GC_SAFE_SYSTEM_CALL(result=, GetCurrentDirectory(path_buflen,path_buffer)); if (!result) { OS_error(); } if (result >= path_buflen) { path_buflen = result; path_buffer = (char*)alloca(path_buflen); GC_SAFE_SYSTEM_CALL(result=, GetCurrentDirectory(path_buflen,path_buffer)); if (!result) { OS_error(); } } if (path_buffer[1]==':') { /* local device */ ASSERT(path_buffer[2]=='\\'); return as_cint(up_case(as_chart(path_buffer[0]))); } else if (path_buffer[0]=='\\') { /* network host */ ASSERT(path_buffer[1]=='\\'); return 0; } else NOTREACHED; #endif } /* UP: returns the current directory on the given drive. > uintB drive: drive-(capital-)letter > object pathname: pathname (for error-reporting purposes) < result: current directory (as pathname) can trigger GC */ local maygc object default_directory_of (uintB drive, object pathname) { /* working directory (of DOS) is the current directory: */ #if defined(WIN32_NATIVE) var char currpath[4]; var DWORD path_buflen = _MAX_PATH; var char* path_buffer = (char*)alloca(path_buflen+1); var char* dummy; var DWORD result; if (drive) { /* local disk */ currpath[0] = drive; currpath[1] = ':'; currpath[2] = '.'; /* this dot is actually not needed */ currpath[3] = '\0'; GC_SAFE_SYSTEM_CALL(result=,GetFullPathName(currpath,path_buflen,path_buffer,&dummy)); if (!result) { OS_file_error(pathname); } if (result >= path_buflen) { path_buflen = result; path_buffer = (char*)alloca(path_buflen+1); GC_SAFE_SYSTEM_CALL(result=,GetFullPathName(currpath,path_buflen,path_buffer,&dummy)); if (!result) { OS_file_error(pathname); } } } else { /* network path */ GC_SAFE_SYSTEM_CALL(result=, GetCurrentDirectory(path_buflen,path_buffer)); if (!result) { OS_file_error(pathname); } if (result >= path_buflen) { path_buflen = result; path_buffer = (char*)alloca(path_buflen); GC_SAFE_SYSTEM_CALL(result=, GetCurrentDirectory(path_buflen,path_buffer)); if (!result) { OS_file_error(pathname); } } } { /* poss. add a '\' at the end: */ var char* path_end = &path_buffer[asciz_length(path_buffer)]; if (!(path_end[-1]=='\\')) { path_end[0] = '\\'; path_end[1] = '\0'; } } #else var char path_buffer[3+MAXPATHLEN]; /* cf. GETWD(3) */ path_buffer[0] = drive; path_buffer[1] = ':'; /* file working directory in path_buffer: */ begin_blocking_system_call(); getwd_of(&path_buffer[2],drive); end_blocking_system_call(); #endif /* Hack by DJ (see GO32/EXPHDLR.C) and EM (see LIB/MISC/_GETCWD1.C): converts all '\' to '/' and all captial- to small letters (only cosmetics, because DOS and our PARSE-NAMESTRING also understand filenames with '/' instead of '\'). convert to pathname: */ return asciz_dir_to_pathname(&path_buffer[0],O(pathname_encoding)); } /* UP: Fills default-drive and default-directory into a pathname. use_default_dir(pathname) > pathname: non-logical pathname with Device /= :WILD < result: new absolute pathname can trigger GC */ local maygc object use_default_dir (object pathname) { /* first copy the pathname: */ pathname = copy_pathname(pathname); pushSTACK(pathname); /* stack layout: pathname. default for the device: */ #if HAS_HOST /* PATHNAME_WIN32 */ if (nullp(ThePathname(pathname)->pathname_host)) #endif if (nullp(ThePathname(pathname)->pathname_device)) { /* no device specified? --- take the default-drive instead: */ ThePathname(pathname)->pathname_device = O(default_drive); } { /* Default for the directory: */ var object subdirs = ThePathname(pathname)->pathname_directory; /* Does pathname-directory start with :RELATIVE ? */ if (nullp(subdirs) || eq(Car(subdirs),S(Krelative))) { /* yes -> replace :RELATIVE with the default-directory: */ pushSTACK(consp(subdirs) ? (object)Cdr(subdirs) : NIL); #if HAS_HOST /* PATHNAME_WIN32 */ if (!nullp(ThePathname(pathname)->pathname_host)) { /* We do not have the concept of a current directory on a remote host. Simply use :ABSOLUTE instead of :RELATIVE. */ subdirs = allocate_cons(); Car(subdirs) = S(Kabsolute); Cdr(subdirs) = popSTACK(); } else #endif { /* drive does not have to be present if we start on a network path */ var object drive = ThePathname(pathname)->pathname_device; if (eq(drive,S(Kwild))) check_no_wildcards(pathname); /* error */ var uintB dr = nullp(drive) ? 0 : as_cint(TheSnstring(drive)->data[0]); var object default_dir = default_directory_of(dr,pathname); #if HAS_HOST /* PATHNAME_WIN32 */ ThePathname(STACK_1)->pathname_host = /* replace NIL in pathname ... */ ThePathname(default_dir)->pathname_host; /* ... with default */ #endif /* default_dir (a Pathname) is finished. Replace :RELATIVE with default-subdirs, i.e. form (append default-subdirs (cdr subdirs)) = (nreconc (reverse default-subdirs) (cdr subdirs)) */ var object temp = ThePathname(default_dir)->pathname_directory; temp = reverse(temp); subdirs = nreconc(temp,popSTACK()); } } /* traverse list and freshly cons up, thereby process '.\' and '..\' and '...\' (do not leave it to DOS): */ pushSTACK(subdirs); pushSTACK(NIL); /* stack layout: pathname, subdir-oldlist, subdir-newlist. */ while (mconsp(STACK_1)) { /* until oldlist is finished: */ var object subdir = Car(STACK_1); /* next subdir */ if (equal(subdir,O(dot_string))) { /* = :CURRENT -> leave newlist unchanged */ } else if (equal(subdir,O(dotdot_string))) { /* = :PARENT -> shorten newlist by one: */ if (matomp(Cdr(STACK_0))) { /* newlist (except for :ABSOLUTE) empty ? */ /* :PARENT from "\" returns Error */ pushSTACK(STACK_2); /* FILE-ERROR slot PATHNAME */ pushSTACK(O(backslash_string)); /* "\\" */ pushSTACK(directory_namestring(STACK_(2+2))); /* directory of pathname */ error(file_error,GETTEXT("no directory ~S above ~S")); } if (eq(Car(STACK_0),S(Kwild_inferiors))) { /* newlist starts with '...\' ? */ /* :PARENT from "...\" returns Error */ pushSTACK(STACK_2); /* FILE-ERROR slot PATHNAME */ pushSTACK(directory_namestring(STACK_(2+1))); /* directory of pathname */ error(file_error, /* '"..\\" after "...\\" is inadmissible: ~' */ GETTEXT("\"..\\\\\" after \"...\\\\\" is invalid: ~S")); } STACK_0 = Cdr(STACK_0); } else { /* (also if :ABSOLUTE !) */ /* lengthen newlist by one: */ pushSTACK(subdir); var object new_cons = allocate_cons(); Car(new_cons) = popSTACK(); Cdr(new_cons) = STACK_0; STACK_0 = new_cons; } STACK_1 = Cdr(STACK_1); } subdirs = nreverse(popSTACK()); /* newlist, reverse again */ skipSTACK(1); /* stack layout: pathname. */ ThePathname(STACK_0)->pathname_directory = simplify_directory(subdirs); /* enter into the pathname */ pathname = popSTACK(); } return pathname; } #ifdef WIN32_NATIVE /* UP: translates short name to full name > shortname: old DOS 8.3 pathname wildcards aren't allowed. "." and ".." can be used. < fullname: buffer should be not less than MAX_PATH < result: true on success */ static BOOL FullName (LPCSTR shortname, LPSTR fullname) { var char current[_MAX_PATH]; var char * rent = current;/* current+end-device-pos, rest after X: */ var int state = 1; /* states for automata reading 'rent' pathname backward: 0 - end 1 - beginning 2 - name component 3 - slash component 9,11,13... slash component after dots (".."). components to be skipped = (state - 9)/2 10,12,14... name components after dots. components to be skipped = (state - 10)/2; */ var enum {fn_eof, fn_name, fn_dots, fn_dot, fn_slash} symbol; /* symbol at the end of 'rent': 1 - generic name 2 - ".." 3 - "." 4 - slash 0 - EOF i.e. beginning of 'rent' */ var int pos; var int ops = 0;/* output position */ strcpy(current,shortname); /* determine the end of device part */ if (((current[0] >= 'a' && current[0] <= 'z') || (current[0] >= 'A' && current[0] <= 'Z')) && current[1] == ':') { rent = current+2; } else if (current[0]=='\\' && current[1]=='\\') { int i;rent = current; /* host */ rent+=2; for (i=0;i<2;i++) {/* skip host and sharename */ while (*rent && !cpslashp(*rent)) rent++; if (*rent) rent++; else return false;/*host and sharename don't end with slash*/ } } pos = strlen(rent); do { rent[pos] = '\0'; if (pos == 0) symbol = fn_eof; else if (cpslashp(rent[pos-1])) { pos--; symbol = fn_slash; } else { int dotcount = 0;/* < 0 -> not only dots */ int wild = 0; while(pos > 0 && !cpslashp(rent[pos-1])) { if (rent[pos-1] == '.') dotcount++; else dotcount = -pos; if (rent[pos-1] == '*' || rent[pos-1] == '?') wild = 1; pos--; } if (wild) return false; if (dotcount <= 0) symbol = fn_name; else if (dotcount == 1) symbol = fn_dot; else if (dotcount == 2) symbol = fn_dots; else return false; /* too many dots */ } if (state == 1 /* beginning */ || state == 2 /* name component */) { switch(symbol) { case fn_dot: state = 3; break; /* slash */ case fn_dots: state = 11; break; /* dots-slash */ case fn_name: { var WIN32_FIND_DATA wfd; var HANDLE h = NULL; h = FindFirstFile(current,&wfd); if (h != INVALID_HANDLE_VALUE) { strrev(wfd.cFileName); if (ops > 0 || wfd.dwFileAttributes & FILE_ATTRIBUTE_DIRECTORY) fullname[ops++] = '\\'; strcpy(fullname+ops,wfd.cFileName); ops+=strlen(wfd.cFileName); FindClose(h); } else return false; /* file not found */ state = 3; } break; case fn_slash: if (state == 1) state = 2; else return false; /* two slashes in a row */ break; case fn_eof: if (state == 1 && current == rent) return false; /* D: */ else state = 0; break; default: return false;/* program error */ } } else if (state == 3) {/* slash */ switch(symbol) { case fn_slash: state = 2;break; case fn_eof: if (current == rent) state = 0; else return false; /*D:FOO*/ break; default: return false; /* program error */ } } else if (state % 2 == 1) {/* dots - slash 9, 11, 13 ... */ switch(symbol) { case fn_slash: state += 1; if (state == 10) state = 2; /* zero depth */ break; /* same depth */ case fn_eof: return false; /* too many ".." */ break; default: return false; /* program error */ } } else {/* dots - name 10, 12, 14, ... */ switch(symbol) { case fn_dot: state -= 1; break; /* same depth */ case fn_dots: state += 1; break; /* increase depth */ case fn_name: state -= 3; /* decrease depth */ if (state < 9) return false; /* program error */ break; case fn_slash: return false; /* two slashes */ case fn_eof: return false; /* too many ".."s */ } } } while (state != 0); if (rent > current) fullname[ops++] = '\\'; /* add device */ while(rent > current) fullname[ops++] = (rent--)[-1]; fullname[ops] = '\0'; strrev(fullname); return true; } #endif /* UP: guarantees that the Directory of the Pathname exists (signals an error if it does not) assure_dir_exists(file_status,links_resolved,tolerantp) > fs->fs_pathname: absolute pathname without wildcards in directory > links_resolved: Flag, whether all links in the directory of the pathname are already resolved > tolerantp: Flag, whether an error should be avoided < fs->fs_namestring: if Name=NIL: Directory-Namestring (for DOS) if Name/=NIL: Namestring (for DOS) if tolerantp, maybe: nullobj can trigger GC */ #ifdef WIN32_NATIVE struct file_status { gcv_object_t *fs_pathname; /* pointer into STACK */ object fs_namestring; /* usually returned by assure_dir_exists() */ DWORD fs_fileattr; }; local inline bool file_status_is_dir (struct file_status *fs) { return fs->fs_fileattr == 0xFFFFFFFF || !(fs->fs_fileattr & FILE_ATTRIBUTE_DIRECTORY); } local inline void file_status_init(struct file_status *fs,gcv_object_t *path) { fs->fs_pathname = path; fs->fs_namestring = nullobj; fs->fs_fileattr = 0; } local maygc void assure_dir_exists (struct file_status *fs, bool links_resolved, bool tolerantp) { var bool nnullp = namenullp(*(fs->fs_pathname)); if (nnullp && links_resolved) { fs->fs_namestring = directory_namestring(*(fs->fs_pathname)); return; } with_sstring_0(whole_namestring(*(fs->fs_pathname)),O(pathname_encoding), path, { var char resolved[MAX_PATH]; var bool substitute = false; var bool error = false; begin_system_call(); if (links_resolved) { /* use light function */ shell_shortcut_target_t rresolve = resolve_shell_symlink(path,resolved); if (rresolve != shell_shortcut_notresolved) { if (rresolve == shell_shortcut_notexists) error = true; else substitute = true; } } else { if (real_path(path,resolved)) substitute = true; else { /* A file doesn't exist. Maybe dir does ? */ error = true; /* let's be pessimistic */ if (!nnullp) { var uintL lastslashpos = strlen(path) - 1; while (lastslashpos > 0 && path[lastslashpos]!=slash) lastslashpos--; if (path[lastslashpos]==slash) { path[lastslashpos + 1] = '\0'; /* leave only path without name */ if (real_path(path,resolved)) { /* substitute only directory part */ fs->fs_fileattr = GetFileAttributes(resolved); /* resolved to a file ? Only directories allowed - nonmaskable error */ if (fs->fs_fileattr == 0xFFFFFFFF || !(fs->fs_fileattr & FILE_ATTRIBUTE_DIRECTORY)) error_directory(*(fs->fs_pathname)); pushSTACK(asciz_to_string(resolved,O(pathname_encoding))); /* substitute immediately - w/o substitute flag turn it into a pathname and use it with old name: */ pushSTACK(coerce_pathname(STACK_0)); /* save old pathname name and type components */ pushSTACK(ThePathname(STACK_2)->pathname_name); pushSTACK(ThePathname(STACK_3)->pathname_type); *(fs->fs_pathname) = STACK_2; ThePathname(*(fs->fs_pathname))->pathname_name = STACK_1; ThePathname(*(fs->fs_pathname))->pathname_type = STACK_0; skipSTACK(4); error = false; } } } } } end_system_call(); if (error) { if (tolerantp) { fs->fs_namestring = nullobj; return; } pushSTACK(copy_pathname(*(fs->fs_pathname))); ThePathname(STACK_0)->pathname_name = NIL; ThePathname(STACK_0)->pathname_type = NIL; error_dir_not_exists(popSTACK()); } if (substitute) { var object resolved_string = asciz_to_string(resolved,O(pathname_encoding)); *(fs->fs_pathname) = coerce_pathname(resolved_string); nnullp = namenullp(*(fs->fs_pathname)); } }); /* merge in *DEFAULT-PATHNAME-DEFAULTS* & :VERSION :NEWEST: for cross-platform consistency, either all or no versions of assure_dir_exists() must call MERGE-PATHNAMES */ funcall(L(merge_pathnames),1); pushSTACK(value1); { var object dns = directory_namestring(*(fs->fs_pathname)); fs->fs_namestring = nnullp ? dns : OSnamestring(dns); } } #endif #endif #ifdef PATHNAME_UNIX /* UP: Return the current Directory. < result: current Directory (as Pathname) can trigger GC */ local maygc object default_directory (void) { var char path_buffer[MAXPATHLEN]; /* cf. GETWD(3) */ /* store Working Directory in path_buffer: */ begin_blocking_system_call(); if ( getwd(&path_buffer[0]) ==NULL) { end_blocking_system_call(); pushSTACK(O(dot_string)); /* FILE-ERROR slot PATHNAME */ pushSTACK(asciz_to_string(&path_buffer[0],O(pathname_encoding))); /* message */ error(file_error,GETTEXT("UNIX error while GETWD: ~S")); } end_blocking_system_call(); /* It must start with '/' : */ if (!(path_buffer[0] == '/')) { pushSTACK(O(dot_string)); /* FILE-ERROR slot PATHNAME */ pushSTACK(asciz_to_string(&path_buffer[0],O(pathname_encoding))); error(file_error,GETTEXT("UNIX GETWD returned ~S")); } /* convert to pathname: */ return asciz_dir_to_pathname(&path_buffer[0],O(pathname_encoding)); } /* UP: Fills Default-Directory into a pathname. use_default_dir(pathname) > pathname: non-logical pathname < result: new pathname, whose directory contains no :RELATIVE . (short: "absolute pathname") can trigger GC */ local maygc object use_default_dir (object pathname) { /* copy the pathname first: */ pathname = copy_pathname(pathname); { /* then build the default-directory into the pathname: */ var object subdirs = ThePathname(pathname)->pathname_directory; /* does pathname-directory start with :RELATIVE? */ if (nullp(subdirs) || eq(Car(subdirs),S(Krelative))) { /* yes -> replace :RELATIVE with default-subdirs, i.e. form (append default-subdirs (cdr subdirs)) = (nreconc (reverse default-subdirs) (cdr subdirs)) */ pushSTACK(pathname); pushSTACK(consp(subdirs) ? (object)Cdr(subdirs) : NIL); var object temp = default_directory(); temp = ThePathname(temp)->pathname_directory; temp = reverse(temp); subdirs = nreconc(temp,popSTACK()); subdirs = simplify_directory(subdirs); pathname = popSTACK(); /* enter into the pathname: */ ThePathname(pathname)->pathname_directory = subdirs; } } return pathname; } /* UP: Assures, that the directory of a pathname exists, and thereby resolves symbolic links. assure_dir_exists(file_status, links_resolved, tolerantp) > file_status->fs_pathname: non-logical pathname, whose directory does not contain :RELATIVE. > links_resolved: Flag, if all links in the directory of the pathname are already resolved and if it is known to exist > tolerantp: flag, if an error is to be avoided < file_status->fs_pathname: (poss. the same) pathname, whereas neither for the directory nor for the Filename a symbolic link is to be tracked. < file_status->fs_namestring: if Name=NIL: directory-namestring (for UNIX, with '/' at the end) if Name/=NIL: namestring (for UNIX) if tolerantp poss.: nullobj < file_status->fs_stat_validp: if Name/=NIL: false if the file does not exist, true if it exists, in which case file_status->fs_stat contains its stats can trigger GC */ struct file_status { gcv_object_t *fs_pathname; /* pointer into STACK */ object fs_namestring; /* usually returned by assure_dir_exists() */ bool fs_stat_validp; struct stat fs_stat; }; local inline bool file_status_is_dir (struct file_status *fs) { return S_ISDIR(fs->fs_stat.st_mode); } local inline void file_status_init(struct file_status *fs,gcv_object_t *path) { fs->fs_pathname = path; fs->fs_namestring = nullobj; fs->fs_stat_validp = false; } local maygc char* realpath_obj (object namestring, char *path_buffer) { char* ret; with_sstring_0(namestring,O(pathname_encoding),namestring_asciz, { begin_blocking_system_call(); ret = realpath(namestring_asciz,path_buffer); end_blocking_system_call(); }); return ret; } /* return true if assure_dir_exists is done */ local maygc bool get_path_info (struct file_status *fs, char *namestring_asciz, uintC *allowed_links, bool tolerantp) { begin_blocking_system_call(); if (!( lstat(namestring_asciz,&(fs->fs_stat)) ==0)) { if (!tolerantp && (errno!=ENOENT)) { end_blocking_system_call(); OS_file_error(*(fs->fs_pathname)); } /* file does not exist. */ end_blocking_system_call(); FREE_DYNAMIC_ARRAY(namestring_asciz); fs->fs_stat_validp = false; return true; } end_blocking_system_call(); /* file exists. */ if (S_ISDIR(fs->fs_stat.st_mode)) error_directory(*(fs->fs_pathname)); else if (S_ISLNK(fs->fs_stat.st_mode)) { /* is it a symbolic link? yes -> continue resolving: */ if (*allowed_links == 0) { /* no more links allowed? */ /* yes -> simulate UNIX-Error ELOOP */ begin_system_call(); errno = ELOOP_VALUE; end_system_call(); OS_file_error(*(fs->fs_pathname)); } --*allowed_links; /* after that, one link less is allowed */ var uintL linklen = fs->fs_stat.st_size; /* presumed length of the link-content */ retry_readlink: { var DYNAMIC_ARRAY(linkbuf,char,linklen+1); /* buffer for the Link-content */ /* read link-content: */ { var int result; GC_SAFE_SYSTEM_CALL(result=, readlink(namestring_asciz,linkbuf,linklen)); if (result<0) OS_file_error(*(fs->fs_pathname)); if (!(result == (int)linklen)) { /* sometimes (AIX, NFS) status.st_size is incorrect */ FREE_DYNAMIC_ARRAY(linkbuf); linklen = result; goto retry_readlink; } } /* turn it into a pathname: (MERGE-PATHNAMES (PARSE-NAMESTRING linkbuf) pathname-without-name&type) */ pushSTACK(n_char_to_string(linkbuf,linklen,O(pathname_encoding))); FREE_DYNAMIC_ARRAY(linkbuf); } funcall(L(parse_namestring),1); pushSTACK(value1); var object pathname = copy_pathname(*(fs->fs_pathname)); ThePathname(pathname)->pathname_name = NIL; ThePathname(pathname)->pathname_type = NIL; pushSTACK(pathname); funcall(L(merge_pathnames),2); *(fs->fs_pathname) = value1; } else /* normal file */ return ((fs->fs_stat_validp = true)); return false; } local maygc void assure_dir_exists (struct file_status *fs, bool links_resolved, bool tolerantp) { var uintC allowed_links = MAXSYMLINKS; /* number of allowed symbolic links */ if (links_resolved) goto dir_exists; while (1) { /* loop over the symbolic links to be resolved */ { /* determine Truepath of the directory: */ var char path_buffer[MAXPATHLEN]; /* cf. REALPATH(3) */ { var object pathname = *(fs->fs_pathname); var uintC stringcount = /* host and directory strings */ directory_namestring_parts(pathname); pushSTACK(O(dot_string)); /* and "." */ var object string = string_concat(stringcount+1); /* concatenate */ /* resolve symbolic links therein: */ if (realpath_obj(string,path_buffer) == NULL) { if (errno!=ENOENT) { OS_file_error(*(fs->fs_pathname)); } if (!tolerantp) error_dir_not_exists(asciz_dir_to_pathname(path_buffer,O(pathname_encoding))); /* erroneous component */ fs->fs_namestring = nullobj; return; } } /* new Directory-Path must start with '/' : */ if (!(path_buffer[0] == '/')) { pushSTACK(*(fs->fs_pathname)); /* FILE-ERROR slot PATHNAME */ pushSTACK(asciz_to_string(&path_buffer[0],O(pathname_encoding))); error(file_error,GETTEXT("UNIX REALPATH returned ~S")); } /* possibly add a '/' at the end: */ var char* pathptr = &path_buffer[0]; var uintL len = 0; /* string-length */ while (*pathptr != 0) { pathptr++; len++; } /* search ASCIZ-string-end */ if (!((len>0) && (pathptr[-1]=='/'))) { *pathptr = '/'; len++; /* add a '/' */ } /* and convert to a string: */ var object new_string = n_char_to_string(&path_buffer[0],len,O(pathname_encoding)); /* turn it into a pathname and use its Directory: */ var object new_pathname = coerce_pathname(new_string); ThePathname(*(fs->fs_pathname))->pathname_directory = ThePathname(new_pathname)->pathname_directory; } dir_exists: pushSTACK(*(fs->fs_pathname)); funcall(L(merge_pathnames),1); *(fs->fs_pathname) = value1; /* get information for the addressed file: */ if (namenullp(*(fs->fs_pathname))) { /* no file addressed? */ fs->fs_namestring = directory_namestring(*(fs->fs_pathname)); return; /* yes -> finished */ } fs->fs_namestring = whole_namestring(*(fs->fs_pathname)); /* concat */ /* get information: */ pushSTACK(fs->fs_namestring); /* save for get_path_info() */ var bool done; with_sstring_0(fs->fs_namestring,O(pathname_encoding),namestring_asciz, { done = get_path_info(fs,namestring_asciz,&allowed_links,tolerantp); }); fs->fs_namestring = popSTACK(); /* restore */ if (done) return; } } #endif #ifdef PATHNAME_WIN32 #if 0 /* unused */ /* UP: Turns a directory-namestring into one, that is suitably for DOS. OSdirnamestring(namestring) > namestring: newly created directory-namestring, with '\' at the end, a normal-simple-string < result: namestring for this directory, in DOS-Format: last '\' discarded, if superfluous, a normal-simple-string can trigger GC */ local maygc object OSdirnamestring (object namestring) { var uintL len = Sstring_length(namestring); if (len==0) goto ok; /* empty string -> do not discard anything */ var chart ch = TheSnstring(namestring)->data[len-1]; if (!chareq(ch,ascii('\\'))) /* no '\' at the end -> do not discard */ goto ok; if (len==1) goto ok; /* "\" means Root -> do not discard */ ch = TheSnstring(namestring)->data[len-2]; if (chareq(ch,ascii('\\')) || colonp(ch)) /* '\' or ':' before it */ goto ok; /* -> means parent -> do not discard */ /* discard '\' at the end: */ namestring = subsstring(namestring,0,len-1); ok: /* do not discard anything */ return namestring; } #endif /* UP: Changes the default-drive and its default-directory. change_default(); > STACK_0: absolute pathname, whose device is a string and directory contains no :RELATIVE, :CURRENT, :PARENT, and name and type are =NIL. can trigger GC */ local maygc void change_default (void) { { /* change default-directory for this drive: */ var object pathname = STACK_0; var uintC stringcount = directory_namestring_parts(pathname); /* no redundant '\' at the end */ if (mconsp(Cdr(ThePathname(pathname)->pathname_directory))) { skipSTACK(1); stringcount--; } var object string = string_concat(stringcount); /* concatenate */ with_sstring_0(string,O(pathname_encoding),asciz, { /* change default-directory: */ change_current_directory(asciz); }); } /* change default-drive: */ O(default_drive) = ThePathname(STACK_0)->pathname_device; /* set *DEFAULT-PATHNAME-DEFAULTS* : */ recalc_defaults_pathname(); } #endif #ifdef PATHNAME_UNIX /* UP: changes the default-directory. change_default(); > STACK_0: absolute pathname, whose directory contains no :RELATIVE, :CURRENT, :PARENT , and name and Type are =NIL. can trigger GC */ local maygc void change_default (void) { var object string = directory_namestring(STACK_0); with_sstring_0(string,O(pathname_encoding),asciz, { /* change default-directory: */ begin_blocking_system_call(); if (!( chdir(asciz) ==0)) { end_blocking_system_call(); OS_file_error(STACK_0); } end_blocking_system_call(); }); } #endif LISPFUNNR(namestring,1) { /* (NAMESTRING pathname), CLTL p. 417 */ var object pathname = coerce_xpathname(popSTACK()); VALUES1(whole_namestring(pathname)); } /* error-message because of missing file name error_noname(pathname); > pathname: pathname */ local _Noreturn void error_noname (object pathname) { pushSTACK(pathname); /* FILE-ERROR slot PATHNAME */ pushSTACK(pathname); pushSTACK(TheSubr(subr_self)->name); error(file_error,GETTEXT("~S: No file name given: ~S")); } #define check_noname(pathname) \ do { if (namenullp(pathname)) { error_noname(pathname); } } while(0) /* error-message because of illegal Name/Type-specification error_notdir(pathname); > pathname: pathname */ local _Noreturn void error_notdir (object pathname) { pushSTACK(pathname); /* FILE-ERROR slot PATHNAME */ pushSTACK(pathname); pushSTACK(TheSubr(subr_self)->name); error(file_error,GETTEXT("~S: Not a directory: ~S")); } #define check_notdir(pathname) \ do { if (!(nullp(ThePathname(pathname)->pathname_name) \ && nullp(ThePathname(pathname)->pathname_type))) \ error_notdir(pathname); } while(0) /* test, if a file exists: file_exists(file_status) > only after: assure_dir_exists() */ #if defined(WIN32_NATIVE) local /* maygc */ inline int access0 (const char* path, struct file_status *fs) { GCTRIGGER1(fs->fs_namestring); GC_SAFE_SYSTEM_CALL(fs->fs_fileattr=, GetFileAttributes(path)); if (fs->fs_fileattr == 0xFFFFFFFF) { if (WIN32_ERROR_NOT_FOUND) { return -1; } OS_file_error(*(fs->fs_pathname)); } return 0; } local /* maygc */ bool file_exists (struct file_status *fs) { GCTRIGGER1(fs->fs_namestring); var bool exists; with_sstring_0(fs->fs_namestring,O(pathname_encoding),namestring_asciz, { exists = (access0(namestring_asciz,fs)==0); }); return exists; } #elif defined(UNIX) #define file_exists(fs) ((fs)->fs_stat_validp) #define FILE_EXISTS_TRIVIAL #else #error file_exists is not defined #endif /* error-message because of non-existent file error_file_not_exists(); > STACK_0: pathname */ local _Noreturn void error_file_not_exists (void) { /* STACK_0 = FILE-ERROR slot PATHNAME */ pushSTACK(STACK_0); /* pathname */ pushSTACK(TheSubr(subr_self)->name); error(file_error,GETTEXT("~S: File ~S does not exist")); } /* TRUENAME for a pathname set fs->fs_pathname to the truename (filename for the operating system) or nullobj can trigger GC */ local maygc void true_namestring (struct file_status *fs, bool noname_p, bool tolerantp) { check_no_wildcards(*fs->fs_pathname); /* with wildcards -> error */ *(fs->fs_pathname) = use_default_dir(*(fs->fs_pathname)); /* insert default-directory */ if (noname_p) check_noname(*(fs->fs_pathname)); assure_dir_exists(fs,false,tolerantp); } LISPFUNNS(truename,1) { /* (TRUENAME pathname), CLTL p. 413 */ var object pathname = STACK_0; /* pathname-argument */ if (builtin_stream_p(pathname)) { /* stream -> treat extra: */ /* must be file-stream: */ pathname = as_file_stream(pathname); test_file_stream_named(pathname); /* Streamtype File-Stream */ VALUES1(TheStream(pathname)->strm_file_truename); } else { var struct file_status fs; file_status_init(&fs,&STACK_0); *(fs.fs_pathname) = merge_defaults(coerce_pathname(pathname)); true_namestring(&fs,false,false); if (namenullp(*(fs.fs_pathname))) { /* no name specified */ if (!nullp(ThePathname(*(fs.fs_pathname))->pathname_type)) { pushSTACK(*(fs.fs_pathname)); /* FILE-ERROR slot PATHNAME */ pushSTACK(STACK_0); /* pathname */ pushSTACK(TheSubr(subr_self)->name); error(file_error,GETTEXT("~S: pathname with type but without name makes no sense: ~S")); } /* no name and no type specified -> pathname as result */ } else { /* name specified. check, if the file exists: */ if (!file_exists(&fs)) { error_file_not_exists(); } /* file exists -> pathname as value */ } VALUES1(*(fs.fs_pathname)); } skipSTACK(1); } /* Probe filename referred to by the stream > stream : a built-in stream < stream : its strm_file_truename (or error is not a file stream) < true if the stream was open and thus no further checks are necessary */ local bool probe_path_from_stream (gcv_object_t *stream) { /* must be file-stream: */ *stream = as_file_stream(*stream); test_file_stream_named(*stream); /* streamtype file-stream -> take truename: */ var uintB flags = TheStream(*stream)->strmflags; *stream = TheStream(*stream)->strm_file_truename; return flags & strmflags_open_B; } LISPFUNNS(probe_file,1) { /* (PROBE-FILE filename), CLTL p. 424 */ if (builtin_stream_p(STACK_0)) { /* stream -> treat extra: */ if (probe_path_from_stream(&STACK_0)) { VALUES1(popSTACK()); return; } } else /* turn into a pathname */ STACK_0 = merge_defaults(coerce_pathname(STACK_0)); /* STACK_0 is a pathname */ var struct file_status fs; file_status_init(&fs,&STACK_0); true_namestring(&fs,true,true); if (eq(fs.fs_namestring,nullobj)) { /* path to the file does not exist -> NIL as value: */ skipSTACK(1); VALUES1(NIL); return; } if (file_exists(&fs)) /* check, if the file exists: */ VALUES1(*(fs.fs_pathname)); /* file exists -> pathname as value */ else VALUES1(NIL); /* else NIL as value */ skipSTACK(1); } #if defined(WIN32_NATIVE) #define FIND_DATA_FWD(filedata) \ ((filedata.ftLastWriteTime.dwLowDateTime == 0 \ && filedata.ftLastWriteTime.dwHighDateTime == 0) \ ? &(filedata.ftCreationTime) : &(filedata.ftLastWriteTime)) #define FIND_DATA_FSIZE(filedata) \ (((uint64)filedata.nFileSizeHigh<<32)|filedata.nFileSizeLow) /* call FindFirstFile with all checks > namestring_asciz : asciz path < filedata : file data STACK_0 = FILE-ERROR slot PATHNAME */ local void find_first_file (const char *namestring_asciz, WIN32_FIND_DATA *filedata) { var HANDLE search_handle; begin_blocking_system_call(); search_handle = FindFirstFile(namestring_asciz,filedata); if (search_handle == INVALID_HANDLE_VALUE) { if (WIN32_ERROR_NOT_FOUND) { end_blocking_system_call(); error_file_not_exists(); } end_blocking_system_call(); OS_file_error(STACK_0); } else if (!FindClose(search_handle)) { end_blocking_system_call(); OS_file_error(STACK_0); } end_blocking_system_call(); } #endif /* Check whether the file exists > namestring : path > STACK_0 = FILE-ERROR slot PATHNAME < resolved : truename (if return is success, i.e., FILE or DIR) < fwd: file write date (if return is success and address is supplied) < fsize: file size (if return is success and address is supplied) < returns: the file kind triggers GC if fwd or fsize are supplied */ global /*maygc*/ file_kind_t classify_namestring (const char* namestring, char *resolved, gcv_object_t *fwd, gcv_object_t* fsize) { if (fwd || fsize) GCTRIGGER(); #if defined(UNIX) struct stat status; int ret; GC_SAFE_SYSTEM_CALL(ret=, stat(namestring,&status)); if (ret) { if (errno != ENOENT && errno != ENOTDIR) return FILE_KIND_BAD; return FILE_KIND_NONE; /* does not exist */ } else { /* file exists. */ realpath(namestring,resolved); /* ==> success assured */ if (fwd) *fwd = convert_time_to_universal(&(status.st_mtime)); if (fsize) *fsize = off_to_I(status.st_size); if (S_ISDIR(status.st_mode)) return FILE_KIND_DIR; else return FILE_KIND_FILE; } #elif defined(WIN32_NATIVE) bool ret; begin_blocking_system_call(); if (real_path(namestring,resolved)) { WIN32_FILE_ATTRIBUTE_DATA filedata; BOOL success = GetFileAttributesEx(resolved, GetFileExInfoStandard, &filedata); end_blocking_system_call(); if (success) { /* file exists. */ if (fwd) *fwd = convert_time_to_universal( filedata.ftLastWriteTime.dwHighDateTime || filedata.ftLastWriteTime.dwLowDateTime ? &filedata.ftLastWriteTime : &filedata.ftCreationTime); if (fsize) *fsize = off_to_I( ((uint64)filedata.nFileSizeHigh<<32)|filedata.nFileSizeLow); if (filedata.dwFileAttributes & FILE_ATTRIBUTE_DIRECTORY) return FILE_KIND_DIR; else return FILE_KIND_FILE; } else { /* you get ERROR_INVALID_NAME on GetFileAttributes("foo/") when file "foo" exists */ if (!(WIN32_ERROR_NOT_FOUND || GetLastError() == ERROR_INVALID_NAME)) return FILE_KIND_BAD; return FILE_KIND_NONE; /* does not exist */ } } else { end_blocking_system_call(); return FILE_KIND_NONE; } #else #error classify_namestring is not defined #endif } LISPFUNNS(probe_pathname,1) /* (PROBE-PATHNAME pathname) */ { /* a safe way to distinguish between files and dirs: "dir", "dir/" ==> #p"dir/" "file", "file/" ==> #p"file" "none", "none/" ==> NIL the first value is the truename, the second is the "correct" absolute pathname */ if (builtin_stream_p(STACK_0)) { /* stream -> path */ probe_path_from_stream(&STACK_0); /* STACK_0 is now an absolute truename */ } else { /* turn into a pathname */ STACK_0 = merge_defaults(coerce_pathname(STACK_0)); check_no_wildcards(STACK_0); STACK_0 = use_default_dir(STACK_0); /* absolute pathname */ } /* STACK_0 is a non-wild non-logical absolute pathname */ var file_kind_t classification; var char resolved[MAXPATHLEN]; pushSTACK(NIL); pushSTACK(STACK_1); /* space for FWD & FSIZE */ with_sstring_0(whole_namestring(STACK_0),O(pathname_encoding), namestring_asciz, { while (true) { classification = classify_namestring(namestring_asciz,resolved, &STACK_1/*fwd*/,&STACK_2/*fsize*/); if (classification == FILE_KIND_NONE && namestring_asciz_bytelen > 1 /* no need to classify "" */ && cpslashp(namestring_asciz[namestring_asciz_bytelen-1])) namestring_asciz[--namestring_asciz_bytelen] = 0; /* strip last slash */ else break; } }); switch (classification) { case FILE_KIND_NONE: /* does not exist */ VALUES1(NIL); skipSTACK(3); return; case FILE_KIND_DIR: { /* directory */ int len = strlen(resolved); if (!cpslashp(resolved[len-1])) { /* append '/' to truename */ resolved[len] = '/'; resolved[len+1]= 0; } if (!namenullp(STACK_0)) { /* make STACK_0 a directory pathname */ STACK_0 = copy_pathname(STACK_0); var uintC count = file_namestring_parts(STACK_0); var object tmp = string_concat(count); pushSTACK(tmp); tmp = allocate_cons(); Car(tmp) = STACK_0; STACK_0 = tmp; tmp = ThePathname(STACK_1)->pathname_directory; if (consp(tmp)) { /* do NOT modify the argument! */ tmp = copy_list(tmp); ThePathname(STACK_1)->pathname_directory = tmp; while (!nullp(Cdr(tmp))) tmp = Cdr(tmp); Cdr(tmp) = popSTACK(); /* append name.type to directory */ } else if (nullp(tmp)) { tmp = allocate_cons(); ThePathname(STACK_1)->pathname_directory = tmp; Car(tmp) = S(Krelative); Cdr(tmp) = popSTACK(); /* :directory (:relative name.type) */ } else NOTREACHED; ThePathname(STACK_0)->pathname_name = NIL; /* drop name... */ ThePathname(STACK_0)->pathname_type = NIL; /* ...and type */ } } break; case FILE_KIND_FILE: /* file */ if (namenullp(STACK_0)) { /* make STACK_0 a regular file pathname */ STACK_0 = copy_pathname(STACK_0); var object tmp = ThePathname(STACK_0)->pathname_directory; while (!nullp(Cdr(Cdr(tmp)))) tmp = Cdr(tmp); pushSTACK(Car(Cdr(tmp))); Cdr(tmp) = NIL; /* chop off last dir comp */ split_name_type(1); ThePathname(STACK_2)->pathname_name = STACK_1; ThePathname(STACK_2)->pathname_type = STACK_0; skipSTACK(2); } break; case FILE_KIND_BAD: OS_file_error(STACK_0); } pushSTACK(asciz_to_string(resolved,O(pathname_encoding))); funcall(L(truename),1); value2 = popSTACK(); value3 = popSTACK(); value4 = popSTACK(); mv_count = 4; } #ifdef UNIX /* call stat(2) on the object and return its return value > namestring: string > status: pointer to a stat < status */ local maygc int stat_obj (object namestring, struct stat *status) { int ret; with_sstring_0(namestring,O(pathname_encoding),namestring_asciz, { GC_SAFE_SYSTEM_CALL(ret=, stat(namestring_asciz,status)); }); return ret; } #endif /* tests, if a directory exists. directory_exists(pathname) > pathname: an absolute pathname without wildcards, with Name=NIL and Type=NIL < result: true, if it denotes an existing directory can trigger GC */ local maygc bool directory_exists (object pathname) { pushSTACK(pathname); /* save pathname */ var object dir_namestring = directory_namestring(pathname); /* existence test, see assure_dir_exists(): */ var bool exists = true; #if defined(WIN32_NATIVE) with_sstring_0(dir_namestring,O(pathname_encoding),dir_namestring_asciz, { if (!nullp(Cdr(ThePathname(STACK_0)->pathname_directory))) { var uintL len = Sstring_length(dir_namestring); ASSERT((len > 0) && cpslashp(dir_namestring_asciz[len-1])); dir_namestring_asciz[len-1] = '\0'; /* replace '\' at the end with nullbyte */ } var DWORD fileattr; GC_SAFE_SYSTEM_CALL(fileattr=, GetFileAttributes(dir_namestring_asciz)); if (fileattr == 0xFFFFFFFF) { if (!WIN32_ERROR_NOT_FOUND) { OS_file_error(STACK_0); } exists = false; } else { if (!(fileattr & FILE_ATTRIBUTE_DIRECTORY)) /* found file is no subdirectory ? */ exists = false; } }); #elif defined(PATHNAME_UNIX) pushSTACK(dir_namestring); pushSTACK(O(dot_string)); /* and "." */ dir_namestring = string_concat(2); /* concatenate */ var struct stat statbuf; if (stat_obj(dir_namestring,&statbuf) < 0) { if (errno != ENOENT) OS_file_error(STACK_0); exists = false; } else { if (!S_ISDIR(statbuf.st_mode)) /* found file is no subdirectory ? */ exists = false; } #else #error directory_exists is not defined #endif skipSTACK(1); return exists; } LISPFUNNS(probe_directory,1) { /* (PROBE-DIRECTORY filename) tests, if a directory exists. */ var object pathname = popSTACK(); /* pathname-argument */ pathname = merge_defaults(coerce_pathname(pathname)); /* --> pathname */ check_no_wildcards(pathname); /* with wildcards -> error */ pathname = use_default_dir(pathname); /* insert default-directory */ check_notdir(pathname); /* ensure that Name=NIL and Type=NIL */ VALUES_IF(directory_exists(pathname)); } /* Converts a directory pathname to an OS directory specification. > pathname: an object > use_default: whether to use the current default directory < result: a simple-bit-vector containing an ASCIZ string in OS format can trigger GC */ modexp maygc object pathname_to_OSdir (object pathname, bool use_default) { pathname = coerce_pathname(pathname); /* convert to pathname */ check_no_wildcards(pathname); /* if it has wildcards -> error */ if (use_default) pathname = use_default_dir(pathname); /* insert default directory */ check_notdir(pathname); /* ensure that Name=NIL and Type=NIL */ pushSTACK(pathname); /* save pathname */ var object dir_namestring = directory_namestring(pathname); var object dir_namestring_asciz = string_to_asciz(dir_namestring,O(pathname_encoding)); var char* asciz = TheAsciz(dir_namestring_asciz); var uintL len = asciz_length(asciz); #if defined(WIN32_NATIVE) || defined(UNIX) if (!nullp(Cdr(ThePathname(STACK_0)->pathname_directory))) { ASSERT((len > 0) && cpslashp(asciz[len-1])); asciz[len-1] = '\0'; } #endif skipSTACK(1); /* forget pathname */ return dir_namestring_asciz; } /* Converts an OS directory specification to a directory pathname. > path: a pathname referring to a directory < result: a pathname without name and type can trigger GC */ modexp maygc object OSdir_to_pathname (const char* path) { return asciz_dir_to_pathname(path,O(pathname_encoding)); } /* UP: determines, if a file is opened. openp(pathname) */ #ifdef PATHNAME_WIN32 /* > pathname: absolute pathname, without wildcards. */ #endif #ifdef PATHNAME_UNIX /* > pathname: absolute pathname, without wildcards, after resolution of symbolic links */ #endif /* < result: true, if an opened file-stream exits for this file. */ local maygc bool openp (object pathname) { pushSTACK(pathname); var bool found = false; var gcv_object_t *pathname_ = &STACK_0; WITH_OS_MUTEX_LOCK(0,&open_files_lock, { var object flist = O(open_files); /* traverse list of all open files */ while (!found && consp(flist)) { var object f = Car(flist); /* next open stream */ if (TheStream(f)->strmtype == strmtype_file) { /* file-stream ? */ if (equal(TheStream(f)->strm_file_truename,*pathname_)) { found = true; /* exit */ } } flist = Cdr(flist); } }); skipSTACK(1); return found; } /* error-message because of deletion attempt on opened file error_delete_open(pathname); > pathname: truename of the file */ local _Noreturn void error_delete_open (object pathname) { pushSTACK(pathname); /* FILE-ERROR slot PATHNAME */ pushSTACK(pathname); pushSTACK(TheSubr(subr_self)->name); error(file_error,GETTEXT("~S: Cannot delete file ~S since there is a file stream open to it")); } #define check_delete_open(pathname) \ do { if (openp(pathname)) { error_delete_open(pathname); } } while(0) /* (DELETE-FILE filename), CLTL p. 424 */ LISPFUNN(delete_file,1) { var object pathname = popSTACK(); /* pathname-argument */ if (builtin_stream_p(pathname)) { /* stream -> treat extra: */ var object stream = as_file_stream(pathname); /* must be file-stream */ test_file_stream_named(stream); /* Streamtype file-stream. if file is opened, close file first: */ if (TheStream(stream)->strmflags & strmflags_open_B) { /* file opened ? */ pushSTACK(stream); builtin_stream_close(&STACK_0,0); stream = popSTACK(); } /* then take the truename as file to be deleted: */ pathname = TheStream(stream)->strm_file_truename; } else /* turn into a pathname */ pathname = merge_defaults(coerce_pathname(pathname)); /* pathname is now a pathname. */ check_no_wildcards(pathname); /* with wildcards -> error */ pathname = use_default_dir(pathname); /* insert default-directory */ check_noname(pathname); pushSTACK(pathname); pushSTACK(pathname); var struct file_status fs; file_status_init(&fs,&STACK_0); assure_dir_exists(&fs,false,true); if (!eq(fs.fs_namestring,nullobj)) /* path to the file exists */ check_delete_open(*(fs.fs_pathname)); /* delete the original filename - not the truename (which may be invalid!) */ if (delete_file_if_exists_obj(whole_namestring(STACK_1))) /* file existed, was deleted -> pathname (/=NIL) as value */ VALUES1(nullp(O(ansi)) ? (object)STACK_1 : T); else /* file does not exist -> value NIL */ VALUES1(NIL); skipSTACK(2); } /* error-message because of renaming attempt of an opened file error_rename_open(pathname); > pathname: truename of the file */ local _Noreturn void error_rename_open (object pathname) { pushSTACK(pathname); /* FILE-ERROR slot PATHNAME */ pushSTACK(pathname); pushSTACK(TheSubr(subr_self)->name); error(file_error,GETTEXT("~S: Cannot rename file ~S since there is a file stream open to it")); } #define check_rename_open(pathname) \ do { if (openp(pathname)) { error_rename_open(pathname); } } while(0) /* UP: Renames a file. rename_file(); > stack layout: filename, newname, oldpathname. < stack layout: filename, newname, oldpathname, newpathname, oldtruename, oldnamestring, newtruename, newnamestring. */ local void rename_file (if_exists_t if_exists) { { /* 1. newpathname := (MERGE-PATHNAMES newname oldpathname) */ pushSTACK(STACK_1); /* newname as 1st argument */ pushSTACK(STACK_(0+1)); /* oldpathname as 2nd argument */ funcall(L(merge_pathnames),2); pushSTACK(value1); } /* stack layout: filename, newname, oldpathname, newpathname. */ { /* 2. check oldpathname: */ pushSTACK(STACK_1); var struct file_status fs; file_status_init(&fs,&STACK_0); true_namestring(&fs,true,false); pushSTACK(fs.fs_namestring); check_rename_open(*(fs.fs_pathname)); /* do not rename open files! */ fs.fs_namestring = STACK_0; if (!file_exists(&fs)) error_file_not_exists(); fs.fs_namestring = popSTACK(); pushSTACK(fs.fs_namestring); } /* stack layout: filename, newname, oldpathname, newpathname, oldtruename, oldnamestring. */ { /* 3. check newpathname: */ var object newpathname = coerce_pathname(STACK_2); pushSTACK(newpathname); var struct file_status fs; file_status_init(&fs,&STACK_0); true_namestring(&fs,true,false); /* stack layout: filename, newname, oldpathname, newpathname, oldtruename, oldnamestring, newtruename. 4. rename file: */ pushSTACK(fs.fs_namestring); /* since soon may be invalid */ switch (if_exists) { case IF_EXISTS_UNBOUND: case IF_EXISTS_NIL: case IF_EXISTS_ERROR: if (file_exists(&fs)) { skipSTACK(1); /* file already exists -> do not delete without forewarn */ error_file_exists(); } break; default: break; /* atomically replace */ } } /* stack layout: filename, newname, oldpathname, newpathname, oldtruename, oldnamestring, newtruename, newnamestring. now it can be renamed without risk: */ rename_existing_path(STACK_2,STACK_0); } /* (RENAME-FILE filename newname &if-exists), CLTL p. 423 */ LISPFUN(rename_file,seclass_default,2,0,norest,key,1,(kw(if_exists))) { var if_exists_t if_exists = check_if_exists(popSTACK()); if (!nullp(O(ansi)) && if_exists != IF_EXISTS_UNBOUND) error_too_many_args(unbound,S(rename_file),4,2); var object filename = STACK_1; /* filename-argument */ if (builtin_stream_p(filename)) { /* stream -> treat extra: */ /* must be file-stream: */ filename = as_file_stream(filename); test_file_stream_named(filename); /* streamtype file-stream -> use truename: */ filename = TheStream(filename)->strm_file_truename; pushSTACK(filename); /* rename: */ rename_file(if_exists); /* update stream: */ filename = STACK_7; TheStream(filename)->strm_file_name = STACK_4; /* newpathname as new name */ TheStream(filename)->strm_file_truename = STACK_1; /* newtruename as new truename */ /* leave handle etc. untouched */ } else { /* turn into a pathname */ filename = merge_defaults(coerce_pathname(filename)); pushSTACK(filename); /* rename: */ rename_file(if_exists); } VALUES3(STACK_4, /* newpathname as 1st value */ STACK_3, /* oldtruename as 2nd value */ STACK_1); /* newtruename as 3rd value */ skipSTACK(8); } /* Create a file. create_new_file(pathstring); It is known that the file does not already exist. > pathstring: file name, ASCIZ-String > STACK_0: pathname */ local maygc inline void create_new_file (char* pathstring) { #if defined(WIN32_NATIVE) var Handle handle; GC_SAFE_SYSTEM_CALL(handle=, CreateFile(pathstring, 0, FILE_SHARE_READ | FILE_SHARE_WRITE, NULL, CREATE_ALWAYS, FILE_ATTRIBUTE_NORMAL, NULL)); if (handle==INVALID_HANDLE_VALUE) { OS_file_error(STACK_0); } /* file was created, handle is the Handle. close file again: */ var BOOL closed; GC_SAFE_SYSTEM_CALL(closed=, CloseHandle(handle)); if (!closed) { OS_file_error(STACK_0); } #elif defined(UNIX) var int result; GC_SAFE_SYSTEM_CALL(result=, OPEN(pathstring, O_WRONLY | O_BINARY | O_CREAT | O_TRUNC, my_open_mask)); if (result<0) { OS_file_error(STACK_0); } /* report error */ /* file was created, result is the Handle. close file again: */ var int closed; GC_SAFE_SYSTEM_CALL(closed=, CLOSE(result)); if (!(closed == 0)) { OS_file_error(STACK_0); } /* report error */ #else #error create_new_file is not defined #endif } /* Open a file for input. open_input_file(file_status, pathstring,create_if_not_exists,&handle) > only after: assure_dir_exists() > file_status: structure, filled in by assure_dir_exists() > pathstring: file name, ASCIZ-String > create_if_not_exists: if true, the file must be created > STACK_0: pathname < handle: open file handle < result: whether the file could be opened (necessarily true if create_if_not_exists) */ local maygc inline bool open_input_file (struct file_status *fs, char* pathstring, bool create_if_not_exists, Handle* handle_) { #if defined(UNIX) var int result; #ifdef FILE_EXISTS_TRIVIAL var int oflags = O_RDONLY | O_BINARY; if (!file_exists(fs)) { /* file does not exist */ if (!create_if_not_exists) return false; /* create file with open: */ oflags |= O_CREAT; } GC_SAFE_SYSTEM_CALL(result=, OPEN(pathstring,oflags,my_open_mask)); if (result<0) { OS_file_error(STACK_0); } #else var int oflags = O_RDONLY | O_BINARY; if (create_if_not_exists) { oflags |= O_CREAT; } GC_SAFE_SYSTEM_CALL(result=, OPEN(pathstring,oflags,my_open_mask)); if (result<0) { if (errno == ENOENT) { /* not found? */ /* file does not exist */ if (!create_if_not_exists) { return false; } } OS_file_error(STACK_0); /* report error */ } #endif *handle_ = result; return true; #elif defined(WIN32_NATIVE) var Handle handle; #ifdef FILE_EXISTS_TRIVIAL var DWORD flag = OPEN_EXISTING; if (!file_exists(_EMA_)) { /* file does not exist */ if (!create_if_not_exists) return false; /* create file with CreateFile: */ flag = OPEN_ALWAYS; } GC_SAFE_SYSTEM_CALL(handle=, CreateFile(pathstring, GENERIC_READ, FILE_SHARE_READ | FILE_SHARE_WRITE, NULL, flag, FILE_ATTRIBUTE_NORMAL, NULL)); if (handle==INVALID_HANDLE_VALUE) { OS_file_error(STACK_0); } #else var DWORD flag = OPEN_EXISTING; if (create_if_not_exists) { flag = OPEN_ALWAYS; } GC_SAFE_SYSTEM_CALL(handle=, CreateFile(pathstring, GENERIC_READ, FILE_SHARE_READ | FILE_SHARE_WRITE, NULL, flag, FILE_ATTRIBUTE_NORMAL, NULL)); if (handle==INVALID_HANDLE_VALUE) { if (WIN32_ERROR_NOT_FOUND) { /* not found? */ /* file does not exist */ if (!create_if_not_exists) { return false; } } OS_file_error(STACK_0); /* report Error */ } #endif *handle_ = handle; return true; #else #error open_input_file is not defined #endif } /* Open a file for output. open_output_file(pathstring,truncate_if_exists) > pathstring: file name, ASCIZ-String > truncate_if_exists: if true, the file is truncated to zero size > STACK_0: pathname < result: open file handle */ local maygc inline Handle open_output_file (char* pathstring, bool wronly, bool truncate_if_exists) { #if defined(UNIX) begin_blocking_system_call(); var int flags = O_BINARY | O_CREAT | (truncate_if_exists ? O_TRUNC : 0); /* regular file or !wronly => O_RDWR i.e., for the handle to be O_WRONLY, it must be opened :DIRECTION :OUTPUT AND the underlying file must be special (pipe &c) see bug #[ 1379620 ]: open FIFOs with write-only access for IPC see Stevens, UNIX Network Programming, vol 2 (IPC), ch 4 (pipes & FIFOs)*/ if (wronly) { /* regular (regular_handle_p) => ignore wronly for buffering */ var struct stat statbuf; if (stat(pathstring,&statbuf) || S_ISREG(statbuf.st_mode) || S_ISBLK(statbuf.st_mode)) flags |= O_RDWR; /* not exists or regular => read-write */ else flags |= O_WRONLY; /* special => write-only */ } else flags |= O_RDWR; var int result = OPEN(pathstring,flags,my_open_mask); end_blocking_system_call(); if (result<0) { OS_file_error(STACK_0); } /* report error */ return result; #elif defined(WIN32_NATIVE) begin_blocking_system_call(); var Handle handle = /* ignore wronly: no "special" files where it may hurt */ CreateFile(pathstring, GENERIC_READ | GENERIC_WRITE, FILE_SHARE_READ | FILE_SHARE_WRITE, NULL, (truncate_if_exists ? CREATE_ALWAYS : OPEN_ALWAYS), FILE_ATTRIBUTE_NORMAL, NULL); end_blocking_system_call(); if (handle==INVALID_HANDLE_VALUE) { OS_file_error(STACK_0); } return handle; #else #error open_output_file is nore defined #endif } local maygc inline Handle open_output_file_obj (object namestring, bool wronly, bool truncate_if_exists) { Handle ret; with_sstring_0(namestring,O(pathname_encoding),namestring_asciz, { ret = open_output_file(namestring_asciz,wronly,truncate_if_exists); }); return ret; } /* Create a backup file before opening a file for output. create_backup_file(pathstring,delete_backup_file); > only after: assure_dir_exists() > pathstring: file name, ASCIZ-String > delete_backup_file: if true, delete the backup file > STACK_0: pathname Can trigger GC */ local inline maygc void create_backup_file (char* pathstring, bool delete_backup_file) { check_rename_open(STACK_0); /* do not rename open files! */ var object filename = STACK_0; var object new_namestring; /* extend truename with "%" resp. ".bak" resp. "~" : filename := (parse-namestring (concatenate 'string (namestring filename) "%")) : */ filename = whole_namestring(filename); /* as String */ pushSTACK(filename); pushSTACK(O(backupextend_string)); /* "%" */ filename = string_concat(2); /* concatenate */ pushSTACK(filename); /* save */ pushSTACK(filename); /* save */ filename = coerce_pathname(filename); /* again as filename */ pushSTACK(filename); check_delete_open(filename); /* maygc */ filename = popSTACK(); STACK_1 = filename; /* directory already exists. Do not resolve further links here. */ new_namestring = popSTACK(); /* filename for the operating system */ with_sstring_0(new_namestring,O(pathname_encoding),new_namestring_asciz, { /* delete file (or link) with this name, if existing: */ delete_file_before_rename(new_namestring_asciz); /* rename file from the old name to this name: */ rename_existing_file(pathstring,new_namestring_asciz); if (delete_backup_file) { delete_existing_file(new_namestring_asciz); } }); skipSTACK(1); } local inline maygc void create_backup_file_obj (object namestring, bool delete_backup_file) { with_sstring_0(namestring,O(pathname_encoding),namestring_asciz, { create_backup_file(namestring_asciz,delete_backup_file); }); } /* check the :DIRECTION argument */ modexp direction_t check_direction (object dir) { if (!boundp(dir) || eq(dir,S(Kinput))) return DIRECTION_INPUT; else if (eq(dir,S(Kinput_immutable))) return DIRECTION_INPUT_IMMUTABLE; else if (eq(dir,S(Koutput))) return DIRECTION_OUTPUT; else if (eq(dir,S(Kio))) return DIRECTION_IO; else if (eq(dir,S(Kprobe))) return DIRECTION_PROBE; else error_illegal_arg(dir,O(type_direction),S(Kdirection)); } local object direction_symbol (direction_t direction) { switch (direction) { case DIRECTION_INPUT: { return S(Kinput); } case DIRECTION_INPUT_IMMUTABLE: { return S(Kinput_immutable); } case DIRECTION_OUTPUT: { return S(Koutput); } case DIRECTION_IO: { return S(Kio); } case DIRECTION_PROBE: { return S(Kprobe); } default: NOTREACHED; } } /* check the :IF-DOES-NOT-EXIST argument check_if_does_not_exist(argument) */ modexp if_does_not_exist_t check_if_does_not_exist (object if_not_exist) { if (!boundp(if_not_exist)) return IF_DOES_NOT_EXIST_UNBOUND; else if (eq(if_not_exist,S(Kerror))) return IF_DOES_NOT_EXIST_ERROR; else if (nullp(if_not_exist)) return IF_DOES_NOT_EXIST_NIL; else if (eq(if_not_exist,S(Kcreate))) return IF_DOES_NOT_EXIST_CREATE; else error_illegal_arg(if_not_exist,O(type_if_does_not_exist), S(Kif_does_not_exist)); } /* Converts a :IF-DOES-NOT-EXIST enum item to a symbol. if_does_not_exist_symbol(item)*/ modexp object if_does_not_exist_symbol (if_does_not_exist_t if_not_exist) { switch (if_not_exist) { case IF_DOES_NOT_EXIST_UNBOUND: { return unbound; } case IF_DOES_NOT_EXIST_ERROR: { return S(Kerror); } case IF_DOES_NOT_EXIST_NIL: { return NIL; } case IF_DOES_NOT_EXIST_CREATE: { return S(Kcreate); } } NOTREACHED; } /* check the :IF-EXISTS argument check_if_exists(argument) */ modexp if_exists_t check_if_exists (object if_exists) { if (!boundp(if_exists)) return IF_EXISTS_UNBOUND; else if (eq(if_exists,S(Kerror))) return IF_EXISTS_ERROR; else if (nullp(if_exists)) return IF_EXISTS_NIL; else if (eq(if_exists,S(Krename))) return IF_EXISTS_RENAME; else if (eq(if_exists,S(Krename_and_delete))) return IF_EXISTS_RENAME_AND_DELETE; else if (eq(if_exists,S(Knew_version)) || eq(if_exists,S(Ksupersede))) return IF_EXISTS_SUPERSEDE; else if (eq(if_exists,S(Kappend))) return IF_EXISTS_APPEND; else if (eq(if_exists,S(Koverwrite))) return IF_EXISTS_OVERWRITE; else error_illegal_arg(if_exists,O(type_if_exists),S(Kif_exists)); } /* Converts a :IF-EXISTS enum item to a symbol. if_exists_symbol(item) */ modexp object if_exists_symbol (if_exists_t if_exists) { switch (if_exists) { /* :IF-EXISTS */ case IF_EXISTS_UNBOUND: { return unbound; } case IF_EXISTS_ERROR: { return S(Kerror); } case IF_EXISTS_NIL: { return NIL; } case IF_EXISTS_RENAME: { return S(Krename); } case IF_EXISTS_RENAME_AND_DELETE: { return S(Krename_and_delete); } case IF_EXISTS_SUPERSEDE: { return S(Ksupersede); } case IF_EXISTS_APPEND: { return S(Kappend); } case IF_EXISTS_OVERWRITE: { return S(Koverwrite); } } NOTREACHED; } /* UP: check that the file we are about to open has not been opened yet > object truename - the name of the file that is being opened > direction_t direction - the direction of the pending OPEN can trigger GC - if CERROR or WARNING is signaled */ extern maygc void* find_open_file (struct file_id *fid, uintB flags); local maygc void check_file_reopen (object truename, direction_t direction) { var uintB flags; switch (direction) { case DIRECTION_INPUT_IMMUTABLE: case DIRECTION_INPUT: flags = strmflags_wr_B; break; case DIRECTION_IO: case DIRECTION_OUTPUT: flags = (strmflags_rd_B | strmflags_wr_B); break; default: return; /* PROBE: nothing to check */ } check_file_reopen_restart_search: var object bad_stream = nullobj; var struct file_id fi; var os_error_code_t status; pushSTACK(truename); /* save for find_open_file & namestring_file_id. */ with_string_0(truename,O(pathname_encoding),namez, { GC_SAFE_SYSTEM_CALL(status=, namestring_file_id(namez,&fi)); }); if (status == 0 /* file exists - see if it is already open */ && find_open_file(&fi,flags)) bad_stream = popSTACK(); truename = popSTACK(); if (!eq(bad_stream,nullobj)) { /* found an existing open stream */ #define error_format_string CLSTEXT("~S: ~S already points to file ~S, opening the file again for ~S may produce unexpected results") if (eq(Symbol_value(S(reopen_open_file)),S(error))) { check_file_reopen_error: pushSTACK(NIL); /* 8: continue-format-string */ pushSTACK(S(file_error)); /* 7: error type */ pushSTACK(S(Kpathname)); /* 6: :PATHNAME */ pushSTACK(truename); /* 5: the offending pathname */ pushSTACK(NIL); /* 4: error-format-string */ pushSTACK(TheSubr(subr_self)->name); /* 3: caller */ pushSTACK(bad_stream); /* 2: bad stream */ pushSTACK(truename); /* 1: truename */ pushSTACK(direction_symbol(direction)); /* 0: direction */ STACK_8 = CLSTEXT("Open the file anyway"); /* continue-format-string */ STACK_4 = error_format_string; funcall(L(cerror_of_type),9); } else if (eq(Symbol_value(S(reopen_open_file)),S(warn))) { pushSTACK(NIL); /* 4: error_format_string */ pushSTACK(TheSubr(subr_self)->name); /* 3: caller */ pushSTACK(bad_stream); /* 2: bad stream */ pushSTACK(truename); /* 1: truename */ pushSTACK(direction_symbol(direction)); /* 0: direction */ STACK_4 = error_format_string; funcall(S(warn),5); } else if (eq(Symbol_value(S(reopen_open_file)),S(closeL))) { pushSTACK(truename); /* save */ pushSTACK(bad_stream); builtin_stream_close(&STACK_0,1); skipSTACK(1); truename = popSTACK(); /* restore */ goto check_file_reopen_restart_search; } else { pushSTACK(bad_stream); pushSTACK(truename); /* save */ pushSTACK(CLSTEXT("~S: The value of ~S should be one of ~S, ~S, ~S, or ~S, not ~S. It has been changed to ~S.")); pushSTACK(TheSubr(subr_self)->name); pushSTACK(S(reopen_open_file)); pushSTACK(S(error)); pushSTACK(S(warn)); pushSTACK(S(closeL)); pushSTACK(NIL); pushSTACK(Symbol_value(S(reopen_open_file))); pushSTACK(S(error)); funcall(S(warn),9); Symbol_value(S(reopen_open_file)) = S(error); truename = popSTACK(); bad_stream = popSTACK(); /* restore */ goto check_file_reopen_error; } #undef error_format_string } } /* UP: create a file-stream open_file(filename,direction,if_exists,if_not_exists) > STACK_3: original filename (may be logical) > STACK_2: :BUFFERED argument > STACK_1: :EXTERNAL-FORMAT argument > STACK_0: :ELEMENT-TYPE argument > filename: filename, a pathname > direction: direction_t (see lispbibl.d) > if_exists: :IF-EXISTS argument if_exists_t (see lispbibl.d) > if_not_exists: :IF-DOES-NOT-EXIST argument (see lispbibl.d) < result: Stream or NIL < STACK: cleaned up can trigger GC */ local maygc object open_file (object filename, direction_t direction, if_exists_t if_exists, if_does_not_exist_t if_not_exists) { pushSTACK(NIL); /* reserve space on STACK for namestring ... */ var gcv_object_t *namestring_ = &STACK_0; /* ... and remember it */ pushSTACK(STACK_(3+1)); /* save filename */ /* Directory must exist: */ pushSTACK(filename); var struct file_status fs; file_status_init(&fs,&STACK_0); /* tolerant only if :PROBE and if_not_exists = UNBOUND or NIL */ true_namestring(&fs,true, ((direction == DIRECTION_PROBE) && (if_not_exists == IF_DOES_NOT_EXIST_UNBOUND)) || (if_not_exists == IF_DOES_NOT_EXIST_NIL)); if (eq(fs.fs_namestring,nullobj)) /* path to the file does not exist, and :IF-DOES-NOT-EXIST = unbound or NIL */ goto result_NIL; *namestring_ = fs.fs_namestring; /* stack layout: Namestring, Pathname, Truename check filename and get the handle: */ if (!nullpSv(reopen_open_file)) { check_file_reopen(*namestring_,direction); fs.fs_namestring = *namestring_; } var object handle; {var bool append_flag = false; var bool wronly_flag = false; switch (direction) { case DIRECTION_PROBE: if (!file_exists(&fs)) { /* file does not exist */ /* :IF-DOES-NOT-EXIST decides: */ if (if_not_exists==IF_DOES_NOT_EXIST_ERROR) goto error_notfound; if (if_not_exists==IF_DOES_NOT_EXIST_UNBOUND || if_not_exists==IF_DOES_NOT_EXIST_NIL) goto result_NIL; /* :CREATE -> create the file using open and close: */ with_sstring_0(*namestring_,O(pathname_encoding),namestring_asciz, { create_new_file(namestring_asciz); }); } { handle = NIL; } /* Handle := NIL */ break; case DIRECTION_INPUT: case DIRECTION_INPUT_IMMUTABLE: { /* == :INPUT */ var Handle handl; var bool result; with_sstring_0(*namestring_,O(pathname_encoding),namestring_asciz, { result = open_input_file(&fs,namestring_asciz, if_not_exists==IF_DOES_NOT_EXIST_CREATE, &handl); }); if (!result) { /* :IF-DOES-NOT-EXIST decides: */ if (if_not_exists==IF_DOES_NOT_EXIST_NIL) goto result_NIL; else /* UNBOUND or :ERROR -> Error */ goto error_notfound; } handle = allocate_handle(handl); } break; case DIRECTION_OUTPUT: wronly_flag = true; /*FALLTHROUGH*/ case DIRECTION_IO: /* default for if_not_exists depends on if_exists: */ if (if_not_exists==IF_DOES_NOT_EXIST_UNBOUND) { if (if_exists!=IF_EXISTS_APPEND && if_exists!=IF_EXISTS_OVERWRITE) /* (if_exists if_not_exists unchanged, otherwise :CREATE is the default */ if_not_exists = IF_DOES_NOT_EXIST_CREATE; } /* default for if_exists is :SUPERSEDE (= :NEW-VERSION) : */ if (if_exists==IF_EXISTS_UNBOUND) if_exists = IF_EXISTS_SUPERSEDE; if (file_exists(&fs)) { /* file exists => :IF-EXISTS decides: */ switch (if_exists) { case IF_EXISTS_ERROR: goto error_exists; case IF_EXISTS_NIL: goto result_NIL; case IF_EXISTS_RENAME: case IF_EXISTS_RENAME_AND_DELETE: create_backup_file_obj(*namestring_, if_exists==IF_EXISTS_RENAME_AND_DELETE); break; case IF_EXISTS_APPEND: append_flag = true; /* position at the end */ default: ; /* :OVERWRITE -> use the existing file :NEW-VERSION, :SUPERSEDE -> truncate the file at 0 length */ } } else { /* file does not exist => :IF-DOES-NOT-EXIST decides: */ if (if_not_exists==IF_DOES_NOT_EXIST_UNBOUND || if_not_exists==IF_DOES_NOT_EXIST_ERROR) goto error_notfound; if (if_not_exists==IF_DOES_NOT_EXIST_NIL) goto result_NIL; /* :CREATE */ } /* open file: if-exists: if if_exists use truename: */ filename = TheStream(filename)->strm_file_truename; pushSTACK(filename); } else { filename = coerce_xpathname(filename); /* turn into a pathname */ pushSTACK(filename); /* Convert from logical to physical pathname: */ if (logpathnamep(filename)) filename = coerce_pathname(filename); filename = merge_defaults(filename); } /* Stack layout: filename-arg, direction, element-type, if-exists, if-does-not-exist, external-format, buffered, origpathname. filename is now a pathname. */ var direction_t direction = check_direction(STACK_(5+1)); var if_exists_t if_exists = check_if_exists(STACK_(3+1)); var if_does_not_exist_t if_not_exists=check_if_does_not_exist(STACK_(2+1)); /* :element-type is checked later. :external-format is checked later. :buffered is checked later. open file: */ STACK_4 = STACK_5; STACK_5 = STACK_2; STACK_6 = STACK_1; STACK_7 = STACK_0; skipSTACK(4); VALUES1(open_file(filename,direction,if_exists,if_not_exists)); } /* UP: Returns a list of all matching pathnames. directory_search(pathname,dir_search_param) > pathname: pathname with device /= :WILD > dir_search_param: :if-does-not-exist, :circle flag, :full flag < result: if name=NIL and type=NIL: list of all matching directories, else (name=NIL -> name=:WILD): list of all matching files. as absolute pathname without wildcards at a time, resp. for files and Full-Flag /=NIL as list (Pathname Write-Date Length) with Pathname without :WILD/:WILD-INFERIORS-components, Write-Date = Date of file creation (ss mm hh dd mm yy), as Decoded-Time suitable for ENCODE-UNIVERSAL-TIME, Length = Length of the file (in Bytes). Method: Breadth-first-search (=> only one search operation runs at a time) can trigger GC */ typedef enum { DIR_IF_NONE_DISCARD, DIR_IF_NONE_ERROR, DIR_IF_NONE_KEEP, DIR_IF_NONE_IGNORE } dir_search_if_none_t; typedef struct { dir_search_if_none_t if_none; bool full_p; bool circle_p; } dir_search_param_t; local maygc object directory_search (object pathname, dir_search_param_t *dsp); /* UP: extends a pathname by the file-information. > STACK_1: absolute pathname > STACK_0: absolute pathname, links resolved > timepoint: decoded mtime > entry_size: file size < replace STACK_0 with :FULL info: (Pathname Truename Write-Date Length [Comment]) can trigger GC */ local maygc void pack_full_info (decoded_time_t *timepoint, off_t *entry_size) { var object newlist; /* Pathname already in STACK_1, as 1st list element Truename already in STACK_0, as 2nd list element */ pushSTACK(timepoint->seconds); pushSTACK(timepoint->minutes); pushSTACK(timepoint->hours); pushSTACK(timepoint->day); pushSTACK(timepoint->month); pushSTACK(timepoint->year); newlist = listof(6); /* build 6-element list */ pushSTACK(newlist); /* as 3rd list element */ pushSTACK(off_to_I(*entry_size)); /* length as 4th list element */ newlist = listof(4); /* build 4-element list */ pushSTACK(Car(newlist)); /* pathname again in the STACK */ pushSTACK(newlist); /* list in the STACK */ } #ifdef WIN32_NATIVE /* Set of macros for directory search. */ #define READDIR_wildnametype_suffix O(wild_string) /* "*" */ #define READDIR_var_declarations \ var WIN32_FIND_DATA filedata; \ var HANDLE search_handle; #define READDIR_end_declarations #define READDIR_findfirst(pathstring,error_statement,done_statement) \ if ((search_handle = FindFirstFile(pathstring,&filedata)) \ == INVALID_HANDLE_VALUE) { \ if (!WIN32_ERROR_NOT_FOUND) { error_statement } \ else { done_statement } \ } #define READDIR_findnext(error_statement,done_statement) \ if (!FindNextFile(search_handle,&filedata)) { \ if (!(GetLastError()==ERROR_NO_MORE_FILES) \ || !FindClose(search_handle)) \ { error_statement } \ else { done_statement } \ } #define READDIR_entry_name() (&filedata.cFileName[0]) #define READDIR_entry_ISDIR() (filedata.dwFileAttributes & FILE_ATTRIBUTE_DIRECTORY) #define READDIR_entry_timedate(timepointp) \ convert_time(FIND_DATA_FWD(filedata),timepointp) #define READDIR_entry_size() FIND_DATA_FSIZE(filedata) /* UP: get mtime and size from filesystem > pathname: absolute pathname, links resolved < timepoint: decoded time < entry_size: file size can trigger GC */ local maygc void get_time_size (gcv_object_t *pathname, decoded_time_t *timepoint, off_t *entry_size) { READDIR_var_declarations; with_sstring_0(whole_namestring(*pathname),O(pathname_encoding), resolved_asciz,{ var bool notfound = false; /* strip trailing slash, see http://msdn2.microsoft.com/en-us/library/aa364418.aspx */ if (resolved_asciz[resolved_asciz_bytelen - 1] == '\\') resolved_asciz[resolved_asciz_bytelen - 1] = 0; begin_blocking_system_call(); READDIR_findfirst(resolved_asciz, notfound = true; , notfound = true; ); end_blocking_system_call(); if (notfound) /* just to be paranoid */ OS_file_error(*pathname); begin_blocking_system_call(); FindClose(search_handle); end_blocking_system_call(); READDIR_entry_timedate(timepoint); *entry_size = READDIR_entry_size(); }); READDIR_end_declarations; } local maygc void with_stat_info_computed (struct file_status *fs) { decoded_time_t timepoint; off_t entry_size; get_time_size(fs->fs_pathname,&timepoint,&entry_size); pack_full_info(&timepoint,&entry_size); } #endif #ifdef UNIX /* Just like stat(), except that directories or files which would lead to problems are silently hidden. */ local maygc inline int stat_for_search (char* pathstring, struct stat * statbuf) { var int result; GC_SAFE_SYSTEM_CALL(result=, stat(pathstring,statbuf)); #ifdef UNIX_CYGWIN32 if ((result < 0) && (errno == EACCES)) { errno = ENOENT; } #endif return result; } #endif #ifdef PATHNAME_NOEXT /* UP: Extends the directory of a pathname by one component. > pathname: a pathname > subdir: new Subdir-component, a Simple-String < result: new pathname with directory lengthened by subdir can trigger GC */ local maygc object pathname_add_subdir (object pathname, object subdir) { pushSTACK(pathname); pushSTACK(subdir); /* copy pathname and lengthen its directory according to (append x (list y)) = (nreverse (cons y (reverse x))) : */ pathname = copy_pathname(STACK_1); STACK_1 = pathname; pushSTACK(reverse(ThePathname(pathname)->pathname_directory)); var object new_cons = allocate_cons(); Cdr(new_cons) = popSTACK(); Car(new_cons) = popSTACK(); new_cons = nreverse(new_cons); pathname = popSTACK(); ThePathname(pathname)->pathname_directory = new_cons; return pathname; } #ifdef UNIX /* UP: extends a pathname by the file-information. > STACK_1: absolute pathname > STACK_0: absolute pathname, links resolved > *filestatus: its stat-info < STACK_0: list (Pathname Truename Write-Date Length [Comment]) in :FULL-Format */ local maygc void with_stat_info (struct stat *filestatus) { var decoded_time_t timepoint; /* Write-Date in decoded form */ convert_time(&(filestatus->st_mtime),&timepoint); pack_full_info(&timepoint,&(filestatus->st_size)); } local maygc void with_stat_info_computed (struct file_status *fs) { if (!fs->fs_stat_validp) { if (stat_obj(whole_namestring(*(fs->fs_pathname)),&(fs->fs_stat)) < 0) OS_file_error(*(fs->fs_pathname)); fs->fs_stat_validp = true; } with_stat_info(&(fs->fs_stat)); } #endif /* push object in front of a list can trigger GC */ local inline maygc void push (gcv_object_t *head, gcv_object_t *tail) { var object new_cons = allocate_cons(); Car(new_cons) = *head; Cdr(new_cons) = *tail; *tail = new_cons; } #define PUSH_ON_STACK(h,t) push(&STACK_(h),&STACK_(t)) /* Search for a subdirectory with a given name. directory_search_1subdir(subdir,namestring); > STACK_0 = pathname > STACK_(3+1) = new-pathname-list > subdirtail: the tail of the directory list, Car(subdirtail) is the new directory component to add to the pathname, if it exists > namestring: the namestring (for the OS) < STACK_0: replaced < STACK_(3+1): augmented can trigger GC */ local maygc void copy_pathname_and_add_subdir (object subdir) { /* copy pathname(STACK_0) and lengthen its directory by subdir: */ STACK_0 = pathname_add_subdir(STACK_0,subdir); /* push this new pathname in front of new-pathname-list: */ PUSH_ON_STACK(0,3+1); } /* Check whether a directory exists and call copy_pathname_and_add_subdir() on it; if the directory does not exist or is a file, do nothing */ local maygc void directory_search_1subdir (gcv_object_t *subdirtail, object namestring) { with_sstring_0(namestring,O(pathname_encoding),namestring_asciz, { char resolved[MAXPATHLEN]; if (classify_namestring(namestring_asciz,resolved,NULL,NULL) == FILE_KIND_DIR) /* namestring is a directory */ copy_pathname_and_add_subdir(Car(*subdirtail)); }); } /* Returns a truename dependent hash code for a directory. directory_search_hashcode() STACK_0 = dir_namestring STACK_1 = pathname < result: a hash code, or nullobj if the directory does not exist can trigger GC */ #if defined(UNIX) /* return (cons drive inode) */ local maygc object directory_search_hashcode (void) { pushSTACK(STACK_0); /* Directory-Name */ pushSTACK(O(dot_string)); /* and "." */ var object namestring = string_concat(2); /* concatenate */ var struct stat status; if (stat_obj(namestring,&status) != 0) return nullobj; /* entry exists (oh miracle...) */ pushSTACK(UL_to_I(status.st_dev)); /* Device-Number and */ #if SIZEOF_INO_T > 4 pushSTACK(UQ_to_I(status.st_ino)); /* Inode-Number */ #else pushSTACK(UL_to_I(status.st_ino)); /* Inode-Number */ #endif var object new_cons = allocate_cons(); /* cons them together */ Cdr(new_cons) = popSTACK(); Car(new_cons) = popSTACK(); return new_cons; } #elif defined(WIN32_NATIVE) /* win32 - there is stat but no inodes using directory truenames as hashcodes */ local maygc object directory_search_hashcode (void) { return STACK_0; } #else #error directory_search_hashcode is not defined #endif #ifdef UNIX /* Tests whether a directory entry actually exists and is accessible. (It could be a link pointing to nowhere, or a directory without permissions) directory_search_direntry_ok(namestring,&statbuf) STACK_2 = pathname < result: true and statbuf filled, or false. */ local maygc bool directory_search_direntry_ok (object namestring, struct stat * statbuf) { var bool exists = true; with_sstring_0(namestring,O(pathname_encoding),namestring_asciz, { if (stat_for_search(namestring_asciz,statbuf)) { exists = false; } }); return exists; } #endif /* the version of files returned by DIRECTORY Since all pathnames returned by DIRECTORY must be truenames, this must be :NEWEST [but then they will not be printable readably!] */ #define DEFAULT_VERSION S(Knewest) /* Convert a directory entry to a string direntry_to_string (char* string, int len) > string : asciz > len : its length (if it is -1, asciz_length is used) < value1 : lisp string or NIL if string is "." or ".." OR if the conversion failed and the CONTINUE restart was selected can trigger GC */ #if !defined(MULTITHREAD) /* should be per thread - moved to clisp_thread_t in MT */ local bool running_handle_directory_encoding_error = false; #endif local void handle_directory_encoding_error /* cf. enter_frame_at_STACK */ (void *sp, gcv_object_t* frame, object label, object condition) { /* avoid nested handle_directory_encoding_error calls */ if (running_handle_directory_encoding_error) return; else running_handle_directory_encoding_error = true; value1 = condition; unwind_upto(frame); } local maygc object direntry_to_string (char* string, int len) { if (asciz_equal(string,".") || asciz_equal(string,"..")) return NIL; if (len == -1) len = asciz_length(string); #ifdef ENABLE_UNICODE var gcv_object_t *stack_save = STACK; var object encoding = O(pathname_encoding); restart_direntry_to_string: running_handle_directory_encoding_error = false; /* build UNWIND-PROTECT-frame: */ var sp_jmp_buf returner; /* return point */ make_HANDLER_entry_frame(O(handler_for_charset_type_error), handle_directory_encoding_error,returner, goto signal_encoding_error; ); value1 = n_char_to_string(string,len,encoding); unwind_HANDLER_frame(); direntry_to_string_done: running_handle_directory_encoding_error = false; if (stack_save != STACK) abort(); return value1; signal_encoding_error: /* value1 = condition */ unwind_HANDLER_frame(); pushSTACK(S(pathname_encoding)); /* PLACE */ pushSTACK(value1); /* condition - for CHECK-VALUE */ /* set condition $DATUM slot to string (as a byte vector) */ pushSTACK(value1/*condition*/); pushSTACK(S(datum)); pushSTACK(allocate_bit_vector(Atype_8Bit,len)); /* slot DATUM */ var int pos; /* fill DATUM: string as a byte vector */ for (pos = 0; pos < len; pos++) TheSbvector(STACK_0)->data[pos] = string[pos]; funcall(L(set_slot_value),3); funcall(S(check_value),2); if (nullp(value1)) goto direntry_to_string_done; /* CONTINUE restart */ encoding = check_encoding(value1,&O(pathname_encoding),false); if (eq(T,value2)) O(pathname_encoding) = encoding; /* STORE-VALUE restart */ goto restart_direntry_to_string; #else return n_char_to_string(string,len,O(pathname_encoding)); #endif } #if defined(MULTITHREAD) && defined(HAVE_READDIR_R) /* UP: Calculate the required buffer size (in bytes) for directory entries read from the given directory handle. Return -1 if this this cannot be done. http://womble.decadentplace.org.uk/readdir_r-advisory.html > dirp: open directory handle < returns the size in bytes needed for struct dirent buffer This code does not trust values of NAME_MAX that are less than 255, since some systems (including at least HP-UX) incorrectly define it to be a smaller value. If you use autoconf, include fpathconf and dirfd in your AC_CHECK_FUNCS list. Otherwise use some other method to detect and use them where available. */ local size_t dirent_buf_size(DIR * dirp) { var long name_max; var size_t name_end; #if defined(HAVE_FPATHCONF) && defined(HAVE_DIRFD) && defined(_PC_NAME_MAX) name_max = fpathconf(dirfd(dirp), _PC_NAME_MAX); if (name_max == -1) #if defined(NAME_MAX) name_max = (NAME_MAX > 255) ? NAME_MAX : 255; #else return (size_t)(-1); #endif #else #if defined(NAME_MAX) name_max = (NAME_MAX > 255) ? NAME_MAX : 255; #else #error "buffer size for readdir_r cannot be determined" #endif #endif name_end = (size_t)offsetof(struct dirent, d_name) + name_max + 1; return (name_end > sizeof(struct dirent) ? name_end : sizeof(struct dirent)); } #endif /* Scans an entire directory. directory_search_scandir(recursively,next_task); stack layout: result-list, pathname, name&type, subdir-list, pathname-list, new-pathname-list, ht, pathname-list-rest, pathnames-to-insert, pathname, dir_namestring. */ typedef enum { TASK_DONE = 0, /* nothing, finished */ TASK_FILE = 1, /* look for a file of given name/type */ TASK_DIR = -1, /* look for a subdirectory of given name */ TASK_ALL_FILES = 2, /* look for all files matching the given name/type */ TASK_ALL_DIRS = -2 /* look for all subdirectories matching the given name */ } task_t; #define TASK_FILE_P(task) (task>0) #define TASK_DIR_P(task) (task<0) local maygc void directory_search_scandir (bool recursively, task_t next_task, dir_search_param_t *dsp) { #if defined(UNIX) { var object namestring; pushSTACK(STACK_0); /* directory-name */ pushSTACK(O(dot_string)); /* and "." */ namestring = string_concat(2); /* concatenate */ /* scan directory: */ var DIR* dirp; set_break_sem_4(); with_sstring_0(namestring,O(pathname_encoding),namestring_asciz, { /* open directory */ GC_SAFE_SYSTEM_CALL(dirp=, opendir(namestring_asciz)); }); if (dirp == (DIR*)NULL) { switch (dsp->if_none) { case DIR_IF_NONE_IGNORE: return; case DIR_IF_NONE_DISCARD: /* ansi cl: unaccessible directory => error */ case DIR_IF_NONE_ERROR: OS_file_error(STACK_1); case DIR_IF_NONE_KEEP: return; default: NOTREACHED; } } while (1) { #if defined(MULTITHREAD) && defined(HAVE_READDIR_R) /* we should use readdir_r(). it is thread safe (but optional in POSIX) TODO: some config scripts for it ? Is there thread safe, portable implementation in GNULIB? */ var DYNAMIC_ARRAY(dp_buf,char,dirent_buf_size(dirp)); var struct dirent * dp; var int rdr; /* readdir_r() return*/ /* fetch next directory-entry */ GC_SAFE_SYSTEM_CALL(rdr=, readdir_r(dirp,(struct dirent *)dp_buf,&dp)); if (dp == (struct dirent *)NULL) { FREE_DYNAMIC_ARRAY(dp_buf); } errno = rdr; #else var struct dirent * dp; errno = 0; /* fetch next directory-entry */ GC_SAFE_SYSTEM_CALL(dp=, readdir(dirp)); #endif if (dp == (struct dirent *)NULL) { /* error or directory finished */ if (!(errno==0)) { OS_file_error(STACK_1); } break; } /* convert directory-entry into string: */ var object direntry; { var uintL direntry_len; #if defined(UNIX_CYGWIN32) /* Neither d_reclen nor d_namlen present in DIR structure. */ direntry_len = asciz_length(dp->d_name); #elif !defined(HAVE_STRUCT_DIRENT_D_NAMLEN) || defined(__USE_GNU) { /* On UNIX_LINUX direntry_len := dp->d_reclen was sufficient, but in general direntry_len := min(dp->d_reclen,asciz_length(dp->d_name)) is necessary. The GNU libc is buggy: it does "#define d_namlen d_reclen", just as the Linux libc-5.0.9. */ var const uintB* ptr = (const uintB*)(&dp->d_name[0]); var uintL count = dp->d_reclen; direntry_len = 0; while (count-- && *ptr++) direntry_len++; } #else direntry_len = dp->d_namlen; #endif direntry = direntry_to_string(dp->d_name,direntry_len); } #ifdef MULTITHREAD FREE_DYNAMIC_ARRAY(dp_buf); #endif if (!nullp(direntry)) { pushSTACK(direntry); /* stack layout: ..., pathname, dir_namestring, direntry. determine, if it is a directory or a file: */ pushSTACK(STACK_1); /* Directory-Namestring */ SUBDIR_PUSHSTACK(direntry); /* direntry */ var object namestring = string_concat(2); /* concatenate */ /* get information: */ var struct stat status; #if 1 /* just an optimization */ if (!recursively) { /* Try to avoid calling directory_search_direntry_ok(), since it is an expensive operation (it calls stat()). */ if (TASK_DIR_P(next_task)) { /* match (car subdir-list) with direntry: */ if (wildcard_match(Car(STACK_(1+4+3)),STACK_0)) if (directory_search_direntry_ok(namestring,&status)) { if (S_ISDIR(status.st_mode)) goto push_matching_subdir; } else switch (dsp->if_none) { case DIR_IF_NONE_IGNORE: break; case DIR_IF_NONE_DISCARD: case DIR_IF_NONE_ERROR: OS_file_error(namestring); case DIR_IF_NONE_KEEP: goto push_matching_file; default: NOTREACHED; } } else if (TASK_FILE_P(next_task)) { /* match name&type with direntry: */ if (wildcard_match(STACK_(2+4+3),STACK_0)) if (directory_search_direntry_ok(namestring,&status)) { if (!S_ISDIR(status.st_mode)) goto push_matching_file; } else switch (dsp->if_none) { case DIR_IF_NONE_IGNORE: case DIR_IF_NONE_DISCARD: break; case DIR_IF_NONE_ERROR: OS_file_error(namestring); case DIR_IF_NONE_KEEP: goto push_matching_file; default: NOTREACHED; } } goto done_direntry; } #endif if (directory_search_direntry_ok(namestring,&status)) { /* entry exists and is not unwanted. */ if (S_ISDIR(status.st_mode)) { /* is it a directory? */ /* entry is a directory. */ if (recursively) { /* all recursive subdirectories wanted? */ /* yes -> turn into a pathname and push to pathnames-to-insert (it is later inserted in front of pathname-list-rest): */ pushSTACK(pathname_add_subdir(STACK_2/*pathname*/,STACK_0/*direntry*/)); /* push this new pathname in front of pathname-to-insert: */ PUSH_ON_STACK(0,1+3); skipSTACK(1); } if (TASK_DIR_P(next_task)) { /* match (car subdir-list) with direntry: */ if (wildcard_match(Car(STACK_(1+4+3)),STACK_0)) { push_matching_subdir: /* subdirectory matches -> turn into a pathname and push onto new-pathname-list: */ pushSTACK(pathname_add_subdir(STACK_2/*pathname*/,STACK_0/*direntry*/)); /* push this new pathname in front of new-pathname-list: */ PUSH_ON_STACK(0,4+3); skipSTACK(1); } } } else if (TASK_FILE_P(next_task)) { /* entry is a (halfway) normal File. */ /* match name&type with direntry: */ if (wildcard_match(STACK_(2+4+3),STACK_0)) { push_matching_file: /* File matches -> turn into a pathname and push onto result-list: */ pushSTACK(STACK_0); /* direntry */ split_name_type(1); /* split into Name and Type */ { var object pathname = copy_pathname(STACK_(2+2)); ThePathname(pathname)->pathname_type = popSTACK(); /* insert type */ ThePathname(pathname)->pathname_name = popSTACK(); /* insert name */ ThePathname(pathname)->pathname_version = DEFAULT_VERSION; pushSTACK(pathname); pushSTACK(pathname); } /* form truename (resolve symbolic links): */ var struct file_status fs; file_status_init(&fs,&STACK_0); assure_dir_exists(&fs,true,true); if (!eq(nullobj,fs.fs_namestring) && file_exists(&fs)) { /* if file (still...) exists */ if (dsp->full_p) /* :FULL wanted? */ with_stat_info(&(fs.fs_stat)); /* yes -> extend STACK_0 */ /* and push STACK_0 in front of result-list: */ PUSH_ON_STACK(0,4+4+3+2); } else if (dsp->if_none == DIR_IF_NONE_KEEP) PUSH_ON_STACK(1/* unresolved pathname */,4+4+3+2); skipSTACK(2); } } } else switch (dsp->if_none) { case DIR_IF_NONE_IGNORE: case DIR_IF_NONE_DISCARD: break; case DIR_IF_NONE_ERROR: OS_file_error(namestring); case DIR_IF_NONE_KEEP: goto push_matching_file; default: NOTREACHED; } done_direntry: skipSTACK(1); /* forget direntry */ } } begin_blocking_system_call(); if (CLOSEDIR(dirp)) { end_blocking_system_call(); OS_file_error(STACK_1); } end_blocking_system_call(); clr_break_sem_4(); } #elif defined(WIN32_NATIVE) { SUBDIR_PUSHSTACK(STACK_0); /* Directory-Name */ pushSTACK(READDIR_wildnametype_suffix); /* and concatenate */ var object namestring = string_concat(2); /* "*.*" resp. "*" */ with_sstring_0(namestring,O(pathname_encoding),namestring_asciz, { /* scan directory, according to DOS- resp. Win32-convention: */ READDIR_var_declarations; /* start of search, search for folders and normal files: */ begin_blocking_system_call(); do { /* readdir in resolved directory. directory was resolved earlier */ READDIR_findfirst(namestring_asciz,{ end_blocking_system_call(); if (dsp->if_none == DIR_IF_NONE_IGNORE) { FREE_DYNAMIC_ARRAY(namestring_asciz); return; } else OS_file_error(STACK_1); }, break; ); while (1) { end_blocking_system_call(); /* convert directory-entry into string: */ var object direntry = direntry_to_string(READDIR_entry_name(),-1); if (!nullp(direntry)) { var shell_shortcut_target_t rresolved = shell_shortcut_notresolved; pushSTACK(direntry); /* stack layout: ..., pathname, dir_namestring, direntry. */ pushSTACK(NIL); /* will become found file full pathname, */ /* changed with symbolic name for resolved (maybe nonfound) links */ pushSTACK(NIL); /* true pathname of it or whatever result to return */ pushSTACK(direntry); /* here will come filename to wildcard match */ split_name_type(1); /* stack layout: ..., pathname, dir_namestring, direntry, NIL, NIL, direntry-name, direntry-type. */ /* make full name of found file - dir + direntry TODO: optimize to not do it when it not needed */ if (READDIR_entry_ISDIR()) { /* pathname and direntry: */ STACK_3 = pathname_add_subdir(STACK_6,STACK_4); } else { STACK_(3) = copy_pathname(STACK_(6)); ThePathname(STACK_(3))->pathname_type = STACK_0; ThePathname(STACK_(3))->pathname_name = STACK_1; ThePathname(STACK_(3))->pathname_version = DEFAULT_VERSION; } /* try to resolve .lnk files */ if (!READDIR_entry_ISDIR() && !nullp(STACK_0) && string_equal(STACK_0,O(lnk_string))) { var char resolved[MAX_PATH]; var char * full_resolved = resolved; with_sstring_0(whole_namestring(STACK_(3)),O(pathname_encoding),linkfile_asciz, { rresolved = resolve_shell_shortcut_more(linkfile_asciz,resolved); if (rresolved != shell_shortcut_notresolved) { var char resolved_f[MAX_PATH]; if (FullName(resolved,resolved_f)) full_resolved = resolved_f; /* hack direntry-pathname to make it a symbolic name symbolic link names are direntry-pathnames w/o ".lnk" so split the name again hack it in-place since lnk filename is not need anymore */ pushSTACK(STACK_1); split_name_type(1); ThePathname(STACK_(3+2))->pathname_name = STACK_1; ThePathname(STACK_(3+2))->pathname_type = STACK_0; ThePathname(STACK_(3+2))->pathname_version = DEFAULT_VERSION; skipSTACK(2); /* what to use as a result */ if (rresolved == shell_shortcut_notexists) STACK_(2) = STACK_(3); /* use symbolic names as a result when target is not found */ else { STACK_(2) = coerce_pathname(direntry_to_string(full_resolved,-1)); ThePathname(STACK_(2))->pathname_version = DEFAULT_VERSION; } } }); } if (rresolved == shell_shortcut_notresolved) { /* truename is the pathname itself */ STACK_(2) = STACK_(3); /* nametomatch is direntry */ STACK_(1) = STACK_(4); } skipSTACK(1); /* drop direntry-type */ /* stack layout: ..., pathname, dir_namestring, direntry, direntry-pathname, true-pathname, direntry-name-to-check. */ if (rresolved == shell_shortcut_notexists && dsp->if_none == DIR_IF_NONE_ERROR) error_file_not_exists(); if (rresolved != shell_shortcut_notexists || (dsp->if_none != DIR_IF_NONE_DISCARD && dsp->if_none != DIR_IF_NONE_IGNORE)) { if (READDIR_entry_ISDIR() || rresolved == shell_shortcut_directory) { /* nonfound shortcuts are treated as shortcuts to files */ if (recursively) /* all recursive subdirectories wanted? */ /* yes -> push truename onto pathnames-to-insert (it is inserted in front of pathname-list-rest later): */ PUSH_ON_STACK(1,0+6); if (TASK_DIR_P(next_task)) { /* match (car subdir-list) with direntry: */ if (wildcard_match(Car(STACK_(1+4+6)),STACK_0)) /* Subdirectory matches -> push truename onto new-pathname-list: */ PUSH_ON_STACK(1,3+6); } } else if (TASK_FILE_P(next_task)) { /* entry is a (halfway) normal file. */ if (wildcard_match(STACK_(2+4+6),STACK_0)) { /* stack layout: ..., pathname, dir_namestring, direntry, direntry-maybhacked-pathname, true-pathname, direntry-name-to-check. test Full-Flag and poss. get more information: */ if (dsp->full_p /* :FULL wanted? */ && rresolved != shell_shortcut_notexists) { /* treat nonexisting as :FULL NIL */ var decoded_time_t timepoint; var off_t entry_size; pushSTACK(STACK_(2)); /* newpathname as 1st list element */ pushSTACK(STACK_(1+1)); /* resolved pathname as 2nd list element */ /* get file attributes into timepoint & entry_size */ if (rresolved == shell_shortcut_file) { /* need another readdir here */ get_time_size(&STACK_0,&timepoint,&entry_size); } else { /* easy way */ READDIR_entry_timedate(&timepoint); entry_size = READDIR_entry_size(); } pack_full_info(&timepoint,&entry_size); PUSH_ON_STACK(0,4+4+6+2); skipSTACK(2); /* drop newname & full info list */ } else PUSH_ON_STACK(1,4+4+6); } } } skipSTACK(4); /* forget all up to dir_namestring */ } /* next file: */ begin_blocking_system_call(); READDIR_findnext({ end_blocking_system_call(); OS_file_error(STACK_1); }, break; ); } } while (false); end_blocking_system_call(); READDIR_end_declarations; }); } #else #error directory_search_scandir is not defined #endif } local maygc object directory_search (object pathname, dir_search_param_t *dsp) { pathname = use_default_dir(pathname); /* insert default-directory */ /* pathname is now new and an absolute pathname. */ pushSTACK(NIL); /* result-list := NIL */ pushSTACK(pathname); /* if name=NIL and type/=NIL: set name := "*". */ if (nullp(ThePathname(pathname)->pathname_name) && !nullp(ThePathname(pathname)->pathname_type)) ThePathname(pathname)->pathname_name = S(Kwild); /* for matching: collect name and type into a string: */ if (nullp(ThePathname(pathname)->pathname_name)) { pushSTACK(NIL); /* name=NIL -> also type=NIL -> do not search files */ } else { var object nametype_string = file_namestring(pathname); pathname = STACK_0; pushSTACK(nametype_string); } pushSTACK(ThePathname(pathname)->pathname_directory); /* subdir-list */ /* copy pathname and thereby discard name and type and shorten directory to (:ABSOLUTE) resp. (:ABSOLUTE :ROOT) : */ pathname = copy_pathname(pathname); ThePathname(pathname)->pathname_name = NIL; ThePathname(pathname)->pathname_type = NIL; ThePathname(pathname)->pathname_version = NIL; ThePathname(pathname)->pathname_directory = O(directory_absolute); pushSTACK(pathname); { /* pack into one-element list: */ var object new_cons = allocate_cons(); Car(new_cons) = STACK_0; STACK_0 = new_cons; } var bool recursively = /* Flag, if the next operation has to be applied */ false; /* to all subdirectories. */ while (1) { /* stack layout: result-list, pathname, name&type, subdir-list, pathname-list. result-list = list of finished pathnames/lists, reversed. name&type = NIL or Normal-Simple-String, against which the filenames have to be matched. pathname-list = list of directories to be processed. the pathnames from pathname-list contain the directory only so deep, that afterwards work continues with (cdr subdir-list) . process next subdir-level: */ STACK_1 = Cdr(STACK_1); /* shorten subdir-list */ var task_t next_task; /* what has to be done with the Dirs from pathname-list: */ if (matomp(STACK_1)) { /* subdir-list finished? */ var object nametype = STACK_2; if (nullp(nametype)) /* name=NIL and type=NIL -> do not search files */ next_task = TASK_DONE; #if !defined(WIN32_NATIVE) else if (!wild_p(nametype,false) && (dsp->if_none != DIR_IF_NONE_IGNORE)) /* === !(wild_p(name) || ((!nullp(type)) && wild_p(type))) */ next_task = TASK_FILE; /* search file */ #endif else next_task = TASK_ALL_FILES; /* search files with wildcards */ } else { var object next_subdir = Car(STACK_1); if (eq(next_subdir,S(Kwild_inferiors))) { /* '...' ? */ /* will be treated at the next run */ recursively = true; goto passed_subdir; } if (!wild_p(next_subdir,false)) next_task = TASK_DIR; /* search subdir */ else next_task = TASK_ALL_DIRS; /* search subdirs with wildcards */ } /* traverse pathname-list and construct new list: */ { pushSTACK(NIL); } if (dsp->circle_p) { /* query :CIRCLE-Flag */ /* maintain hash-table of all scanned directories so far (as cons (dev . ino)) : (MAKE-HASH-TABLE :KEY-TYPE '(CONS INTEGER INTEGER) :VALUE-TYPE '(EQL T) :TEST 'EQUAL) */ pushSTACK(S(Ktest)); pushSTACK(S(equal)); funcall(L(make_hash_table),2); pushSTACK(value1); } else pushSTACK(NIL); pushSTACK(STACK_(0+2)); while (1) { /* stack layout: ..., new-pathname-list, ht, pathname-list-rest. */ var object pathname_list_rest = STACK_0; if (atomp(pathname_list_rest)) break; STACK_0 = Cdr(pathname_list_rest); /* shorten list */ pushSTACK(NIL); /* pathnames-to-insert := NIL */ /* stack layout: ..., new-pathname-list, ht, pathname-list-rest, pathnames-to-insert. */ { var object pathname = Car(pathname_list_rest); /* next directory */ pushSTACK(pathname); /* into the stack */ /* try to shorten the task a little: */ if (!recursively) { switch (next_task) { case TASK_DONE: { /* return this directory pathname */ ASSERT(namenullp(STACK_0)); pushSTACK(copy_pathname(STACK_0)); var struct file_status fs; file_status_init(&fs,&STACK_0); assure_dir_exists(&fs,false,false); /* first resolve links */ if (dsp->full_p) /* assure_dir_exists does not fill fs_stat */ with_stat_info_computed(&fs); /* and push STACK_0 in front of result-list: */ PUSH_ON_STACK(0,4+4+2); skipSTACK(2); } goto next_pathname; #if !defined(WIN32_NATIVE) case TASK_FILE: { /* look in this pathname for a file */ ThePathname(pathname)->pathname_name = /* insert name (/=NIL) */ ThePathname(STACK_(3+4+1))->pathname_name; ThePathname(pathname)->pathname_type = /* insert type */ ThePathname(STACK_(3+4+1))->pathname_type; ThePathname(pathname)->pathname_version = DEFAULT_VERSION; /* original may be :WILD! */ pushSTACK(pathname); var struct file_status fs; file_status_init(&fs,&STACK_0); assure_dir_exists(&fs,true,true); /* resolve links, stat file */ if (file_exists(&fs)) { /* if file exists */ /* extend result-list: */ if (dsp->full_p) /* :FULL wanted? */ with_stat_info(&(fs.fs_stat)); /* yes -> extend STACK_0 */ /* and push STACK_0 in front of result-list: */ PUSH_ON_STACK(0,4+4+2); } skipSTACK(2); } goto next_pathname; #endif case TASK_DIR: { /* search for a subdirectory in this pathname */ var struct file_status fs; file_status_init(&fs,&STACK_0); assure_dir_exists(&fs,true,false); /* resolve links, directory-namestring */ pushSTACK(fs.fs_namestring); /* directory-namestring */ { var object subdir = Car(STACK_(1+4+1+1)); /*(car subdir-list)*/ SUBDIR_PUSHSTACK(subdir); } #if defined(WIN32_NATIVE) pushSTACK(O(backslash_string)); fs.fs_namestring = string_concat(3); /* concatenate */ #else fs.fs_namestring = string_concat(2); #endif /* get information: */ directory_search_1subdir(&(STACK_(1+4+1)),fs.fs_namestring); skipSTACK(1); } goto next_pathname; default: ; /* do nothing */ } } /* in order to finish the task, all entries in this directory have to be scanned: */ { var struct file_status fs; pushSTACK(STACK_0);/*truename*/ file_status_init(&fs,&STACK_0); assure_dir_exists(&fs,false,false); /* resolve links, form directory-name */ pushSTACK(fs.fs_namestring); /* save */ /* stack layout: ..., pathname, truename, dir_namestring. */ if (dsp->circle_p) { /* query :CIRCLE flag */ /* search pathname in the hash-table: */ var object hashcode = directory_search_hashcode(); if (eq(hashcode,nullobj)) { /* entry does not exist, however (this can happen to us only for symbolic links) -> will be skipped */ skipSTACK(3); goto next_pathname; } /* and locate in the hash-table and store: */ if (!nullp(shifthash(STACK_(2+3),hashcode,T,true))) { /* was already inside -> will be skipped */ skipSTACK(3); goto next_pathname; } } if (next_task==TASK_DONE) { /* push pathname STACK_1 in front of result-list: */ if (dsp->full_p) { /* assure_dir_exists does not fill fs_stat */ pushSTACK(STACK_2); pushSTACK(STACK_(1+1)); with_stat_info_computed(&fs); STACK_(1+2) = STACK_0; skipSTACK(2); } PUSH_ON_STACK(1,4+4+3); if (dsp->full_p) STACK_1 = Car(STACK_1); } } STACK_2 = STACK_1; STACK_1 = STACK_0; skipSTACK(1); /* drop pathname */ directory_search_scandir(recursively,next_task,dsp); skipSTACK(2); /* forget pathname and dir_namestring */ next_pathname: ; } /* stack layout: ..., new-pathname-list, ht, pathname-list-rest, pathnames-to-insert. Before advancing with pathname-list-rest : pathname-list-rest := (nreconc pathnames-to-insert pathname-list-rest): */ var object pathnames_to_insert = popSTACK(); STACK_0 = nreconc(pathnames_to_insert,STACK_0); } skipSTACK(2); /* forget empty pathname-list-rest and hash-table */ { /* reverse new-pathname-list, replaces the emptied pathname-list: */ var object new_pathname_list = popSTACK(); STACK_0 = nreverse(new_pathname_list); /* new pathname-list */ } /* we are finished with this subdir-stage. */ if (matomp(STACK_1)) break; /* (atom subdir-list) -> finished. */ recursively = false; /* the next (preliminarily) non-recursive */ passed_subdir: ; } /* stack layout: result-list pathname name&type subdir-list pathname-list subdir-list became =NIL , also pathname-list = NIL (because at the last loop iteration next_task is always DONE, FILE or ALL_FILES, so nothing was pushed on new-pathname-list). */ skipSTACK(4); return popSTACK(); /* result-list as result */ } #endif /* PATHNAME_NOEXT */ /* (DIRECTORY pathname [:circle] [:full] [:if-does-not-exist]), CLTL p. 427 */ LISPFUN(directory,seclass_rd_sig,1,0,norest,key,3, ( kw(if_does_not_exist),kw(circle),kw(full) )) { /* stack layout: pathname, if-does-not-exist, circle, full. */ var dir_search_param_t dsp; if (!boundp(STACK_2) || eq(STACK_2,S(Kdiscard))) /* :IF-DOES-NOT-EXIST defaults to :DISCARD */ dsp.if_none = DIR_IF_NONE_DISCARD; else if (eq(STACK_2,S(Kerror))) dsp.if_none = DIR_IF_NONE_ERROR; else if (eq(STACK_2,S(Kkeep))) dsp.if_none = DIR_IF_NONE_KEEP; else if (eq(STACK_2,S(Kignore))) dsp.if_none = DIR_IF_NONE_IGNORE; else error_illegal_arg(STACK_2,O(type_directory_not_exist), S(Kif_does_not_exist)); dsp.circle_p = !missingp(STACK_1); /* :CIRCLE argument defaults to NIL */ dsp.full_p = !missingp(STACK_0); /* :FULL argument defaults to NIL */ skipSTACK(3); /* check pathname-argument: */ var object pathname = merge_defaults(coerce_pathname(STACK_0)); /* let's go: */ #ifdef PATHNAME_WIN32 if (eq(ThePathname(pathname)->pathname_device,S(Kwild))) { /* Device = :WILD ? ==> scan all devices */ STACK_0 = pathname; pushSTACK(NIL); /* pathname-list := NIL */ { /* stack layout: pathname, pathname-list. */ var char drive; for (drive='A'; drive<='Z'; drive++) /* traverse all drives */ if (good_drive(drive)) { var object newpathname = copy_pathname(STACK_1); ThePathname(newpathname)->pathname_device = /* take over the device = one-element drive string */ n_char_to_string(&drive,1,O(pathname_encoding)); /* search within a drive: */ var object newpathnames = directory_search(newpathname,&dsp); /* and attach pathname-list in front of STACK_0: */ STACK_0 = nreconc(newpathnames,STACK_0); } } VALUES1(nreverse(STACK_0)); /* reverse pathname-list again */ skipSTACK(2); } else /* only one device to scan */ #endif { VALUES1(directory_search(pathname,&dsp)); /* form matching pathnames */ skipSTACK(1); } } /* UP: make sure that the supposed directory namestring ends with a slash returns a new string with a slash appended or the same stirng can trigger GC */ local maygc object ensure_last_slash (object dir_string) { ASSERT(stringp(dir_string)); var uintL len, offset; var object str = unpack_string_ro(dir_string,&len,&offset); var chart ch = schar(str,len+offset-1); if (!pslashp(ch) && !lslashp(ch)) { var char sl = (looks_logical_p(dir_string) ? ';' : slash); with_sstring_0(str,O(pathname_encoding),asciz, { dir_string = asciz_add_char(asciz,len,sl,O(pathname_encoding)); }); } return dir_string; } /* (CD [pathname]) sets the current drive and the current directory. */ LISPFUN(cd,seclass_default,0,1,norest,nokey,0,NIL) { var object pathname = popSTACK(); if (!boundp(pathname)) { pathname = O(empty_string); } /* "" */ else if (stringp(pathname)) /* make sure it ends with a slash */ pathname = ensure_last_slash(pathname); pathname = copy_pathname(coerce_pathname(pathname)); /* --> pathname */ ThePathname(pathname)->pathname_name = NIL; ThePathname(pathname)->pathname_type = NIL; pushSTACK(pathname); var struct file_status fs; file_status_init(&fs,&STACK_0); true_namestring(&fs,false,false); /* the directory must exist */ change_default(); /* set default drive and default directory */ VALUES1(popSTACK()); /* new pathname as the value */ } #undef lslashp #undef pslashp /* UP: checks a pathname, if both name and type are =NIL , and if the directory "almost" exists. shorter_directory(pathname,resolve_links) > pathname : Pathname-Argument > resolve_links : flag, if links have to be resolved (usually yes) < -(STACK) : absolute pathname */ #ifdef WIN32_NATIVE /* < result: Directory-Namestring (for the OS, without '\' at the end, Normal-Simple-String) */ #endif #ifdef UNIX /* < result: Directory-Namestring (for the OS, without '/' at the end, Normal-Simple-String) */ #endif /* decrements STACK by 1. can trigger GC */ local maygc object shorter_directory (object pathname, bool resolve_links) { pathname = merge_defaults(coerce_pathname(pathname)); /* --> pathname */ check_no_wildcards(pathname); /* with wildcards -> error */ pathname = use_default_dir(pathname); /* insert default-directory */ check_notdir(pathname); /* ensure that Name=NIL and Type=NIL */ pushSTACK(pathname); /* save new pathname */ /* shorten the directory: */ var object subdirs = ThePathname(pathname)->pathname_directory; if (nullp(Cdr(subdirs))) { /* root-directory ? */ /* STACK_0 = pathname, FILE-ERROR slot PATHNAME */ pushSTACK(STACK_0); error(file_error,GETTEXT("root directory not allowed here: ~S")); } subdirs = reverse(subdirs); /* copy list and reverse */ pushSTACK(subdirs); /* save cons with last subdir as CAR */ subdirs = Cdr(subdirs); /* all subdirs except for the last */ subdirs = nreverse(subdirs); /* bring into right order again */ pathname = STACK_1; ThePathname(pathname)->pathname_directory = subdirs; /* and store in the pathname */ /* this directory must exist: */ pushSTACK(pathname); /* stack layout: pathname, subdircons, pathname. */ var struct file_status fs; file_status_init(&fs,&STACK_0); assure_dir_exists(&fs,!resolve_links,false); /* build subdir-string for the operating system: */ STACK_0 = fs.fs_namestring; /* directory-namestring so far as 1st String */ var uintC stringcount = /* the strings in the last subdir */ subdir_namestring_parts(STACK_1,false); /* and no '\' at the end (for the OS) and no '/' at the end (for the OS) */ var object dirstring = string_concat(1+stringcount); /* concatenate */ skipSTACK(1); return dirstring; } LISPFUNN(make_directory,1) { /* (MAKE-DIRECTORY pathname) makes a new subdirectory pathname. */ var object pathstring = shorter_directory(STACK_0,true); with_sstring_0(pathstring,O(pathname_encoding),pathstring_asciz, { make_directory(pathstring_asciz); }); skipSTACK(2); VALUES1(T); } LISPFUNN(delete_directory,1) { /* (DELETE-DIRECTORY pathname) removes the subdirectory pathname. */ var object pathstring = shorter_directory(STACK_0,true); with_sstring_0(pathstring,O(pathname_encoding),pathstring_asciz, { delete_directory(pathstring_asciz); }); skipSTACK(2); VALUES1(T); } LISPFUNN(rename_directory,2) { /* (RENAME-DIRECTORY dirname newname) renames an existing directory. */ var object newdir = shorter_directory(STACK_0,true); STACK_0 = newdir; var object olddir = shorter_directory(STACK_2,true); STACK_2 = olddir; rename_existing_path(STACK_2,STACK_1); skipSTACK(4); VALUES1(T); } /* (defun ensure-directories-exist (pathspec &key verbose) (let* ((dir (pathname-directory pathspec)) (path (make-pathname :host (pathname-host pathspec) :device (pathname-device pathspec) :directory dir))) (when (wild-pathname-p path) (error (make-condition (quote file-error) :pathname pathspec))) (if (directory path) (values pathspec nil) (loop for i from 1 upto (length dir) for newpath = (make-pathname :host (pathname-host pathspec) :device (pathname-device pathspec) :directory (subseq dir 0 i)) unless (directory newpath) do (let ((namestring (namestring newpath))) (when verbose (format *standard-output* "~&Creating directory: ~A~%" namestring)) (ignore-errors (ext:make-directory namestring)) (unless (directory newpath) (error (make-condition (quote file-error) :pathname pathspec)))))) finally (return (values pathspec t)))) */ LISPFUN(ensure_directories_exist,seclass_default,1,0,norest,key,1, (kw(verbose))) { var object pathname = coerce_pathname(STACK_1); pathname = merge_defaults(pathname); /* copy and discard name, type */ ThePathname(pathname)->pathname_name = NIL; ThePathname(pathname)->pathname_type = NIL; check_no_wildcards(pathname); /* with wildcards -> error */ pathname = use_default_dir(pathname); /* insert default-directory */ pushSTACK(pathname); /* save new pathname */ /* stack layout: pathspec, verbose, pathname. */ if (directory_exists(pathname)) { skipSTACK(2); value2 = NIL; /* pathspec, NIL as values */ } else { var object subdirs = copy_list(ThePathname(STACK_0)->pathname_directory); pushSTACK(subdirs); pushSTACK(Cdr(subdirs)); Cdr(subdirs) = NIL; ThePathname(STACK_2)->pathname_directory = subdirs; /* stack layout: pathspec, verbose, pathname, (car (last subdirs)), remaining_subdirs. */ while (mconsp(STACK_0)) { subdirs = STACK_0; Cdr(STACK_1) = subdirs; STACK_1 = subdirs; STACK_0 = Cdr(subdirs); Cdr(subdirs) = NIL; if (!directory_exists(STACK_2)) { if (!missingp(STACK_3)) { /* Verbose? */ funcall(L(fresh_line),0); /* (FRESH-LINE [*standard-output*]) */ pushSTACK(CLSTEXT("Creating directory: ")); funcall(L(write_string),1); /* (WRITE-STRING "..." [*standard-output*]) */ pushSTACK(STACK_2); funcall(L(princ),1); /* (PRINC pathname [*standard-output*]) */ funcall(L(terpri),0); /* (TERPRI [*standard-output*]) */ } /* side remark: Do not need to resolve links here, because here we proceed step by step starting at the root, anyway. */ var object pathstring = shorter_directory(STACK_2,false); with_sstring_0(pathstring,O(pathname_encoding),pathstring_asciz, { make_directory(pathstring_asciz); }); skipSTACK(1); } } skipSTACK(4); value2 = T; /* pathspec, T as values */ } value1 = popSTACK(); mv_count=2; } #ifdef UNIX /* Returns the struct passwd entry for the current user. The return value points to static data, or is NULL upon failure. */ local struct passwd * unix_user_pwd (void) { var const char* username; var struct passwd * userpasswd = NULL; /* The manpage for GETLOGIN(3V) recommends first getpwnam(getlogin()), then getpwuid(getuid()). */ begin_system_call(); /* 1. attempt: getpwnam(getenv("USER")) */ username = getenv("USER"); if (username != NULL) { errno = 0; userpasswd = getpwnam(username); if (userpasswd != NULL) goto ok; if (errno != 0) { OS_error(); } } /* 2. attempt: getpwnam(getlogin()) */ username = getlogin(); if (username != NULL) { errno = 0; userpasswd = getpwnam(username); if (userpasswd != NULL) goto ok; if (errno != 0) { OS_error(); } } /* 3. attempt: getpwuid(getuid()) */ errno = 0; userpasswd = getpwuid(getuid()); if (userpasswd != NULL) goto ok; if (errno != 0) { OS_error(); } /* Everything fails, userpasswd == NULL. */ ok: end_system_call(); return userpasswd; } #endif /* UP: Initializes the pathname-system. init_pathnames(); can trigger GC */ global maygc void init_pathnames (void) { #ifdef PATHNAME_WIN32 { /* initialize default-drive: */ var char drive = default_drive(); O(default_drive) = (drive == 0 ? NIL /* network */ : n_char_to_string(&drive,1,O(pathname_encoding))); /* local device */ } #endif /* initialize *DEFAULT-PATHNAME-DEFAULTS* : */ recalc_defaults_pathname(); #if defined(UNIX) /* we retrieve the home-directory and the usable shell from the environment. It contains (almost) always at least the following variables: LOGNAME = Username at the first login ("true" identity of the user) USER = current username HOME = current home-directory, fetched from /etc/passwd SHELL = current standard-shell, fetched from /etc/passwd PATH = search path for program call TERM = terminal emulation we retrieve HOME (for "~" - translation) and SHELL (for EXECUTE). For "~username" we must scan the /etc/passwd - file. */ { /* search in the environment for variable HOME: */ begin_system_call(); var const char* homedir = getenv("HOME"); end_system_call(); if (homedir != NULL) { /* found? */ O(user_homedir) = asciz_dir_to_pathname(homedir,O(misc_encoding)); /* yes -> enter */ } else { /* no -> get home-directory from the passwort-file: */ var struct passwd * userpasswd = unix_user_pwd(); if (userpasswd != NULL) { /* no -> enter homedir as pathname */ O(user_homedir) = asciz_dir_to_pathname(userpasswd->pw_dir,O(misc_encoding)); } else { /* no -> take current directory: */ O(user_homedir) = default_directory(); } } } #elif defined(WIN32) /* WinNT defines HOMEDRIVE and HOMEPATH. Win95 (which is actually not a multiuser OS) lets the user set HOME himself. In any case, we give preference to HOME, because the user can change this. */ { var const char * home; begin_system_call(); home = getenv("HOME"); if (home != NULL) { end_system_call(); O(user_homedir) = asciz_dir_to_pathname(home,O(misc_encoding)); } else { var const char * homedrive = getenv("HOMEDRIVE"); var const char * homepath = getenv("HOMEPATH"); end_system_call(); if (homedrive!=NULL && homepath!=NULL) { var char* homeall = (char*)alloca(asciz_length(homedrive)+asciz_length(homepath)+1); var char* ptr = homeall; while ((*ptr = *homedrive) != '\0') { homedrive++; ptr++; } while ((*ptr = *homepath) != '\0') { homepath++; ptr++; } *ptr = '\0'; O(user_homedir) = asciz_dir_to_pathname(homeall,O(misc_encoding)); } else { O(user_homedir) = use_default_dir(asciz_dir_to_pathname(".",Symbol_value(S(ascii)))); } } } #else /* !UNIX & !WIN32 */ #error O(user_homedir) not initialized #endif #if defined(UNIX) /* the command-shell O(command_shell) remains unchanged, otherwise we get too many portability problems. */ { /* search the environment for variable SHELL: */ begin_system_call(); var const char* shell = getenv("SHELL"); end_system_call(); if (shell != NULL) { /* found? ==> enter */ O(user_shell) = asciz_to_string(shell,O(misc_encoding)); } /* else O(user_shell) remains on the default value "/bin/csh". */ } #elif defined(WIN32_NATIVE) { /* search in the environment for variable COMSPEC: */ begin_system_call(); var const char* shell = getenv("COMSPEC"); if (!(shell==NULL)) { end_system_call(); O(command_shell) = asciz_to_string(shell,O(misc_encoding)); /* enter */ } else { var OSVERSIONINFO v; v.dwOSVersionInfoSize = sizeof(OSVERSIONINFO); if (!GetVersionEx(&v)) { OS_error(); } if (v.dwPlatformId == VER_PLATFORM_WIN32_NT) { /* Windows NT */ shell = "cmd.exe"; } else { /* Windows 95 or else */ shell = "command.com"; } end_system_call(); O(command_shell) = ascii_to_string(shell); /* enter */ } } #else #error O(command_shell) not initialized #endif } LISPFUNNS(file_write_date,1) { /* (FILE-WRITE-DATE file), CLTL p. 424 */ #if defined(UNIX) var time_t file_datetime; /* buffer for date/time of a file */ #elif defined(WIN32_NATIVE) var WIN32_FIND_DATA filedata; #else #error FILE-WRITE-DATE is not defined #endif var gcv_object_t *pathname = &STACK_0; /* pathname-argument */ if (builtin_stream_p(*pathname)) { /* stream -> treat extra: */ /* must be file-stream: */ *pathname = as_file_stream(*pathname); /* streamtype file-stream */ if ((TheStream(*pathname)->strmflags & strmflags_open_B) && (!nullp(TheStream(*pathname)->strm_buffered_channel))) { /* open file-stream work with the handle directly: */ #if defined(UNIX) var struct stat status; begin_blocking_system_call(); if (!( fstat(TheHandle(TheStream(*pathname)->strm_buffered_channel),&status) ==0)) { end_blocking_system_call(); OS_filestream_error(*pathname); } end_blocking_system_call(); file_datetime = status.st_mtime; #elif defined(WIN32_NATIVE) var BY_HANDLE_FILE_INFORMATION fileinfo; var BOOL result; begin_blocking_system_call(); result = GetFileInformationByHandle(TheHandle(TheStream(*pathname)->strm_buffered_channel),&fileinfo); end_blocking_system_call(); if (result) { filedata.ftCreationTime = fileinfo.ftCreationTime; filedata.ftLastAccessTime = fileinfo.ftLastAccessTime; filedata.ftLastWriteTime = fileinfo.ftLastWriteTime; } else { /* If that failed, try the full pathname. */ test_file_stream_named(*pathname); *pathname = TheStream(*pathname)->strm_file_truename; goto is_pathname; } #else #error FILE-WRITE-DATE is not defined #endif } else { /* closed file-stream -> use truename as pathname */ test_file_stream_named(*pathname); *pathname = TheStream(*pathname)->strm_file_truename; goto is_pathname; } } else { /* turn into a pathname */ *pathname = merge_defaults(coerce_pathname(*pathname)); is_pathname: { /* pathname is now really a pathname */ var struct file_status fs; file_status_init(&fs,&STACK_0); true_namestring(&fs,true,false); #if defined(UNIX) if (!file_exists(&fs)) { error_file_not_exists(); } /* file must exist */ file_datetime = fs.fs_stat.st_mtime; #elif defined(WIN32_NATIVE) /* Only a directory search gives us the times. */ with_sstring_0(fs.fs_namestring,O(pathname_encoding),namestring_asciz, { find_first_file(namestring_asciz,&filedata); }); #else #error FILE-WRITE-DATE is not defined #endif } } skipSTACK(1); /* pathname */ /* date/time no is in the buffer file_datetime. convert into Universal-Time-Format: */ #if defined(UNIX) VALUES1(convert_time_to_universal(&file_datetime)); #elif defined(WIN32_NATIVE) VALUES1(convert_time_to_universal(FIND_DATA_FWD(filedata))); #else #error FILE-WRITE-DATE is not defined #endif } LISPFUNNS(file_author,1) { /* (FILE-AUTHOR file), CLTL p. 424 */ var object pathname = popSTACK(); /* pathname-argument */ if (builtin_stream_p(pathname)) { /* stream -> treat extra: */ /* must be file-stream: */ pathname = as_file_stream(pathname); /* streamtype file-stream */ if (TheStream(pathname)->strmflags & strmflags_open_B) { /* open file-stream -> OK */ } else { /* closed file-stream -> use truename as pathname */ test_file_stream_named(pathname); pathname = TheStream(pathname)->strm_file_truename; goto is_pathname; } } else { pathname = merge_defaults(coerce_pathname(pathname)); /* --> pathname */ is_pathname: { /* pathname is now really a pathname */ pushSTACK(pathname); var struct file_status fs; file_status_init(&fs,&STACK_0); true_namestring(&fs,true,false); if (!file_exists(&fs)) { error_file_not_exists(); } /* file must exist */ skipSTACK(1); } } /* file exists -> NIL as value */ VALUES1(NIL); } #ifdef UNIX /* UP: unblocks blocked signals - called in child (fork-ed) process (probably relevant only in MT builds but does not harm single thread) */ local inline void unblock_all_signals() { var sigset_t sigblock_mask; sigprocmask(SIG_BLOCK, NULL, &sigblock_mask); /* get */ sigprocmask(SIG_UNBLOCK, &sigblock_mask, NULL); /* unblock */ } LISPFUN(execute,seclass_default,1,0,rest,nokey,0,NIL) { /* (EXECUTE file arg1 arg2 ...) calls a file with the given arguments. */ var gcv_object_t* args_pointer = rest_args_pointer STACKop 1; { var gcv_object_t* argptr = args_pointer; /* Pointer to the arguments */ { /* check file: */ var gcv_object_t* file_ = &NEXT(argptr); /* we do not do follow symlinks here because some programs dispatch on argv[0], which could be a symbolic link. E.g., in Maemo Fremantle OS used in Nokia N900 phone, /bin/sh is a symlink to busybox, so RUN-PROGRAM which calls SHELL which calls EXECUTE fails because EXECUTE calls "busybox -c" instead of "/bin/sh -c". */ /* convert thet file to string, existence is checked by execv(2): */ *file_ = physical_namestring(*file_); *file_ = string_to_asciz(*file_,O(misc_encoding)); } { /* check the other arguments: */ var uintC count; dotimesC(count,argcount, { var gcv_object_t* arg_ = &NEXT(argptr); pushSTACK(*arg_); funcall(L(string),1); /* convert next argument into a string */ *arg_ = string_to_asciz(value1,O(misc_encoding)); /* and convert ASCIZ-string */ }); } } { /* build up argv-Array in stack and copy strings in the stack: */ var uintL argvdata_length = 0; { var gcv_object_t* argptr = args_pointer; var uintC count; dotimespC(count,argcount+1, { var object arg = NEXT(argptr); /* next argument, ASCIZ-string */ argvdata_length += Sbvector_length(arg); }); } var DYNAMIC_ARRAY(argv,char*,1+(uintL)argcount+1); var DYNAMIC_ARRAY(argvdata,char,argvdata_length); { var gcv_object_t* argptr = args_pointer; var char** argvptr = &argv[0]; var char* argvdataptr = &argvdata[0]; var uintC count; dotimespC(count,argcount+1, { var object arg = NEXT(argptr); /* next argument, ASCIZ-string */ var char* ptr = TheAsciz(arg); var uintL len = Sbvector_length(arg); *argvptr++ = argvdataptr; /* fill into argv */ dotimespL(len,len, { *argvdataptr++ = *ptr++; } ); /* and copy */ }); *argvptr = NULL; /* and conclude with nullpointer */ } { /* start a new process: */ var int child; begin_system_call(); begin_want_sigcld(); if ((child = vfork()) ==0) { /* this program part is executed by the child-process: */ close_all_fd(); unblock_all_signals(); execv(argv[0],argv); /* call program */ _exit(-1); /* if this fails, end the child-process */ } /* this program part is executed by the caller: */ if (child==-1) { /* something failed, either in vfork or in execv. either way errno was set. */ end_want_sigcld(); end_system_call(); OS_error(); } /* wait, until the child-process is finished: */ var int status; GC_SAFE_CALL(status=, wait2(child)); /* cf. WAIT(2V) and #include : WIFSTOPPED(status) == ((status & 0xFF) == 0177) WEXITSTATUS(status) == ((status & 0xFF00) >> 8) */ end_want_sigcld(); end_system_call(); /* finished. */ set_args_end_pointer(args_pointer); /* clean up STACK */ if (WIFEXITED(status)) { /* process ended normally (without signal, without core-dump) */ int exitcode = WEXITSTATUS(status); VALUES1(exitcode ? fixnum(exitcode) : NIL); /* exit-status as value */ } else /* minus signal as value */ VALUES1(WIFSIGNALED(status) ? negfixnum(- WTERMSIG(status)) : negfixnum(- WSTOPSIG(status))); } FREE_DYNAMIC_ARRAY(argvdata); FREE_DYNAMIC_ARRAY(argv); } } #endif /* Duplicate an open file handle. handle_dup(oldfd) Similar to dup(oldfd), with error checking. To be called only inside begin/end_system_call(). */ modexp Handle handle_dup (Handle old_handle) { Handle new_handle; #if defined(UNIX) new_handle = dup(old_handle); if (new_handle < 0) { OS_error(); } #elif defined(WIN32_NATIVE) new_handle = INVALID_HANDLE_VALUE; if (!DuplicateHandle(GetCurrentProcess(),old_handle, GetCurrentProcess(),&new_handle, 0, true, DUPLICATE_SAME_ACCESS)) OS_error(); #else #error handle_dup is not defined #endif return new_handle; } /* Duplicate an open file handle. handle_dup2(oldfd,newfd) Similar to dup2(oldfd,newfd), with error checking. The result may or may not be equal to newfd. To be called only inside begin/end_system_call(). */ modexp Handle handle_dup2 (Handle old_handle, Handle new_handle) { #if defined(UNIX) new_handle = dup2(old_handle,new_handle); if (new_handle < 0) { OS_error(); } #elif defined(WIN32_NATIVE) if (!DuplicateHandle(GetCurrentProcess(),old_handle, GetCurrentProcess(),&new_handle, 0, true, DUPLICATE_SAME_ACCESS)) OS_error(); #else #error handle_dup2 is not defined #endif return new_handle; } /* (SHELL) calls a shell. (SHELL command) calls a shell and lets it execute a command. */ #if defined(WIN32_NATIVE) /* (SYSTEM::SHELL-NAME) returns the name of the command shell. */ LISPFUNN(shell_name,0) { VALUES1(O(command_shell)); } LISPFUN(shell,seclass_default,0,1,norest,nokey,0,NIL) { var object command = popSTACK(); if (missingp(command)) command = O(command_shell); command = check_string(command); var HANDLE prochandle; with_string_0(command,O(misc_encoding),command_asciz, { /* Start new process. */ var HANDLE stdinput; var HANDLE stdoutput; var HANDLE stderror; var PROCESS_INFORMATION pinfo; begin_system_call(); stdinput = GetStdHandle(STD_INPUT_HANDLE); if (stdinput == INVALID_HANDLE_VALUE) { OS_error(); } stdoutput = GetStdHandle(STD_OUTPUT_HANDLE); if (stdoutput == INVALID_HANDLE_VALUE) { OS_error(); } stderror = GetStdHandle(STD_ERROR_HANDLE); if (stderror == INVALID_HANDLE_VALUE) { OS_error(); } if (!MyCreateProcess(command_asciz,stdinput,stdoutput,stderror,&pinfo)) { OS_error(); } if (pinfo.hThread && !CloseHandle(pinfo.hThread)) { OS_error(); } prochandle = pinfo.hProcess; }); /* Wait until it terminates, get its exit status code. */ var DWORD exitcode; GC_SAFE_CALL(exitcode=,WaitForSingleObject(prochandle,INFINITE)); switch (exitcode) { case WAIT_FAILED: OS_error(); case WAIT_OBJECT_0: break; default: NOTREACHED; } if (!GetExitCodeProcess(prochandle,&exitcode)) { OS_error(); } if (!CloseHandle(prochandle)) { OS_error(); } end_system_call(); /* use return value: =0 (OK) -> NIL, >0 (not OK) -> exitcode */ VALUES1(exitcode == 0 ? NIL : fixnum(exitcode)); } #elif defined(UNIX) LISPFUN(shell,seclass_default,0,1,norest,nokey,0,NIL) { var object command = popSTACK(); if (missingp(command)) { /* execute (EXECUTE shell) : */ pushSTACK(O(user_shell)); /* Shell-Name */ funcall(L(execute),1); } else { /* call (EXECUTE shell "-c" command): */ pushSTACK(O(command_shell)); /* shell name */ pushSTACK(O(command_shell_option)); /* shell option "-c" */ pushSTACK(command); funcall(L(execute),3); } } #else #error EXT:SHELL is not defined #endif /* stringlist_to_ascizlist (stringlist, encoding) convert a stringlist to list of asciz strings and places it on the stack. returns total length of all asciz strings including zeros and listlength (if the pointer is not NULL) adds one element to STACK can trigger GC */ #if !defined(ENABLE_UNICODE) #define stringlist_to_ascizlist(s,e,l) stringlist_to_ascizlist_(s,l) local maygc int stringlist_to_ascizlist_ (object stringlist,uintL *listlength) #else local maygc int stringlist_to_ascizlist (object stringlist, gcv_object_t *encoding_, uintL *listlength) #endif { var int length = 0; var int listlen = 0; pushSTACK(NIL)/*result head*/; pushSTACK(NIL)/*result tail*/; pushSTACK(stringlist); while (consp(STACK_0/*stringlist tail*/)) { var object tmp = allocate_cons(); if (nullp(STACK_2/*result*/)) STACK_1 = STACK_2 = tmp; else { Cdr(STACK_1/*result tail*/) = tmp; STACK_1 = tmp; } tmp = check_string(Car(STACK_0)); tmp = string_to_asciz(tmp,*encoding_); length += Sbvector_length(tmp) + 1; Car(STACK_1) = tmp; STACK_0 = Cdr(STACK_0); listlen++; } if (listlength) *listlength = listlen; skipSTACK(2); /* drop stringlist and result tail */ return length; } #ifdef WIN32_NATIVE /* (SHELL-EXECUTE verb filename parameters defaultdir) ShellExecute wrapper See ShellExecute description at http://msdn.microsoft.com/library/default.asp?url=/library/en-us/shellcc/ platform/Shell/reference/functions/shellexecute.asp verb: usually nil (for default), "edit", "explore", "open", "print", "properties" filename: filename or url to open parameters: list of arguments defaultdir: default directory for application (can be nil) returns: nil, but can signal an OS error*/ LISPFUN(shell_execute,seclass_default,0,4,norest,nokey,0,NIL) { var object verb_arg = STACK_3; var object filename_arg = check_string(STACK_2); var object parameters_arg = STACK_1; var object defaultdir_arg = STACK_0; var int verb_len = 0; if (nullp(verb_arg)) pushSTACK(S(nil)); else { pushSTACK(string_to_asciz(check_string(verb_arg),O(misc_encoding))); verb_len = Sbvector_length(STACK_0); } var int filename_len = 0; pushSTACK(string_to_asciz(check_string(filename_arg), O(misc_encoding))); filename_len = Sbvector_length(STACK_0); var int parameters_len = stringlist_to_ascizlist(parameters_arg,&O(misc_encoding),NULL); /* list of asciz strings is in the STACK */ var DYNAMIC_ARRAY(parameters,char,parameters_len*2); var int parameter_pos = 0; while (!nullp(STACK_0)) { if (parameter_pos > 0) parameters[parameter_pos++] = ' '; parameter_pos += shell_quote(parameters+parameter_pos,TheAsciz(Car(STACK_0))); ASSERT(parameter_pos < parameters_len*2); STACK_0 = Cdr(STACK_0); } skipSTACK(1); var int defaultdir_len = 0; if (nullp(defaultdir_arg)) pushSTACK(S(nil)); else { pushSTACK(string_to_asciz(check_string(defaultdir_arg), O(misc_encoding))); defaultdir_len = Sbvector_length(STACK_0); } /* STACK: verb/nil, filename, defaultdir/nil */ var DYNAMIC_ARRAY(verb,char,1+verb_len); var DYNAMIC_ARRAY(filename,char,1+filename_len); var DYNAMIC_ARRAY(defaultdir,char,1+defaultdir_len); var char *sp, *dp; if (!nullp(STACK_2)) for (sp=TheAsciz(STACK_2),dp=verb;(*dp = *sp);sp++,dp++); for (sp=TheAsciz(STACK_1),dp=filename;(*dp = *sp);sp++,dp++); if (!nullp(STACK_0)) for (sp=TheAsciz(STACK_0),dp=defaultdir;(*dp = *sp);sp++,dp++); begin_blocking_system_call(); var DWORD result = (DWORD) ShellExecute(NULL, nullp(STACK_2)?NULL:verb, filename, parameters_len?parameters:NULL, nullp(STACK_0)?NULL:defaultdir, SW_SHOWNORMAL); end_blocking_system_call(); if (result <= 32) OS_error(); FREE_DYNAMIC_ARRAY(defaultdir); FREE_DYNAMIC_ARRAY(filename); FREE_DYNAMIC_ARRAY(verb); FREE_DYNAMIC_ARRAY(parameters); skipSTACK(3+4); VALUES1(S(nil)); } #endif #if defined(UNIX) /* /dev/null handle. */ local Handle nullfile (void) { var Handle result; begin_system_call(); result = open("/dev/null",O_RDWR); end_system_call(); return result; } /* obtaining a pipe handle */ local void mkpipe (Handle * hin, bool dummy1, Handle * hout, bool dummy2) { var int handles[2]; begin_system_call(); if (pipe(handles)) OS_error(); end_system_call(); *hin = (Handle) handles[0]; *hout = (Handle) handles[1]; } #elif defined(WIN32_NATIVE) /* /dev/null on NT/W95. */ local Handle nullfile (void) { var Handle result; begin_system_call(); result = CreateFile("NUL", GENERIC_READ | GENERIC_WRITE, FILE_SHARE_READ | FILE_SHARE_WRITE, NULL, OPEN_EXISTING, 0, NULL); end_system_call(); return result; } /* obtaining pipe handle */ local void mkpipe (Handle * hin, bool dupinp, Handle * hout, bool dupoutp) { begin_system_call(); if (!CreatePipe(hin,hout,NULL,0)) { OS_error(); } if (dupinp) {/* make it inheritable */ var Handle hin1 = handle_dup(*hin); if (!CloseHandle(*hin)) { OS_error(); } *hin = hin1; } if (dupoutp) { var Handle hout1 = handle_dup(*hout); if (!CloseHandle(*hout)) { OS_error(); } *hout = hout1; } end_system_call(); } #else #error nullfile & mkpipe are not defined #endif local maygc bool init_launch_streamarg (gcv_object_t *streamarg, bool child_inputp, Handle stdhandle, Handle * h, Handle * ph, Handle * hnull, bool * wait_p) { var int handletype = 0; *h = INVALID_HANDLE; *ph = INVALID_HANDLE; if (boundp(*streamarg) && eq(*streamarg,S(Kterminal)) || !boundp(*streamarg)) *h = handle_dup(stdhandle); else if (nullp(*streamarg)) { if (*hnull == INVALID_HANDLE) *hnull = nullfile(); *h = handle_dup(*hnull); } else if (eq(*streamarg,S(Kpipe))) { if (child_inputp) /* make an input pipe for child, ph = parent's handle */ mkpipe(h,true,ph,false); else /* make an output pipe for child */ mkpipe(ph,false,h,true); if (*ph == INVALID_HANDLE || *h == INVALID_HANDLE) return false; *wait_p = false; /* TODO: error when wait_p */ } else { /* child i/o direction is the same as lisp user i/o direction */ *h = handle_dup(stream_lend_handle(streamarg,child_inputp,&handletype)); if (handletype != 1) return false; } return (*h != INVALID_HANDLE); } local maygc void make_launch_pipe (gcv_object_t *ret, direction_t direction, Handle hparent_pipe, int childpid, gcv_object_t *enc, gcv_object_t *eltype, gcv_object_t *buffered) { if (hparent_pipe != INVALID_HANDLE) { pushSTACK(*enc); /* encoding */ pushSTACK(*eltype); /* element-type */ pushSTACK(*buffered); /* buffered */ *ret = mk_pipe_from_handle(hparent_pipe,childpid,direction); /* stack has been cleaned by mk_pipe_from_handle */ } } /* on cygwin, includes therefore *_PRIORITY_CLASS macros are already defined */ #if !defined(NORMAL_PRIORITY_CLASS) #define NORMAL_PRIORITY_CLASS 0 #define HIGH_PRIORITY_CLASS -10 #define IDLE_PRIORITY_CLASS 10 #define MY_LOCAL_PRIORITY_CLASSES #endif #if defined(UNIX) #define CloseHandle(h) (close(h)==0) #endif /* paranoidal close */ #define ParaClose(h) if (!CloseHandle(h)) { end_system_call(); OS_error(); } local maygc sintL interpret_launch_priority (object priority_arg) { if (!boundp(priority_arg)) return NORMAL_PRIORITY_CLASS; restart_priority: if (eq(priority_arg,S(Khigh))) return HIGH_PRIORITY_CLASS; else if (eq(priority_arg,S(Klow))) return IDLE_PRIORITY_CLASS; else if (eq(priority_arg,S(Knormal))) return NORMAL_PRIORITY_CLASS; else if (integerp(priority_arg)) return I_to_L(priority_arg); pushSTACK(NIL); /* no PLACE */ pushSTACK(priority_arg); /* TYPE-ERROR slot DATUM */ pushSTACK(O(type_priority)); /* TYPE-ERROR slot EXPECTED-TYPE */ pushSTACK(priority_arg); pushSTACK(S(Kpriority)); pushSTACK(TheSubr(subr_self)->name); check_value(type_error,GETTEXT("~S: Illegal ~S argument ~S")); priority_arg = value1; goto restart_priority; } /* (LAUNCH executable [:arguments] [:wait] [:input] [:output] [:error] [:element-type] [:external-format] [:buffered] [:priority]) Launches a program. :arguments : a list of strings (*MISC-ENCODING* is used) :wait - nullp/not nullp - whether to wait for process to finish (default T) :input, :output, :error - i/o/e streams for process. basically file-streams, pipe streams or terminal-streams. see stream_lend_handle() in stream.d for full list of supported streams. Can be NIL (/dev/null), :pipe (pipe streams are created) or :terminal. :element-type, :external-format, :buffered : parameters for created pipe-stream if one or more of :input, :output, :error is :pipe. FIXME: this is wrong: it does not allow different pipe types for i/o. The correct arguments should be: :input, :output, :error should take list arguments like this: (:buffered t :element-type (unsigned-byte 8)) :PIPE should be removed from constobj.d :priority : :HIGH/:LOW/:NORMAL or fixnum on UNIX - see nice(2) on Windows - see CreateProcess dwCreationFlags parameter. returns: value1: if wait exit code, child PID otherwise value2: NIL or created pipe-output-stream, input stream for child value3: NIL or created pipe-input-stream, output stream for child value4: NIL or created pipe-input-stream, error stream for child */ LISPFUN(launch,seclass_default,1,0,norest,key,9, (kw(element_type),kw(external_format),kw(buffered),kw(arguments), kw(wait),kw(input),kw(output),kw(error),kw(priority))) { STACK_9 = check_string(STACK_9); /* command_arg */ if (!boundp(STACK_5)) STACK_5 = NIL; /* arguments_arg */ else STACK_5 = check_list(STACK_5); var long priority = interpret_launch_priority(STACK_0); var bool wait_p = !nullp(STACK_4); /* default: do wait! */ var Handle hnull = INVALID_HANDLE; var Handle hinput; var Handle hparent_out; /* in case of pipe */ /* STACK_3 == input_stream_arg */ if (!init_launch_streamarg(&STACK_3, true, stdin_handle, &hinput, &hparent_out, &hnull, &wait_p)) OS_error(); var Handle houtput, hparent_in; /* STACK_2 == output_stream_arg */ if (!init_launch_streamarg(&STACK_2, false, stdout_handle, &houtput, &hparent_in, &hnull, &wait_p)) { begin_system_call(); if (hinput != INVALID_HANDLE && hinput != stdin_handle) ParaClose(hinput); if (hparent_out != INVALID_HANDLE) ParaClose(hparent_out); end_system_call(); OS_error(); } var Handle herror, hparent_errin; /* STACK_1 == error_stream_arg */ if (!init_launch_streamarg(&STACK_1, false, stderr_handle, &herror, &hparent_errin, &hnull, &wait_p)) { begin_system_call(); if (hinput != INVALID_HANDLE && hinput != stdin_handle) ParaClose(hinput); if (hparent_out != INVALID_HANDLE) ParaClose(hparent_out); if (houtput != INVALID_HANDLE && houtput != stdout_handle) ParaClose(houtput); if (hparent_in != INVALID_HANDLE) ParaClose(hparent_in); end_system_call(); OS_error(); } if (hnull != INVALID_HANDLE) { begin_system_call(); ParaClose(hnull); end_system_call(); } /* convert command and args to one asciz string list */ pushSTACK(allocate_cons()); Car(STACK_0) = STACK_(9+1); /* command_arg */ Cdr(STACK_0) = STACK_(5+1); /* arguments_arg */ var uintL arglist_count = 0; var uintL argbuf_len = 1 + stringlist_to_ascizlist(STACK_0,&O(misc_encoding),&arglist_count); /* STACK: cmdlist, ascizcmdlist */ STACK_1 = STACK_0; skipSTACK(1); /* STACK: ascizcmdlist */ var int child_id = 0; #if defined(UNIX) var DYNAMIC_ARRAY(argv,char*,1+(uintL)arglist_count+1); var DYNAMIC_ARRAY(argvdata,char,argbuf_len); var object curcons = STACK_0; var char** argvptr = &argv[0]; var char* argvdataptr = &argvdata[0]; while (consp(curcons)) { var uintL len = Sbvector_length(Car(curcons)); var char* ptr = TheAsciz(Car(curcons)); *argvptr++ = argvdataptr; /* fill into argv */ dotimespL(len,len, { *argvdataptr++ = *ptr++; } ); /* and copy */ curcons = Cdr(curcons); }; *argvptr = NULL; /* and conclude with null */ skipSTACK(1); /* STACK: -- */ begin_system_call(); begin_want_sigcld(); child_id = vfork(); if (child_id == 0) {/* What ?! I am the clone ?! */ /* TODO: close ALL unused opened handles since unclosed handles (to previously opened pipes) can prevent childs to end up properly */ #define CHILD_DUP(from,to) \ if (dup2(from,to) < 0) { \ fprintf(stderr,"clisp/child: cannot duplicate %d to %d: %s\n", \ from,to,strerror(errno)); \ _exit(-1); \ } \ if (from>2) \ close(from) CHILD_DUP(hinput,0); CHILD_DUP(houtput,1); CHILD_DUP(herror,2); #undef CHILD_DUP /* close child copies of parent's handles */ if (hparent_out >= 0) close(hparent_out); if (hparent_in >= 0) close(hparent_in); if (hparent_errin >= 0) close(hparent_errin); #ifdef HAVE_NICE errno = 0; nice(priority); if (errno) { fprintf(stderr,"clisp/child: cannot set priority to %ld: %s\n", priority,strerror(errno)); _exit(-1); } #endif close_all_fd(); unblock_all_signals(); execvp(*argv,argv); fprintf(stderr,"clisp/child: execvp failed: %s\n",strerror(errno)); _exit(-1); } else if (child_id < 0) { /* TODO: FIXME: no easy way to be aware of dup2 or exec failures */ end_want_sigcld(); end_system_call(); OS_error(); } var int exit_code = 0; if (wait_p) { var int status; GC_SAFE_CALL(status=, wait2(child_id)); exit_code = WEXITSTATUS(status); } end_want_sigcld(); /* close our copies of child's handles */ if (hinput!=stdin_handle) ParaClose(hinput); if (houtput!=stdout_handle) ParaClose(houtput); if (herror!=stderr_handle) ParaClose(herror); end_system_call(); FREE_DYNAMIC_ARRAY(argv); FREE_DYNAMIC_ARRAY(argvdata); #elif defined(WIN32_NATIVE) var DYNAMIC_ARRAY(command_data,char,argbuf_len*2); /* argbuf_len is multiplied by 2 for quoting sake */ var int command_pos = 0; while (!nullp(STACK_0)) { if (command_pos > 0) command_data[command_pos++] = ' '; command_pos += shell_quote(command_data+command_pos, TheAsciz(Car(STACK_0))); ASSERT(command_pos < argbuf_len*2); STACK_0 = Cdr(STACK_0); } skipSTACK(1); /* STACK: -- */ /* Start new process. */ var HANDLE prochandle; var PROCESS_INFORMATION pinfo; var STARTUPINFO sinfo; sinfo.cb = sizeof(STARTUPINFO); sinfo.lpReserved = NULL; sinfo.lpDesktop = NULL; sinfo.lpTitle = NULL; sinfo.cbReserved2 = 0; sinfo.lpReserved2 = NULL; sinfo.dwFlags = STARTF_USESTDHANDLES; sinfo.hStdInput = hinput; sinfo.hStdOutput = houtput; sinfo.hStdError = herror; begin_system_call(); if (!CreateProcess(NULL, command_data, NULL, NULL, true, (DWORD)priority & 0x1E0, NULL, NULL, &sinfo, &pinfo)) { end_system_call(); OS_error(); } if (pinfo.hThread) /* zero for 16 bit programs in NT */ ParaClose(pinfo.hThread); prochandle = pinfo.hProcess; child_id = pinfo.dwProcessId; FREE_DYNAMIC_ARRAY(command_data); var DWORD exit_code = 0; if (wait_p) { /* Wait until it terminates, get its exit status code. */ var DWORD waitret; GC_SAFE_CALL(waitret=, WaitForSingleObject(prochandle,INFINITE)); switch (waitret) { case WAIT_FAILED: end_system_call(); OS_error(); case WAIT_OBJECT_0: break; default: NOTREACHED; } if (!GetExitCodeProcess(prochandle,(DWORD*)&exit_code)) { end_system_call(); OS_error(); } } /* we can safely close handle of a running process - it doesn't lead to process termination */ ParaClose(prochandle); /* close our copies of child's handles */ if (hinput!=stdin_handle) ParaClose(hinput); if (houtput!=stdout_handle) ParaClose(houtput); if (herror!=stderr_handle) ParaClose(herror); end_system_call(); #else #error LAUNCH is not defined #endif { /* make pipe-streams */ gcv_object_t *buff = &STACK_6; /* :BUFFERED */ gcv_object_t *enc = &STACK_7; /* :ENCODING */ gcv_object_t *eltype = &STACK_8; /* :ELEMENT-TYPE */ /* child's input stream, pipe-output from our side */ make_launch_pipe(&(STACK_3),DIRECTION_OUTPUT,hparent_out, child_id,enc,eltype,buff); /* child's output stream, pipe-input from our side double analysis of buffered, eltype,encoding drawback: slow; advantage: simple iface with stream.d */ make_launch_pipe(&(STACK_2),DIRECTION_INPUT,hparent_in, child_id,enc,eltype,buff); /* child's error stream, pipe-input from our side */ make_launch_pipe(&(STACK_1),DIRECTION_INPUT,hparent_errin, child_id,enc,eltype,buff); } value1 = wait_p ? fixnum(exit_code) : L_to_I(child_id); value2 = (hparent_out != INVALID_HANDLE) ? (object)STACK_3 : NIL; /*INPUT*/ value3 = (hparent_in != INVALID_HANDLE) ? (object)STACK_2 : NIL; /*OUTPUT*/ value4 = (hparent_errin != INVALID_HANDLE) ? (object)STACK_1 : NIL; /*ERROR*/ mv_count = 4; skipSTACK(10); } #if defined(MY_LOCAL_PRIORITY_CLASSES) #undef MY_LOCAL_PRIORITY_CLASSES #undef NORMAL_PRIORITY_CLASS #undef HIGH_PRIORITY_CLASS #undef IDLE_PRIORITY_CLASS #endif #if defined(UNIX) #undef CloseHandle #endif #undef ParaClose /* (SAVEMEM pathname executable) stores the memory image at pathname. */ LISPFUNN(savemem,2) { #ifdef MULTITHREAD extern bool single_running_threadp(); /* ensure that we are the only running thread. currently threads do not survive savemem()/loadmem() */ if (!single_running_threadp()) { /* signal an error */ pushSTACK(NIL); /* CELL-ERROR Slot NAME */ pushSTACK(subr_self); error(control_error,GETTEXT("~S: There are multiple running threads. Currently they do not survive image saving/loading.")); } /* we are the only one running. let's check mutexes. we do not allow to have locked mutexes saved in the memory image */ var object list = O(all_mutexes); while (!endp(list)) { if (!nullp(TheMutex(Car(list))->xmu_owner)) { /* we have a locked mutex. this is an error. */ pushSTACK(NIL); /* CELL-ERROR Slot NAME */ /* mutex owner (should be eq() to current thread) */ pushSTACK(TheMutex(Car(list))->xmu_owner); pushSTACK(Car(list)); /* mutex */ pushSTACK(subr_self); error(control_error,GETTEXT("~S: Mutex ~S is locked by thread ~S. Currently locked mutexes are not allowed in memory files.")); } list = Cdr(list); } #endif var uintL executable = nullp(STACK_0) ? 0 : eq(Fixnum_0,STACK_0) ? 2 : 1; skipSTACK(1); /* drop executable */ /* execute (OPEN pathname :direction :output) : pathname as 1st argument */ pushSTACK(S(Kdirection)); /* :DIRECTION as 2nd Argument */ pushSTACK(S(Koutput)); /* :OUTPUT as 3rd Argument */ #ifdef UNIX /* On Unix with mmap() existing .mem-Files may not be simply overwritten, because running Lisp-processes would crash due to this. So therefore :if-exists :rename-and-delete. */ #if defined(UNIX_LINUX) && defined(SINGLEMAP_MEMORY) /* Under Linux 1.3.20, when the mem file to be saved is on an NFS volume and has the same filename as the mem file we started with, the GC done by savemem (once the new mem file has been created and still has size 0) will crash. Looks like a bug in the Linux NFS client, which causes random pages to be mapped in instead of pages from the renamed old mem file. Workaround: Do a full GC, forcing all the old mem file's contents into memory immediately. */ gar_col(1); #endif pushSTACK(S(Kif_exists)); /* :IF-EXISTS as 4th Argument */ pushSTACK(S(Krename_and_delete)); /* :RENAME-AND-DELETE as 5th Argument */ funcall(L(open),5); #else funcall(L(open),3); #endif /* write memory image into the file: (the stream has to be closed by function savemem(), also in case of an error.) */ var off_t file_size = savemem(value1,executable); VALUES1(off_to_I(file_size)); } #ifdef DYNAMIC_MODULES /* (SYSTEM::DYNLOAD-MODULES pathname stringlist) loads a shared library, containing a number of modules. */ LISPFUNN(dynload_modules,2) { /* convert pathname into string */ STACK_1 = coerce_pathname(STACK_1); check_no_wildcards(STACK_1); STACK_1 = whole_namestring(use_default_dir(STACK_1)); var uintL stringcount = llength(STACK_0); var gcv_object_t* arg_ = &STACK_0; var gcv_object_t* libpath_ = &STACK_1; { /* print loading message */ dynamic_bind(S(load_level),fixnum_inc(Symbol_value(S(load_level)),1)); pushSTACK(CLSTEXT("Loading module~P ~{~A~^, ~} from ~A")); pushSTACK(fixnum(stringcount)); pushSTACK(*arg_); pushSTACK(*libpath_); funcall(S(loading_message),4); /* defined in init.lisp */ } { /* check strings and store in the stack: */ pushSTACK(*arg_); /* tail */ while (!endp(STACK_0)) { Car(STACK_0) = check_string(Car(STACK_0)); pushSTACK(Cdr(STACK_0)); /* for the next iteration */ STACK_1 = string_to_asciz(Car(STACK_1),Symbol_value(S(ascii))); } skipSTACK(1); /* drop tail */ } { var DYNAMIC_ARRAY(modnames,const char *,stringcount); if (stringcount > 0) { var uintL count; var gcv_object_t* ptr1 = STACK STACKop stringcount; var const char * * ptr2 = modnames; dotimespL(count,stringcount, { *ptr2++ = TheAsciz(NEXT(ptr1)); }); } with_string_0(*libpath_,O(pathname_encoding),libpath, { dynload_modules(libpath,stringcount,modnames); }); FREE_DYNAMIC_ARRAY(modnames); } skipSTACK(stringcount); { /* print loading message */ pushSTACK(CLSTEXT("Loaded module~P ~{~A~^, ~} from ~A")); pushSTACK(fixnum(stringcount)); pushSTACK(*arg_); pushSTACK(*libpath_); funcall(S(loading_message),4); /* defined in init.lisp */ dynamic_unbind(S(load_level)); } VALUES1(*libpath_); /* Library-Name as value */ skipSTACK(2); } #endif /* =================================================================== */ #include "execname.c" LISPFUNN(program_name,0) { /* (SYS::PROGRAM-NAME) returns the executable's name. */ VALUES1(asciz_to_string(executable_name,O(pathname_encoding))); } LISPFUNN(lib_directory,0) { /* (SYS::LIB-DIRECTORY) returns CLISP's private library directory (called $(lisplibdir) in the Makefile). */ if (!nullp(O(lib_dir))) { VALUES1(O(lib_dir)); } else { pushSTACK(TheSubr(subr_self)->name); error(error_condition,GETTEXT("~S: installation directory is not known, use the -B command line option to specify it or set *LIB-DIRECTORY*")); } } LISPFUNN(set_lib_directory,1) { /* (SYS::SET-LIB-DIRECTORY path) sets the CLISP's private library directory (called $(lisplibdir) in the Makefile) */ if (stringp(STACK_0)) STACK_0 = ensure_last_slash(STACK_0); funcall(L(truename),1); O(lib_dir) = value1; } /* ===================================================================== */ #ifdef DEBUG_TRANSLATE_PATHNAME #undef DEBUG_TRANSLATE_PATHNAME #undef DOUT #endif