diff --git a/documentation/source/library-reference/system/file-system.rst b/documentation/source/library-reference/system/file-system.rst index 24a81f7f07..b33ea17479 100644 --- a/documentation/source/library-reference/system/file-system.rst +++ b/documentation/source/library-reference/system/file-system.rst @@ -79,7 +79,8 @@ properties of the file. - :func:`file-properties` - :func:`file-property` - :func:`file-type` -- :func:`link-target` +- :gf:`link-target` +- :gf:`resolve-file` File system locators -------------------- @@ -646,16 +647,26 @@ File-System module. Returns a sequence of files and subdirectories contained in a directory. - :signature: directory-contents *directory* => *locators* + :signature: directory-contents *directory* #key *resolve-links?* => *locators* :parameter directory: An instance of :type:``. + :parameter #key resolve-links?: An instance of :drm:``. The default is :drm:`#f`. :value locators: A :drm:`` of :class:``. :description: - In the result, each file is represented by a :class:`` and - each directory is represented by a :class:``. The "." - and ".." directories are not included in the result. + Returns a sequence of locators describing the files contained in *directory*. The + "." and ".." directories are not included in the result. + + If *resolve-links?* is false then symbolic links are returned as instances of + :class:``. If true, then symbolic links are resolved and the correct + class of locator, :class:`` or :class:``, is + determined based on the file type of the (fully resolved) link target. + + Note that if a symlink points to another file in *directory* then the resulting + sequence may contain duplicates (in the sense of naming the same file system + entity, not in the sense of Dylan object equality) when *resolve-links?* is + true. .. generic-function:: directory-empty? @@ -758,26 +769,27 @@ File-System module. .. generic-function:: expand-pathname - Given a pathname, returns its fully expanded form. - - :signature: expand-pathname *path* => *expanded-path* - - :param path: An instance of :class:``. - :value expanded-path: An instance of :class:``. + Replaces an initial pathname component of ``~`` or ``~user`` with that user's home + directory. -.. method:: expand-pathname - :specializer: + :signature: expand-pathname *pathname* => *locator* - Expand a file path to its fully expanded form. + :param path: An instance of :type:``. + :value expanded: An instance of :class:``. - :param path: An instance of :class:``. + :description: -.. method:: expand-pathname - :specializer: + .. note:: On Windows only ``~`` is replaced; expansion of ``~user`` is not yet + implemented. - Expands a pathname given as a string. + If *pathname* is an instance of :drm:`` it is first converted to a + :class:``. If the first component of this locator begins with + `~` it is replaced by either the specified user's home directory (for ``~user``) or + the current user's home directory (for ``~``). Otherwise the locator is returned + unmodified. - :param path: An instance of :class:``. + If the specified ``~user`` doesn't exist no error is signaled and the locator is + returned without expansion being performed. .. generic-function:: file-error-locator @@ -841,7 +853,7 @@ File-System module. :signature: file-exists? *file* #key *follow-links?* => *exists?* :parameter file: An instance of :type:``. - :parameter follow-links?: An instance of :drm:``. Defaults to + :parameter #key follow-links?: An instance of :drm:``. Defaults to :drm:`#t`. :value exists?: An instance of :drm:``. @@ -1059,6 +1071,9 @@ File-System module. file system entity can either be a file, a directory, or a link to another file or directory. + This function does not resolve symbolic links. To find the file type of the link + target call :gf:`link-target` or :gf:`resolve-file` on *file* first. + .. type:: The type representing all possible types of a file system entity. @@ -1105,21 +1120,60 @@ File-System module. permissions set on the file are incorrect or insufficient for your operation. -.. function:: link-target +.. generic-function:: link-target Returns the target of a symbolic link. - :signature: link-target *file* => *target* + .. note:: On Windows this function is not implemented; it always signals an error. + + :signature: link-target *file* #key *follow-links?* => *target* :parameter file: An instance of type :type:``. - :value target: An instance of type :type:``. + :parameter #key follow-links?: An instance of type :drm:``. The default is + :drm:`#t`. + :value target: :drm:`#f` or an instance of type :class:``. :description: - Repeatedly follows symbolic links starting with *file* until it finds a - non-link file or directory, or a non-existent link target. + Returns a locator identifying the target of symbolic link *file*. + + Signals :class:`` if the system call to read the link target + fails for any reason. For example, if *file* is not a symbolic link or if *file* + does not exist. + + If ``follow-links?`` is true (the default) then links are followed until a file + that is not a symbolic link is found, and the locator for that file is returned. If + the final link in a chain of one or more symbolic links points to a non-existent + file, :drm:`#f` is returned. + + If ``follow-links?`` is false, no attempt is made to follow the link or to check + whether the link target file exists. A locator representing the target is + returned. :seealso: - :func:`create-symbolic-link` + - :gf:`resolve-file` + +.. generic-function:: resolve-file + :open: + + Resolves a file path to its simplest representation containing no symbolic links. + + :signature: resolve-file *path* => *resolved-path* + + :description: + + Resolves all links, parent references (``..``), self references (``.``), and + removes unnecessary path separators. Similar to :func:`simplify-locator` except + that it consults the file system to resolve links. A :class:`` + is signaled if for any reason the path can't be resolved. Examples include + non-existent directory components, access denied, I/O error, etc. In short, this + function follows the semantics of POSIX ``realpath(3)``. + + :parameter path: An instance of :type:``. + :value resolved-path: An instance of :class:``. More + specifically, the return value will be an instance of :class:`` or + :class:`` depending on the type of the resolved file system + entity. .. _make: @@ -1276,7 +1330,7 @@ File-System module. - :func:`file-property-setter` - :func:`file-type` - :func:`home-directory` - - :func:`link-target` + - :gf:`link-target` - :func:`rename-file` - :func:`create-symbolic-link` @@ -1315,7 +1369,7 @@ File-System module. :parameter old-file: An instance of :type:``. :parameter new-file: An instance of :type:``. - :parameter if-exists: An instance of + :parameter #key if-exists: An instance of :type:``. Default value: ``#"signal"``. :description: diff --git a/documentation/source/library-reference/system/locators.rst b/documentation/source/library-reference/system/locators.rst index 2f40f964de..d5586c081d 100644 --- a/documentation/source/library-reference/system/locators.rst +++ b/documentation/source/library-reference/system/locators.rst @@ -384,22 +384,11 @@ The locators Module :parameter locator: An instance of :class:``. :value simplified-locator: An instance of :class:``. -.. generic-function:: resolve-locator - :open: - - Resolves all links, parent references (``..``), self references (``.``), and - removes unnecessary path separators. Similar to :func:`simplify-locator` - except that it consults the file system to resolve links. A - :class:`` is signaled if for any reason the path can't be - resolved. Examples include non-existent directory components, access denied, - I/O error, etc. In short, this function follows the semantics of POSIX - ``realpath(3)``. - - :signature: resolve-locator (locator) => (resolved-locator) +.. constant:: resolve-locator - :parameter locator: An instance of :class:``. - :value simplified-locator: An instance of :class:``. + .. deprecated:: 2025.2 + :seealso: :gf:`resolve-file` .. generic-function:: string-as-locator :open: diff --git a/documentation/source/release-notes/2025.2.rst b/documentation/source/release-notes/2025.2.rst index 2c8dca172f..d25283253b 100644 --- a/documentation/source/release-notes/2025.2.rst +++ b/documentation/source/release-notes/2025.2.rst @@ -23,8 +23,42 @@ Compiler Tools ===== -Library Updates -=============== +Libraries +========= + +System +------ + +* :gf:`resolve-file` (in the ``file-system`` module) replaces :const:`resolve-locator` + (in the ``locators`` module) because it is fundamentally a file-system operation. + + :gf:`resolve-file` now returns the correct class of locator, a subclass of + :class:`` or class:``, depending on the actual file + type of the fully resolved file. It previously returned an instance of the same + class as the locator it was provided, but that is not always accurate when symbolic + links are followed. + +* :gf:`directory-contents` has a new keyword argument ``resolve-links?``. If true, + symbolic links are resolved as with :gf:`resolve-file`. + +* :gf:`expand-pathname` is no longer called by other ``file-system`` functions. Whether + or not to expand ``~`` or ``~user`` in a pathname is up to the user. The function has + been modified such that the :type:`` comprised of the exact string ``"~"`` or + ``"~user"`` expands to the user's home directory. Previously these were returned as + unexpanded instances of :class:``. + + :gf:`expand-pathname` now uses the thread safe function ``getpwnam_r`` on Unix systems. + + On Windows :gf:`expand-pathname` simply returns its argument (converted to a + :class:`` if it was a :drm:``). In a future release it will be fixed + to do the same thing as the Unix implementation. Previously it erroniously did the + same thing as :gf:`resolve-locator`. + +* `Issue 1408 `_, which could result + in an infinite loop in :gf:`link-target`, has been fixed. In addition, the + :gf:`link-target` function accepts a new keyword argument, ``follow-links?``, which + specifies whether to follow all links until a non-symlink file is found (the default) + or just return the direct target of the given symlink. Contributors ============ diff --git a/dylan-package.json b/dylan-package.json index d6b1eb073a..d6b6ba940d 100644 --- a/dylan-package.json +++ b/dylan-package.json @@ -6,7 +6,7 @@ "dependencies": [ "collection-extensions@0.1", "command-line-parser@3.2", - "deft@0.12", + "deft@0.13", "json@1.1", "meta@0.1", "regular-expressions@0.2", diff --git a/sources/system/aarch64-linux-magic-numbers.dylan b/sources/system/aarch64-linux-magic-numbers.dylan index dd410624af..c070de546b 100644 --- a/sources/system/aarch64-linux-magic-numbers.dylan +++ b/sources/system/aarch64-linux-magic-numbers.dylan @@ -7,7 +7,6 @@ License: Public Domain define constant $ENOENT = 2; define constant $EINTR = 4; define constant $EACCES = 13; -define constant $EINVAL = 22; define constant $ETXTBSY = 26; define constant $EROFS = 30; define constant $path-max = 4096; diff --git a/sources/system/arm-linux-magic-numbers.dylan b/sources/system/arm-linux-magic-numbers.dylan index 2235953d25..6ad70f9253 100644 --- a/sources/system/arm-linux-magic-numbers.dylan +++ b/sources/system/arm-linux-magic-numbers.dylan @@ -7,7 +7,6 @@ License: Public Domain define constant $ENOENT = 2; define constant $EINTR = 4; define constant $EACCES = 13; -define constant $EINVAL = 22; define constant $ETXTBSY = 26; define constant $EROFS = 30; define constant $path-max = 4096; diff --git a/sources/system/dump-magic-numbers.c b/sources/system/dump-magic-numbers.c index 171a3b54c5..b630e70b67 100644 --- a/sources/system/dump-magic-numbers.c +++ b/sources/system/dump-magic-numbers.c @@ -10,14 +10,12 @@ #include #include -#define PRINT_USEDBY(file) \ - printf("\n// Used by %s\n", file) #define PRINT_CONSTANT(value, name) \ - printf("define constant $%s = %d;\n", name, value); + printf("define constant %s :: = %d;\n", name, value); #define PRINT_SIZEOF(type, name) \ - printf("define constant $%s-size = %zu;\n", name, sizeof(type)) + printf("define constant %s :: = %zu;\n", name, sizeof(type)) #define PRINT_OFFSETOF(type, member, name) \ - printf("define constant $%s-offset = %zu;\n", name, offsetof(type, member)) + printf("define constant %s :: = %zu;\n", name, offsetof(type, member)) int main(void) { @@ -25,45 +23,41 @@ main(void) { printf("Module: system-internals\n"); printf("License: Public Domain\n"); - printf("\n// WARNING! This file is generated!\n"); - - PRINT_USEDBY("file-system/unix-ffi.dylan"); - - PRINT_CONSTANT(ENOENT, "ENOENT"); - PRINT_CONSTANT(EINTR, "EINTR"); - PRINT_CONSTANT(EACCES, "EACCES"); - PRINT_CONSTANT(EINVAL, "EINVAL"); - PRINT_CONSTANT(ETXTBSY, "ETXTBSY"); - PRINT_CONSTANT(EROFS, "EROFS"); - - PRINT_CONSTANT(PATH_MAX, "path-max"); - - PRINT_SIZEOF(struct stat, "stat"); - PRINT_OFFSETOF(struct stat, st_mode, "st-mode"); - PRINT_OFFSETOF(struct stat, st_uid, "st-uid"); - PRINT_OFFSETOF(struct stat, st_gid, "st-gid"); - PRINT_OFFSETOF(struct stat, st_size, "st-size"); - PRINT_OFFSETOF(struct stat, st_atime, "st-atime"); - PRINT_OFFSETOF(struct stat, st_mtime, "st-mtime"); - PRINT_OFFSETOF(struct stat, st_ctime, "st-ctime"); - - PRINT_OFFSETOF(struct passwd, pw_name, "pw-name"); - PRINT_OFFSETOF(struct passwd, pw_dir, "pw-dir"); - - PRINT_OFFSETOF(struct group, gr_name, "gr-name"); - - - PRINT_USEDBY("unix-date-interface.dylan"); - - PRINT_OFFSETOF(struct tm, tm_sec, "tm-sec"); - PRINT_OFFSETOF(struct tm, tm_min, "tm-min"); - PRINT_OFFSETOF(struct tm, tm_hour, "tm-hour"); - PRINT_OFFSETOF(struct tm, tm_mday, "tm-mday"); - PRINT_OFFSETOF(struct tm, tm_mon, "tm-mon"); - PRINT_OFFSETOF(struct tm, tm_year, "tm-year"); - PRINT_OFFSETOF(struct tm, tm_isdst, "tm-isdst"); - PRINT_OFFSETOF(struct tm, tm_gmtoff, "tm-gmtoff"); - PRINT_OFFSETOF(struct tm, tm_zone, "tm-zone"); + printf("\n// WARNING! This file is generated by running dump-magic-numbers.c!\n"); + + printf("\n"); + PRINT_CONSTANT(ENOENT, "$ENOENT"); + PRINT_CONSTANT(EINTR, "$EINTR"); + PRINT_CONSTANT(EACCES, "$EACCES"); + PRINT_CONSTANT(ETXTBSY, "$ETXTBSY"); + PRINT_CONSTANT(EROFS, "$EROFS"); + + printf("\n"); + PRINT_CONSTANT(PATH_MAX, "$path-max"); + + printf("\n"); + PRINT_SIZEOF(struct stat, "$stat-size"); + PRINT_OFFSETOF(struct stat, st_mode, "$st-mode-offset"); + PRINT_OFFSETOF(struct stat, st_uid, "$st-uid-offset"); + PRINT_OFFSETOF(struct stat, st_gid, "$st-gid-offset"); + PRINT_OFFSETOF(struct stat, st_size, "$st-size-offset"); + PRINT_OFFSETOF(struct stat, st_atime, "$st-atime-offset"); + PRINT_OFFSETOF(struct stat, st_mtime, "$st-mtime-offset"); + PRINT_OFFSETOF(struct stat, st_ctime, "$st-ctime-offset"); + + printf("\n"); + PRINT_OFFSETOF(struct group, gr_name, "$gr-name-offset"); + + printf("\n"); + PRINT_OFFSETOF(struct tm, tm_sec, "$tm-sec-offset"); + PRINT_OFFSETOF(struct tm, tm_min, "$tm-min-offset"); + PRINT_OFFSETOF(struct tm, tm_hour, "$tm-hour-offset"); + PRINT_OFFSETOF(struct tm, tm_mday, "$tm-mday-offset"); + PRINT_OFFSETOF(struct tm, tm_mon, "$tm-mon-offset"); + PRINT_OFFSETOF(struct tm, tm_year, "$tm-year-offset"); + PRINT_OFFSETOF(struct tm, tm_isdst, "$tm-isdst-offset"); + PRINT_OFFSETOF(struct tm, tm_gmtoff, "$tm-gmtoff-offset"); + PRINT_OFFSETOF(struct tm, tm_zone, "$tm-zone-offset"); return 0; } diff --git a/sources/system/file-system/file-system.dylan b/sources/system/file-system/file-system.dylan index 73f694a78f..3846309b2f 100644 --- a/sources/system/file-system/file-system.dylan +++ b/sources/system/file-system/file-system.dylan @@ -8,7 +8,12 @@ Warranty: Distributed WITHOUT WARRANTY OF ANY KIND /// Types -/// Needs a better name, I think ... +// Needs a better name, I think ... +// +// I'm guessing the author of the above comment was thinking of the potential confusion +// between "file type" and "file extension", which in turn is related to the confusion +// between "pathname" or "locator" and "file". Locators uses the "extension" terminology +// consistently so I think is okay. ? ;) --cgay define constant = one-of(#"file", #"directory", #"link"); define constant = one-of(#"signal", #"replace"); @@ -84,7 +89,13 @@ end method condition-to-string; /// And now, the functions ... -/// Given a pathname, returns its fully expanded form. +// Expand ~ and ~user in the given pathname. +// +// TODO(cgay): Seems like this should have "user" in its name. The fact that it doesn't +// could explain why win32-file-system.dylan was apparently using it as a way to convert +// to an absolute pathname. +// Racket: expand-user-path +// Python: os.path.expanduser define generic expand-pathname (path :: ) => (expanded-path :: ); define method expand-pathname (path :: ) => (expanded-path :: ) @@ -138,14 +149,20 @@ end method file-type; /// -define generic link-target (link :: ) => (target :: ); - -define method link-target (link :: ) => (target :: ) - %link-target(link) +define generic link-target + (link :: , #key follow-links?) + => (target :: false-or()); + +define method link-target + (link :: , #key follow-links? :: = #t) + => (target :: false-or()) + %link-target(link, follow-links?) end method link-target; -define method link-target (link :: ) => (target :: ) - link-target(as(, link)) +define method link-target + (link :: , #key follow-links? :: = #t) + => (target :: false-or()) + link-target(as(, link), follow-links?: follow-links?) end method link-target; @@ -316,37 +333,76 @@ end method do-directory; define generic directory-contents - (directory :: ) => (locators :: ); + (directory :: , #key resolve-links?) + => (locators :: ); define method directory-contents - (directory :: ) => (locators :: ) - directory-contents(as(, directory)) + (directory :: , #key resolve-links? :: ) + => (locators :: ) + directory-contents(as(, directory), + resolve-links?: resolve-links?) end; -/// Return a locator for each file in the given directory. The returned -/// locators are guaranteed to be instances of if the -/// file is a directory, and instances of otherwise. -/// +// Return a sequence of locators describing the files in `directory`. If +// `resolve-links?` is false then symbolic links are returned as instances of +// . If true, then symbolic links are resolved and the correct class of +// locator is guaranteed. Note that if a symlink points to another file in `directory` +// then the resulting sequence may contain duplicates (in the sense of naming the same +// file system entity, not Dylan object equality) when `resolve-links?` is true. (This +// could be solved by resolving all the locators and checking for duplicates.) define method directory-contents - (directory :: ) - => (contents :: ) - let contents = #(); - local method add-file (directory, filename, type) - if (filename ~= "." & filename ~= "..") - let locator = if (type = #"directory") - subdirectory-locator(directory, filename) - else - merge-locators(as(, filename), directory) - end; - contents := pair(locator, contents); - end; - end; - do-directory(add-file, directory); - reverse!(contents) + (directory :: , #key resolve-links? :: ) + => (locators :: ) + collecting () + local method add-file (directory, name, type) + if (name ~= "." & name ~= "..") + select (type) + #"directory" => collect(subdirectory-locator(directory, name)); + #"file" => collect(file-locator(directory, name)); + #"link" => + let locator = file-locator(directory, name); + if (resolve-links?) + locator := resolve-locator(locator); + end; + collect(locator); + end; + end; + end method; + do-directory(add-file, directory); + end collecting end method directory-contents; +// Check the file system to resolve and expand links, and normalize the path. +// Returns an absolute locator, using the current process's working directory +// to resolve relative locators, or signals . Note that lack +// of an error does not mean that the resolved locator names an existing file, +// but does mean the containing directory exists. In other words, this function +// inherits POSIX `realpath` semantics. +define open generic resolve-file + (path :: ) => (resolved :: ); + +define method resolve-file + (path :: ) => (resolved :: ) + let resolved = %resolve-file(path); + let class = if (file-type(resolved) == #"directory") + + else + + end; + as(class, resolved) +end method; + +define method resolve-file + (path :: ) => (resolved :: ) + resolve-file(as(, path)) +end method; + /// +// TODO(cgay): We could compatibly change this to create-directory(dir, #rest names). +// Then if you've already cobbled together a directory locator you can just pass that. +// If you pass multiple names, it's like create-directory(subdirectory-locator(dir, +// names...)). create-directory(dir) always was the intuitive API to me anyway. define generic create-directory (parent :: , name :: ) => (directory :: ); @@ -374,7 +430,7 @@ define method delete-directory (directory :: , #key recursive? :: ) => () if (recursive?) - for (file in directory-contents(directory)) + for (file in directory-contents(directory, resolve-links?: #f)) if (instance?(file, )) delete-directory(file, recursive?: #t); else @@ -500,21 +556,7 @@ end method supports-list-locator?; /// define sideways method list-locator (locator :: ) => (locators :: ) - let locators :: = make(); - do-directory - (method (directory :: , name :: , type :: ) - ignore(directory); - let sublocator - = select (type) - #"file", #"link" => - merge-locators(as(, name), locator); - #"directory" => - subdirectory-locator(locator, name); - end; - add!(locators, sublocator) - end, - locator); - locators + directory-contents(locator) end method list-locator; /// @@ -529,4 +571,4 @@ define function create-hard-link (target :: , link :: ) => () %create-hard-link(as(, target), as(, link)) -end function create-hard-link; \ No newline at end of file +end function create-hard-link; diff --git a/sources/system/file-system/unix-ffi.dylan b/sources/system/file-system/unix-ffi.dylan index 77ae98caac..97800d5451 100644 --- a/sources/system/file-system/unix-ffi.dylan +++ b/sources/system/file-system/unix-ffi.dylan @@ -92,21 +92,6 @@ define inline-only function st-ctime (st :: ) => (ctime :: ) => (name :: ) - primitive-raw-as-string - (primitive-c-pointer-at(primitive-unwrap-machine-word(passwd), - integer-as-raw(0), - integer-as-raw($pw-name-offset))) -end function passwd-name; - -define inline-only function passwd-dir (passwd :: ) => (dir :: ) - primitive-raw-as-string - (primitive-c-pointer-at(primitive-unwrap-machine-word(passwd), - integer-as-raw(0), - integer-as-raw($pw-dir-offset))) -end function passwd-dir; - - define inline-only function group-name (group :: ) => (name :: ) primitive-raw-as-string (primitive-c-pointer-at(primitive-unwrap-machine-word(group), diff --git a/sources/system/file-system/unix-file-system.dylan b/sources/system/file-system/unix-file-system.dylan index 38f48b29d9..629b3f72ac 100644 --- a/sources/system/file-system/unix-file-system.dylan +++ b/sources/system/file-system/unix-file-system.dylan @@ -7,43 +7,28 @@ License: See License.txt in this distribution for details. Warranty: Distributed WITHOUT WARRANTY OF ANY KIND // Expand "~" and "~USER" in a pathname. -// -// TODO(cgay): most file-system functions shouldn't call this, since file names -// with ~ in them are perfectly valid; the functionality should be provided -// only for user code to call explicitly. define method %expand-pathname (dir :: ) => (expanded-path :: ) - block (return) - if (~locator-relative?(dir)) - return(dir); - end; - let elements = locator-path(dir); - if (empty?(elements)) - return(dir); - end; - let first = elements[0]; - if (~instance?(first, ) | first.size = 0 | first[0] ~= '~') - return(dir); - end; - let name = case - first = "~" => login-name(); - otherwise => copy-sequence(first, start: 1); - end; - let passwd = primitive-wrap-machine-word - (primitive-cast-pointer-as-raw - (%call-c-function ("getpwnam") - (name :: ) => (passwd :: ) - (primitive-string-as-raw(name)) - end)); - if (primitive-machine-word-equal?(primitive-unwrap-machine-word(passwd), - integer-as-raw(0))) - dir + let path = locator-path(dir); + let name = ~empty?(path) & path[0]; + if (~locator-relative?(dir) + | ~instance?(name, ) + | name.empty? + | name[0] ~== '~') + dir + else + let locator = make(, + path: copy-sequence(path, start: 1), + relative?: #t); + if (name = "~") + merge-locators(locator, home-directory()) else - let homedir = as(, passwd-dir(passwd)); - return(merge-locators(make(, - path: copy-sequence(elements, start: 1), - relative?: #t), - homedir)) + let homedir = user-home-directory(copy-sequence(name, start: 1)); + if (homedir) + merge-locators(locator, as(, homedir)) + else + dir // ~no-such-user + end end end end method; @@ -51,21 +36,60 @@ end method; define method %expand-pathname (file :: ) => (expanded-path :: ) let directory = locator-directory(file); - let expanded-directory = directory & %expand-pathname(directory); - if (directory = expanded-directory) - file + if (directory) + let expanded-directory = %expand-pathname(directory); + if (directory == expanded-directory) + file + else + make(, + directory: expanded-directory, + base: locator-base(file), + extension: locator-extension(file)) + end + elseif (locator-extension(file)) + file // ~foo.bar else - make(, - directory: expanded-directory, - base: locator-base(file), - extension: locator-extension(file)) + // Because expand-pathname may be called with a string such as "~luser", and it is + // coerced to a locator with as(), which may result in a + // without a directory, we need to handle the case of no directory but + // an expandable base component. + let base = locator-base(file); + if (~base | empty?(base) | base[0] ~= '~') + file + elseif (base = "~") + home-directory() + else + let user = copy-sequence(base, start: 1); + let homedir = user-home-directory(user); + if (homedir) + as(, homedir) + else + file // ~no-such-user + end + end end end method; -define method %expand-pathname - (path :: ) => (expanded-path :: ) - path -end method; +define function user-home-directory + (user :: ) => (homedir :: false-or()) + with-storage (homedir-buffer, $path-max) + let status + = (%call-c-function ("system_user_homedir") + (username :: , + buffer :: , + buffer-size :: ) + => (status :: ) + (primitive-string-as-raw(user), + primitive-cast-raw-as-pointer(primitive-unwrap-machine-word(homedir-buffer)), + primitive-cast-integer-as-raw($path-max)) + end); + if (zero?(raw-as-integer(status))) + primitive-raw-as-string( + primitive-cast-raw-as-pointer( + primitive-unwrap-machine-word(homedir-buffer))) + end + end with-storage +end function; // No-op implementation for Windows-only feature. @@ -75,10 +99,9 @@ define function %shorten-pathname path end function %shorten-pathname; -define function %resolve-locator - (locator :: ) - => (resolved-locator :: ) - let path = as(, locator); + +define function %resolve-file + (path :: ) => (resolved :: ) with-storage (resolved-path, $path-max) let result = primitive-wrap-machine-word( @@ -91,20 +114,19 @@ define function %resolve-locator primitive-unwrap-machine-word(resolved-path))) end)); if (result = resolved-path) - let resolved = primitive-raw-as-string( - primitive-cast-raw-as-pointer( - primitive-unwrap-machine-word(resolved-path))); - string-as-locator(object-class(locator), resolved) + primitive-raw-as-string( + primitive-cast-raw-as-pointer( + primitive-unwrap-machine-word(resolved-path))) else unix-file-error("get realpath for", "%=", path); end end with-storage end function; + define function %file-exists? (file :: , follow-links? :: ) => (exists? :: ) - let file = %expand-pathname(file); with-stack-stat (st, file) ~primitive-raw-as-boolean( if (follow-links?) @@ -125,11 +147,10 @@ define function %file-exists? end end function; -/// + define function %file-type - (file :: , #key if-not-exists = #f) - => (file-type :: ) - let file = %expand-pathname(file); + (file :: , #key if-does-not-exist = unsupplied()) + => (file-type :: ) with-stack-stat (st, file) if (primitive-raw-as-boolean (%call-c-function ("system_lstat") (path :: , st :: ) @@ -137,14 +158,14 @@ define function %file-type (primitive-string-as-raw(as(, file)), primitive-cast-raw-as-pointer(primitive-unwrap-machine-word(st))) end)) - if (unix-errno() = $ENOENT & if-not-exists) - if-not-exists + if (unix-errno() == $ENOENT & if-does-not-exist ~== unsupplied()) + if-does-not-exist else unix-file-error("determine the type of", "%s", file) end - elseif (logand(st-mode(st), $S_IFMT) = $S_IFDIR) + elseif (logand(st-mode(st), $S_IFMT) == $S_IFDIR) #"directory" - elseif (logand(st-mode(st), $S_IFMT) = $S_IFLNK) + elseif (logand(st-mode(st), $S_IFMT) == $S_IFLNK) #"link" else #"file" @@ -153,38 +174,45 @@ define function %file-type end function %file-type; -/// define function %link-target - (link :: ) => (target :: ) - let link = %expand-pathname(link); - while (%file-type(link, if-not-exists: #"file") == #"link") - let buffer = make(, size: 8192, fill: '\0'); - let count + (link :: , follow-links? :: ) + => (target :: false-or()) + iterate loop (link = link) + let bufsize = $path-max; + let buffer = make(, size: bufsize, fill: '\0'); + let length = raw-as-integer(%call-c-function ("readlink") (path :: , buffer :: , bufsize :: ) => (count :: ) (primitive-string-as-raw(as(, link)), primitive-string-as-raw(buffer), - integer-as-raw(8192)) + integer-as-raw(bufsize)) end); - if (count = -1) - unless (unix-errno() = $ENOENT | unix-errno() = $EINVAL) - unix-file-error("readlink", "%s", link) - end + if (length == -1) + unix-file-error("readlink", "%s", link); else - let target = as(, copy-sequence(buffer, end: count)); - link := merge-locators(target, link) + let locator = as(, copy-sequence(buffer, end: length)); + let target = merge-locators(locator, link); + if (~follow-links?) + target + else + let type = %file-type(target, if-does-not-exist: #f); + if (~type) + #f + elseif (type == #"link") + loop(target) + else + target + end + end end - end; - link + end iterate end function %link-target; -/// define function %delete-file (file :: ) => () - let file = %expand-pathname(file); if (primitive-raw-as-boolean (%call-c-function ("unlink") (path :: ) => (failed? :: ) @@ -195,15 +223,11 @@ define function %delete-file end function %delete-file; -/// Whoever heard of an OS that doesn't provide a primitive to copy files? -/// Why, the creators of UNIX, of course since it doesn't. We have to resort -/// to invoking the cp (copy) command via RUN-APPLICATION. +// TODO: use copy file syscalls: https://github.com/dylan-lang/opendylan/issues/1649 define function %copy-file (source :: , destination :: , #key if-exists :: = #"signal") => () - let source = %expand-pathname(source); - let destination = %expand-pathname(destination); // UNIX strikes again! The copy command will overwrite its target if // the user has write access and the only way to prevent it would // require the user to respond to a question! So, we have to manually @@ -225,13 +249,10 @@ define function %copy-file end function %copy-file; -/// define function %rename-file (source :: , destination :: , #Key if-exists :: = #"signal") => () - let source = %expand-pathname(source); - let destination = %expand-pathname(destination); // UNIX strikes again! It's rename function always replaces the target. // So, if the caller doesn't want to overwrite an existing file, we have // to manually check beforehand. (Sigh) @@ -251,12 +272,9 @@ define function %rename-file end end function %rename-file; - -/// define function %file-properties (file :: ) => (properties :: ) - let file = %expand-pathname(file); let properties = make(); with-stack-stat (st, file) if (primitive-raw-as-boolean @@ -290,7 +308,6 @@ end function %file-properties; define method %file-property (file :: , key == #"author") => (author :: false-or()) - let file = %expand-pathname(file); with-stack-stat (st, file) if (primitive-raw-as-boolean (%call-c-function ("system_stat") (path :: , st :: ) @@ -300,25 +317,43 @@ define method %file-property end)) unix-file-error("get the author of", "%s", file) end; - let passwd = primitive-wrap-machine-word - (primitive-cast-pointer-as-raw - (%call-c-function ("getpwuid") - (uid :: ) => (passwd :: ) - (abstract-integer-as-raw(st-uid(st))) - end)); - if (primitive-machine-word-not-equal?(primitive-unwrap-machine-word(passwd), - integer-as-raw(0))) - passwd-name(passwd) - else - unix-file-error("get the author of", "%s", file) - end + let uid = raw-as-integer(abstract-integer-as-raw(st-uid(st))); // ?? better way? + username-from-uid(uid) end end method %file-property; +define function username-from-uid (uid :: ) => (username :: ) + // I didn't find a platform-independent way to determine the maximum username size so + // we're going with "256 chars should be enough for anyone". LOGIN_NAME_MAX looks + // potentially useful on Linux? MAXLOGNAME on BSD systems? Can't we all just get along? + // POSIX sets a minumum size of 9 (byte?) characters. + let max-username-size = 256; + with-storage (username-buffer, max-username-size) + let status + = (%call-c-function ("system_passwd_username_from_uid") + (uid :: , + username-buffer :: , + username-buffer-size :: ) + => (status :: ) + (integer-as-raw(uid), + primitive-cast-raw-as-pointer(primitive-unwrap-machine-word(username-buffer)), + primitive-cast-integer-as-raw(max-username-size)) + end); + if (zero?(raw-as-integer(status))) + primitive-raw-as-string( + primitive-cast-raw-as-pointer( + primitive-unwrap-machine-word(username-buffer))) + else + error(make(, + format-string: "Can't get username for uid %d", + format-arguments: list(uid))) + end + end with-storage +end function; + define method %file-property (file :: , key == #"size") => (file-size :: ) - let file = %expand-pathname(file); with-stack-stat (st, file) if (primitive-raw-as-boolean (%call-c-function ("system_stat") (path :: , st :: ) @@ -336,7 +371,6 @@ end method %file-property; define method %file-property (file :: , key == #"creation-date") => (creation-date :: ) - let file = %expand-pathname(file); with-stack-stat (st, file) if (primitive-raw-as-boolean (%call-c-function ("system_stat") (path :: , st :: ) @@ -354,7 +388,6 @@ end method %file-property; define method %file-property (file :: , key == #"access-date") => (access-date :: ) - let file = %expand-pathname(file); with-stack-stat (st, file) if (primitive-raw-as-boolean (%call-c-function ("system_stat") (path :: , st :: ) @@ -372,7 +405,6 @@ end method %file-property; define method %file-property (file :: , key == #"modification-date") => (modification-date :: ) - let file = %expand-pathname(file); with-stack-stat (st, file) if (primitive-raw-as-boolean (%call-c-function ("system_stat") (path :: , st :: ) @@ -390,14 +422,13 @@ end method %file-property; define function accessible? (file :: , mode :: ) => (accessible? :: ) - let file = %expand-pathname(file); if (primitive-raw-as-boolean (%call-c-function ("access") (path :: , mode :: ) => (failed? :: ) (primitive-string-as-raw(as(, file)), abstract-integer-as-raw(mode)) end)) let errno = unix-errno(); - unless (errno = $EACCES | errno = $EROFS | errno = $ETXTBSY) + unless (errno == $EACCES | errno == $EROFS | errno == $ETXTBSY) unix-file-error("determine access to", "%s (errno = %=)", file, errno) end; #f @@ -409,7 +440,6 @@ end function accessible?; define function accessible?-setter (new-mode :: , file :: , on? :: ) => (new-mode :: ) - let file = %expand-pathname(file); with-stack-stat (st, file) if (primitive-raw-as-boolean (%call-c-function ("system_stat") (path :: , st :: ) @@ -488,13 +518,11 @@ define method %file-property-setter end method %file-property-setter; -/// define constant $INVALID_DIRECTORY_FD = 0; define constant $NO_MORE_DIRENTRIES = 0; define function %do-directory (f :: , directory :: ) => () - let directory = %expand-pathname(directory); let directory-fd :: = as(, $INVALID_DIRECTORY_FD); block () directory-fd := primitive-wrap-machine-word @@ -556,11 +584,9 @@ define function %do-directory end function %do-directory; -/// define function %create-directory (directory :: ) => (directory :: ) - let directory = %expand-pathname(directory); if (primitive-raw-as-boolean (%call-c-function ("mkdir") (path :: , mode :: ) @@ -576,10 +602,8 @@ define function %create-directory end function %create-directory; -/// define function %delete-directory (directory :: ) => () - let directory = %expand-pathname(directory); if (primitive-raw-as-boolean (%call-c-function ("rmdir") (path :: ) => (failed? :: ) @@ -606,7 +630,6 @@ define function %directory-empty? end function %directory-empty?; -/// define function %home-directory () => (home-directory :: false-or()) let path = environment-variable("HOME"); @@ -615,7 +638,8 @@ define function %home-directory end function %home-directory; -/// +// The size argument is greater than zero but smaller than the length of the pathname +// plus 1. define constant $ERANGE = 34; define function %working-directory @@ -623,7 +647,7 @@ define function %working-directory let bufsiz :: = 128; let errno :: = $ERANGE; block (return) - while (errno = $ERANGE) + while (errno == $ERANGE) let buffer = make(, size: bufsiz, fill: '\0'); if (primitive-machine-word-equal? (primitive-cast-pointer-as-raw(primitive-string-as-raw(buffer)), @@ -645,24 +669,20 @@ define function %working-directory end end function %working-directory; - -/// define function %working-directory-setter (new-working-directory :: ) => (new-working-directory :: ) - let directory = %expand-pathname(new-working-directory); if (primitive-raw-as-boolean (%call-c-function ("chdir") (path :: ) => (failed? :: ) - (primitive-string-as-raw(as(, directory))) + (primitive-string-as-raw(as(, new-working-directory))) end)) - unix-file-error("chdir", "%s", directory) + unix-file-error("chdir", "%s", new-working-directory) end; - directory + new-working-directory end function %working-directory-setter; -/// define variable *temp-directory* = #f; define function %temp-directory @@ -686,9 +706,6 @@ end function %root-directories; define function %create-symbolic-link (target :: , link :: ) => () - let target = %expand-pathname(target); - let link = %expand-pathname(link); - if (primitive-raw-as-boolean (%call-c-function("symlink") (target :: , link :: ) @@ -703,9 +720,6 @@ end function %create-symbolic-link; define function %create-hard-link (target :: , link :: ) => () - let target = %expand-pathname(target); - let link = %expand-pathname(link); - if (primitive-raw-as-boolean (%call-c-function("link") (target :: , link :: ) diff --git a/sources/system/file-system/win32-file-system.dylan b/sources/system/file-system/win32-file-system.dylan index b5b34c6d26..78cbeab5e4 100644 --- a/sources/system/file-system/win32-file-system.dylan +++ b/sources/system/file-system/win32-file-system.dylan @@ -6,10 +6,22 @@ Copyright: Original Code is Copyright (c) 1995-2004 Functional Objects, Inc. License: See License.txt in this distribution for details. Warranty: Distributed WITHOUT WARRANTY OF ANY KIND -/// + +// TODO(cgay): Not yet implemented on Windows. +// https://github.com/dylan-lang/opendylan/issues/1728 define function %expand-pathname (path :: ) => (expanded-path :: ) + path +end function; + +// TODO(cgay): This used to be the implementation of %expand-pathname (above), but the +// expand-pathname generic function has a different purpose. See +// https://github.com/dylan-lang/opendylan/issues/1728#issuecomment-3014101087 for my +// reasoning for keeping this. +define function %absolute-path + (path :: ) + => (full-path :: ) with-stack-path (path-buffer) with-stack-dword (unused-address) let path-length = raw-as-integer @@ -26,13 +38,13 @@ define function %expand-pathname (primitive-unwrap-machine-word(unused-address))) end); if (path-length > $MAX_PATH | path-length = 0) - win32-file-system-error("expand", "%s", path) + win32-file-system-error("GetFullPathNameA", "%s", path) else as(object-class(path), copy-sequence(path-buffer, end: path-length)) end end end -end function %expand-pathname; +end function; /// @@ -65,34 +77,33 @@ define function %shorten-pathname end function %shorten-pathname; -define function %resolve-locator - (locator :: ) - => (resolved-locator :: ) +define function %resolve-file + (path :: ) => (resolved :: ) with-stack-path (path-buffer) - let path-length = raw-as-integer + let new-length = raw-as-integer (%call-c-function ("GetFullPathNameA", c-modifiers: "__stdcall") (fileName :: , bufferLength :: , bufferPtr :: , filePart :: ) => (bufferUsed :: ) - (primitive-string-as-raw(as(, locator)), + (primitive-string-as-raw(path), integer-as-raw($MAX_PATH), primitive-string-as-raw(path-buffer), primitive-cast-raw-as-pointer(integer-as-raw(0))) end); - if (path-length = 0) + if (new-length = 0) if (win32-raw-last-error() = $ERROR_NOT_SUPPORTED) - locator + path else - win32-file-system-error("resolve", "%s", locator) + win32-file-system-error("resolve", "%s", path) end - elseif (path-length > $MAX_PATH) - win32-file-system-error("resolve", "%s", locator) + elseif (new-length > $MAX_PATH) + win32-file-system-error("resolve", "%s", path) elseif (~%file-exists?(locator, #t)) - win32-file-system-error("resolve", "%s", locator) + win32-file-system-error("resolve", "%s", path) else - as(object-class(locator), copy-sequence(path-buffer, end: path-length)) + copy-sequence(path-buffer, end: new-length) end end end function; @@ -101,7 +112,7 @@ end function; define function %file-exists? (file :: , follow-links? :: ) => (exists? :: ) - let file = %expand-pathname(file); + let file = %absolute-path(file); if (primitive-machine-word-not-equal? (%call-c-function ("GetFileAttributesA", c-modifiers: "__stdcall") (path :: ) @@ -147,7 +158,8 @@ end function %file-type; /// define function %link-target - (link :: ) => (target :: ) + (link :: , follow-links? :: ) + => (target :: ) error(make(, format-string: "link-target is not available on this platform", format-arguments: #())) @@ -157,7 +169,7 @@ end function %link-target; /// define function %delete-file (file :: ) => () - let file = %expand-pathname(file); + let file = %absolute-path(file); // NOTE: Turn off the read-only flag or we won't be able to delete the file! %file-property(file, #"writeable?") := #t; unless (primitive-raw-as-boolean @@ -176,8 +188,8 @@ define function %copy-file (source :: , destination :: , #key if-exists :: = #"signal") => () - let source = %expand-pathname(source); - let destination = %expand-pathname(destination); + let source = %absolute-path(source); + let destination = %absolute-path(destination); // NOTE: Contrary to the documentation, CopyFile won't copy over // an existing read-only file so we need to delete it manually. if (if-exists == #"replace" & %file-exists?(destination, #f)) @@ -206,8 +218,8 @@ define function %rename-file (source :: , destination :: , #key if-exists :: = #"signal") => () - let source = %expand-pathname(source); - let destination = %expand-pathname(destination); + let source = %absolute-path(source); + let destination = %absolute-path(destination); // NOTE: We can't use MoveFileEx which provides options to control // the move if the target exists because MoveFileEx isn't implemented // in Windows 95. (When this code was originally written, the @@ -308,7 +320,7 @@ end function writeable?; define method %file-property (file :: , key == #"writeable?") => (writeable? :: ) - let file = %expand-pathname(file); + let file = %absolute-path(file); let attributes = primitive-wrap-machine-word (%call-c-function ("GetFileAttributesA", c-modifiers: "__stdcall") (path :: ) @@ -327,7 +339,7 @@ end method %file-property; define method %file-property-setter (new-writeable? :: , file :: , key == #"writeable?") => (new-writeable? :: ) - let file = %expand-pathname(file); + let file = %absolute-path(file); let attributes = primitive-wrap-machine-word (%call-c-function ("GetFileAttributesA", c-modifiers: "__stdcall") (path :: ) @@ -360,7 +372,7 @@ end method %file-property-setter; define method %file-property (file :: , key == #"executable?") => (executable? :: ) - let file = %expand-pathname(file); + let file = %absolute-path(file); let executable? = primitive-raw-as-boolean (%call-c-function ("SHGetFileInfoA", c-modifiers: "__stdcall") (pszPath :: , @@ -399,7 +411,7 @@ end method %file-property; /// define function %do-directory (f :: , directory :: ) => () - let directory = %expand-pathname(directory); + let directory = %absolute-path(directory); let wild-file = make(, directory: directory, name: "*.*"); let find-handle = primitive-wrap-machine-word(integer-as-raw($INVALID_HANDLE_VALUE)); with-stack-win32-find-data (wfd, directory) @@ -462,7 +474,7 @@ end function %do-directory; define function %create-directory (directory :: ) => (directory :: ) - let directory = %expand-pathname(directory); + let directory = %absolute-path(directory); if (primitive-raw-as-boolean (%call-c-function ("CreateDirectoryA", c-modifiers: "__stdcall") (dirPathname :: , securityAttributes :: ) @@ -480,7 +492,7 @@ end function %create-directory; /// define function %delete-directory (directory :: ) => () - let directory = %expand-pathname(directory); + let directory = %absolute-path(directory); unless (primitive-raw-as-boolean (%call-c-function ("RemoveDirectoryA", c-modifiers: "__stdcall") (dirPathname :: ) @@ -557,7 +569,7 @@ end function %working-directory; define function %working-directory-setter (new-working-directory :: ) => (new-working-directory :: ) - let directory = %expand-pathname(new-working-directory); + let directory = %absolute-path(new-working-directory); unless (primitive-raw-as-boolean (%call-c-function ("SetCurrentDirectoryA", c-modifiers: "__stdcall") (lpPathName :: ) diff --git a/sources/system/library.dylan b/sources/system/library.dylan index 19089014ca..07c5d604ef 100644 --- a/sources/system/library.dylan +++ b/sources/system/library.dylan @@ -10,6 +10,7 @@ define library system use dylan; use common-dylan; use io; + use collections; export operating-system, date, @@ -146,7 +147,7 @@ define module locators file-locator, merge-locators, relative-locator, - resolve-locator, + resolve-locator, // deprecated, use resolve-file simplify-locator, subdirectory-locator; @@ -261,6 +262,7 @@ define module file-system file-exists?, file-type, link-target, + resolve-file, delete-file, copy-file, rename-file, @@ -339,6 +341,7 @@ define module settings-internals end module settings-internals; define module system-internals + use collectors; use common-dylan; use dylan-extensions; use dylan-direct-c-ffi; diff --git a/sources/system/locators/locators.dylan b/sources/system/locators/locators.dylan index 93c13a04e3..3283e04fab 100644 --- a/sources/system/locators/locators.dylan +++ b/sources/system/locators/locators.dylan @@ -208,22 +208,9 @@ define method simplify-locator end end method; -// Check the file system to resolve and expand links, and normalize the path. -// Returns an absolute locator, using the current process's working directory -// to resolve relative locators, or signals . Note that lack -// of an error does not mean that the resolved locator names an existing file, -// but does mean the containing directory exists. In other words, this function -// inherits POSIX `realpath` semantics. -define open generic resolve-locator - (locator :: ) - => (simplified-locator :: ); - -define method resolve-locator - (locator :: ) - => (simplified-locator :: ) - %resolve-locator(locator) -end method; - +// resolve-locator is deprecated (as of 2025.2) in favor of resolve-file, in the +// file-system module. It is fundamentally a file-system operation. +define constant resolve-locator = resolve-file; /// Subdirectory locator diff --git a/sources/system/riscv64-linux-magic-numbers.dylan b/sources/system/riscv64-linux-magic-numbers.dylan index dd410624af..c070de546b 100644 --- a/sources/system/riscv64-linux-magic-numbers.dylan +++ b/sources/system/riscv64-linux-magic-numbers.dylan @@ -7,7 +7,6 @@ License: Public Domain define constant $ENOENT = 2; define constant $EINTR = 4; define constant $EACCES = 13; -define constant $EINVAL = 22; define constant $ETXTBSY = 26; define constant $EROFS = 30; define constant $path-max = 4096; diff --git a/sources/system/tests/file-system.dylan b/sources/system/tests/file-system.dylan index 11c59649d2..6b690717ac 100644 --- a/sources/system/tests/file-system.dylan +++ b/sources/system/tests/file-system.dylan @@ -61,6 +61,40 @@ end; /// File-system function test cases +define test test-expand-pathname () + // expand-pathname on Windows does something different. + // https://github.com/dylan-lang/opendylan/issues/1728 + if ($os-name ~== #"win32") + let user = login-name(); + // login-name() returns #f on GitHub runners. + if (user) + assert-equal(home-directory(), + expand-pathname(concatenate("~", user)), + "expand ~user"); + assert-equal(file-locator(home-directory(), "bar"), + expand-pathname(concatenate("~", user, "/bar")), + "expand ~user/bar"); + assert-equal(home-directory(), + expand-pathname(concatenate("~", user, "/")), + "expand ~user/"); + end; + assert-equal(home-directory(), expand-pathname("~"), "expand ~"); + assert-equal(file-locator(home-directory(), "foo"), + expand-pathname("~/foo"), + "expand ~/foo"); + assert-equal("a/~/c", + as(, expand-pathname("a/~/c")), + "expand a/~/c is no-op"); + assert-equal("a/b/~c", + as(, expand-pathname("a/b/~c")), + "expand a/b/~c is no-op"); + assert-equal("~no-such-luser/foo", + as(, expand-pathname("~no-such-luser/foo"))); + assert-equal("~no-such-luser", + as(, expand-pathname("~no-such-luser"))); + end; +end test; + define test test-file-exists? () let dir = test-temp-directory(); let file = file-locator(dir, "file"); @@ -94,6 +128,25 @@ define test test-create-hard-link () assert-true(file-exists?(new-path)); end; +define test test-link-target () + if ($os-name ~== #"win32") // link-target is not implemented on Windows + let tmp = test-temp-directory(); + let aaa = file-locator(tmp, "aaa"); + let bbb = file-locator(tmp, "bbb"); + let ccc = file-locator(tmp, "ccc"); + let ddd = file-locator(tmp, "ddd"); + write-test-file(ddd, contents: "ddd"); + create-symbolic-link(ddd, ccc); + create-symbolic-link(ccc, bbb); + create-symbolic-link(bbb, aaa); + assert-equal(link-target(aaa), ddd); + assert-equal(link-target(aaa, follow-links?: #f), bbb); + assert-signals(, link-target(ddd), "ddd is not a symbolic link"); + delete-file(ddd); + assert-false(link-target(aaa), "link target does not exist"); + end if; +end test; + define test test-file-type () //---*** Fill this in. end; @@ -131,8 +184,14 @@ define test test-file-properties () end; define test test-file-property () - //---*** Fill this in. -end; + // login-name returns #f on GitHub Ubuntu runners. + if (login-name()) + let tmpdir = test-temp-directory(); + let file1 = file-locator(tmpdir, "file1"); + write-test-file(file1, contents: "abc"); + assert-equal(login-name(), file-property(file1, #"author")); + end; +end test; define test test-file-property-setter () //---*** Fill this in. @@ -142,10 +201,59 @@ define test test-do-directory () //---*** Fill this in. end; -/// directory-contents is NYI currently ... define test test-directory-contents () - //---*** Fill this in. -end; + let tmpdir = test-temp-directory(); + assert-true(empty?(directory-contents(tmpdir))); + let file1 = file-locator(tmpdir, "file1"); + write-test-file(file1); + let dir1 = subdirectory-locator(tmpdir, "dir1"); + create-directory(tmpdir, "dir1"); + let link1 = file-locator(tmpdir, "link1"); + create-symbolic-link(tmpdir.locator-directory, link1); + + // Here we expect link1 to be a file locator, the link itself. + let contents1 = directory-contents(tmpdir); + assert-equal(3, contents1.size); + let count1 = 0; + for (locator in contents1) + select (locator.locator-name by \=) + "file1" => + assert-instance?(, locator); + count1 := count1 + 1; + "dir1" => + assert-instance?(, locator); + count1 := count1 + 1; + "link1" => + assert-instance?(, locator); + assert-equal("link1", locator.locator-name); + count1 := count1 + 1; + otherwise => + assert-true(#f, "unexpected filename in contents1 %=", locator.locator-name); + end; + end; + assert-equal(3, count1, "didn't see all the expected files (1)"); + + // Here we expect link1 to resolve to a directory locator. + let contents2 = directory-contents(tmpdir, resolve-links?: #t); + assert-equal(3, contents2.size); + let count2 = 0; + for (locator in contents2) + select (locator.locator-name by \=) + "file1" => + assert-instance?(, locator); + count2 := count2 + 1; + "dir1" => + assert-instance?(, locator); + count2 := count2 + 1; + tmpdir.locator-directory.locator-name => + assert-instance?(, locator); + count2 := count2 + 1; + otherwise => + assert-true(#f, "unexpected filename in contents2 %=", locator.locator-name); + end; + end; + assert-equal(3, count2, "didn't see all the expected files (2)"); +end test; define test test-create-directory () //---*** Fill this in. @@ -1626,3 +1734,46 @@ define suite file-system-locators-test-suite () test test-; test test-; end suite; + +define test test-resolve-locator () + let tmpdir = test-temp-directory(); + assert-signals(, + resolve-locator(subdirectory-locator(tmpdir, "non-existent"))); + + create-directory(tmpdir, "foo"); + create-directory(tmpdir, "bar"); + let foo = subdirectory-locator(tmpdir, "foo"); + let bar = subdirectory-locator(tmpdir, "bar"); + let foob = subdirectory-locator(foo, "b"); + create-directory(foo, "b"); + let pname = as(, bar); + assert-equal(as(, resolve-locator(bar)), pname); + for (item in list(list(#["foo"], foo), + list(#["bar"], bar), + list(#["foo", "..", "bar"], bar), + list(#["foo", ".."], tmpdir), + list(#["foo", ".", "b", "..", "..", "foo"], foo))) + let (subdirs, want) = apply(values, item); + let orig = apply(subdirectory-locator, tmpdir, subdirs); + let got = resolve-locator(orig); + assert-equal(got, want, format-to-string("resolve-locator(%=) => %=", orig, got)); + end; + + let link1 = file-locator(tmpdir, "link1"); + create-symbolic-link(foo, link1); + assert-equal(resolve-locator(foo), resolve-locator(link1), + "resolve-locator with valid link target"); + + let link2 = file-locator(tmpdir, "link2"); + create-symbolic-link("nonexistent-target", link2); + assert-signals(, resolve-locator(link2), + "resolve-locator with non-existent link target signals"); + + assert-equal(working-directory(), resolve-locator(as(, "."))); + // Not testing ".." here because it would require changing the value of + // working-directory() to a directory that we know has a parent. +end test; + +define suite file-system-test-suite () + test test-resolve-locator; +end suite; diff --git a/sources/system/tests/library.dylan b/sources/system/tests/library.dylan index e8311dec36..3ce7eb3d34 100644 --- a/sources/system/tests/library.dylan +++ b/sources/system/tests/library.dylan @@ -10,6 +10,7 @@ define library system-test-suite use common-dylan; use common-dylan-test-utilities; use io; + use strings; use system; use testworks; @@ -27,6 +28,7 @@ define module system-test-suite test-stream-class }; use streams; use streams-internals; + use strings; use testworks; // System modules to test diff --git a/sources/system/tests/locators.dylan b/sources/system/tests/locators.dylan index 5cc0326ef2..be9b2ad4ad 100644 --- a/sources/system/tests/locators.dylan +++ b/sources/system/tests/locators.dylan @@ -575,33 +575,6 @@ define test test-merge-locators () end; end test; -// TODO(cgay): create a link and verify that resolve-locator respects the -// link. Currently there is no API to create a link. -define test test-resolve-locator () - let tmpdir = test-temp-directory(); - assert-signals(, - resolve-locator(subdirectory-locator(tmpdir, "non-existent"))); - - create-directory(tmpdir, "foo"); - create-directory(tmpdir, "bar"); - let foo = subdirectory-locator(tmpdir, "foo"); - let bar = subdirectory-locator(tmpdir, "bar"); - let foob = subdirectory-locator(foo, "b"); - create-directory(foo, "b"); - let pname = as(, bar); - assert-equal(as(, resolve-locator(bar)), pname); - for (item in list(list(#["foo"], foo), - list(#["bar"], bar), - list(#["foo", "..", "bar"], bar), - list(#["foo", ".."], tmpdir), - list(#["foo", ".", "b", "..", "..", "foo"], foo))) - let (subdirs, want) = apply(values, item); - let orig = apply(subdirectory-locator, tmpdir, subdirs); - let got = resolve-locator(orig); - assert-equal(got, want, format-to-string("resolve-locator(%=) => %=", orig, got)); - end; -end test; - define test test-parse-path () assert-equal(#["x"], parse-path("x")); assert-equal(#["x", "y"], parse-path("x/y")); @@ -649,6 +622,5 @@ define suite more-locators-test-suite () test test-file-locator; test test-relative-locator; test test-merge-locators; - test test-resolve-locator; test test-parse-path; end suite; diff --git a/sources/system/tests/specification.dylan b/sources/system/tests/specification.dylan index 85b4366c74..806e6ad5c3 100644 --- a/sources/system/tests/specification.dylan +++ b/sources/system/tests/specification.dylan @@ -264,6 +264,7 @@ define suite system-test-suite () suite file-system-locators-specification-suite; suite file-system-locators-test-suite; suite file-system-specification-suite; + suite file-system-test-suite; suite more-locators-test-suite; suite operating-system-specification-suite; suite operating-system-test-suite; diff --git a/sources/system/unix-portability.c b/sources/system/unix-portability.c index cd768acd48..7f45a60d03 100644 --- a/sources/system/unix-portability.c +++ b/sources/system/unix-portability.c @@ -10,6 +10,9 @@ #include #include #include +#include +#include + #ifdef __APPLE__ #include @@ -143,3 +146,45 @@ int system_concurrent_thread_count(void) } return (int) count; } + +// Store the homedir associated with `username` into `homedir`. `homedir_size` is the +// size of the `homedir` buffer. Returns 0 on success, -1 on failure. +int system_user_homedir (const char* username, char* homedir, int homedir_size) { + int passwd_bufsize = 0; + if ((passwd_bufsize = sysconf(_SC_GETPW_R_SIZE_MAX)) == -1) { + return -1; + } + char buffer[passwd_bufsize]; + struct passwd pwd; + struct passwd *result = NULL; + if (getpwnam_r(username, &pwd, buffer, passwd_bufsize, &result) != 0 || !result) { + return -1; + } + int len = strlen(pwd.pw_dir); + if (len >= homedir_size) { + return -1; + } + strncpy(homedir, pwd.pw_dir, len); + return 0; +} + +// Store the username associated with `uid` into `username`. `username_size` is the size +// of the `username` buffer. Returns 0 on success, -1 on failure. +int system_passwd_username_from_uid (uid_t uid, char* username, int username_size) { + int passwd_bufsize = 0; + if ((passwd_bufsize = sysconf(_SC_GETPW_R_SIZE_MAX)) == -1) { + return -1; + } + char buffer[passwd_bufsize]; + struct passwd pwd; + struct passwd *result = NULL; + if (getpwuid_r(uid, &pwd, buffer, passwd_bufsize, &result) != 0 || !result) { + return -1; + } + int len = strlen(pwd.pw_name); + if (len >= username_size) { + return -1; + } + strncpy(username, pwd.pw_name, len); + return 0; +} diff --git a/sources/system/x86-freebsd-magic-numbers.dylan b/sources/system/x86-freebsd-magic-numbers.dylan index 4953bd643d..88a903211b 100644 --- a/sources/system/x86-freebsd-magic-numbers.dylan +++ b/sources/system/x86-freebsd-magic-numbers.dylan @@ -7,7 +7,6 @@ License: Public Domain define constant $ENOENT = 2; define constant $EINTR = 4; define constant $EACCES = 13; -define constant $EINVAL = 22; define constant $ETXTBSY = 26; define constant $EROFS = 30; define constant $path-max = 1024; diff --git a/sources/system/x86-linux-magic-numbers.dylan b/sources/system/x86-linux-magic-numbers.dylan index 2235953d25..6ad70f9253 100644 --- a/sources/system/x86-linux-magic-numbers.dylan +++ b/sources/system/x86-linux-magic-numbers.dylan @@ -7,7 +7,6 @@ License: Public Domain define constant $ENOENT = 2; define constant $EINTR = 4; define constant $EACCES = 13; -define constant $EINVAL = 22; define constant $ETXTBSY = 26; define constant $EROFS = 30; define constant $path-max = 4096; diff --git a/sources/system/x86-netbsd-magic-numbers.dylan b/sources/system/x86-netbsd-magic-numbers.dylan index e1911f7878..41c7b31210 100644 --- a/sources/system/x86-netbsd-magic-numbers.dylan +++ b/sources/system/x86-netbsd-magic-numbers.dylan @@ -7,7 +7,6 @@ License: Public Domain define constant $ENOENT = 2; define constant $EINTR = 4; define constant $EACCES = 13; -define constant $EINVAL = 22; define constant $ETXTBSY = 26; define constant $EROFS = 30; define constant $stat-size = 124; diff --git a/sources/system/x86_64-darwin-magic-numbers.dylan b/sources/system/x86_64-darwin-magic-numbers.dylan index bb92619992..92cc30c588 100644 --- a/sources/system/x86_64-darwin-magic-numbers.dylan +++ b/sources/system/x86_64-darwin-magic-numbers.dylan @@ -1,35 +1,33 @@ Module: system-internals License: Public Domain -// WARNING! This file is generated! +// WARNING! This file is generated by running dump-magic-numbers.c! -// Used by file-system/unix-ffi.dylan -define constant $ENOENT = 2; -define constant $EINTR = 4; -define constant $EACCES = 13; -define constant $EINVAL = 22; -define constant $ETXTBSY = 26; -define constant $EROFS = 30; -define constant $path-max = 1024; -define constant $stat-size = 144; -define constant $st-mode-offset = 4; -define constant $st-uid-offset = 16; -define constant $st-gid-offset = 20; -define constant $st-size-offset = 96; -define constant $st-atime-offset = 32; -define constant $st-mtime-offset = 48; -define constant $st-ctime-offset = 64; -define constant $pw-name-offset = 0; -define constant $pw-dir-offset = 48; -define constant $gr-name-offset = 0; +define constant $ENOENT :: = 2; +define constant $EINTR :: = 4; +define constant $EACCES :: = 13; +define constant $ETXTBSY :: = 26; +define constant $EROFS :: = 30; -// Used by unix-date-interface.dylan -define constant $tm-sec-offset = 0; -define constant $tm-min-offset = 4; -define constant $tm-hour-offset = 8; -define constant $tm-mday-offset = 12; -define constant $tm-mon-offset = 16; -define constant $tm-year-offset = 20; -define constant $tm-isdst-offset = 32; -define constant $tm-gmtoff-offset = 40; -define constant $tm-zone-offset = 48; +define constant $path-max :: = 1024; + +define constant $stat-size :: = 144; +define constant $st-mode-offset :: = 4; +define constant $st-uid-offset :: = 16; +define constant $st-gid-offset :: = 20; +define constant $st-size-offset :: = 96; +define constant $st-atime-offset :: = 32; +define constant $st-mtime-offset :: = 48; +define constant $st-ctime-offset :: = 64; + +define constant $gr-name-offset :: = 0; + +define constant $tm-sec-offset :: = 0; +define constant $tm-min-offset :: = 4; +define constant $tm-hour-offset :: = 8; +define constant $tm-mday-offset :: = 12; +define constant $tm-mon-offset :: = 16; +define constant $tm-year-offset :: = 20; +define constant $tm-isdst-offset :: = 32; +define constant $tm-gmtoff-offset :: = 40; +define constant $tm-zone-offset :: = 48; diff --git a/sources/system/x86_64-freebsd-magic-numbers.dylan b/sources/system/x86_64-freebsd-magic-numbers.dylan index 18ccbd5eec..e804903201 100644 --- a/sources/system/x86_64-freebsd-magic-numbers.dylan +++ b/sources/system/x86_64-freebsd-magic-numbers.dylan @@ -7,7 +7,6 @@ License: Public Domain define constant $ENOENT = 2; define constant $EINTR = 4; define constant $EACCES = 13; -define constant $EINVAL = 22; define constant $ETXTBSY = 26; define constant $EROFS = 30; define constant $path-max = 1024; diff --git a/sources/system/x86_64-linux-magic-numbers.dylan b/sources/system/x86_64-linux-magic-numbers.dylan index f63dfc6f1f..66d7be87cb 100644 --- a/sources/system/x86_64-linux-magic-numbers.dylan +++ b/sources/system/x86_64-linux-magic-numbers.dylan @@ -7,7 +7,6 @@ License: Public Domain define constant $ENOENT = 2; define constant $EINTR = 4; define constant $EACCES = 13; -define constant $EINVAL = 22; define constant $ETXTBSY = 26; define constant $EROFS = 30; define constant $path-max = 4096; diff --git a/sources/system/x86_64-netbsd-magic-numbers.dylan b/sources/system/x86_64-netbsd-magic-numbers.dylan index 7cb20fce84..4874aec8cb 100644 --- a/sources/system/x86_64-netbsd-magic-numbers.dylan +++ b/sources/system/x86_64-netbsd-magic-numbers.dylan @@ -7,7 +7,6 @@ License: Public Domain define constant $ENOENT = 2; define constant $EINTR = 4; define constant $EACCES = 13; -define constant $EINVAL = 22; define constant $ETXTBSY = 26; define constant $EROFS = 30; define constant $path-max = 1024;