From 2cb58ba53c954596c0dec7c2ffbcb29a7f53aa15 Mon Sep 17 00:00:00 2001 From: Carl Gay Date: Wed, 25 Jun 2025 19:12:28 -0400 Subject: [PATCH 1/9] system: Improve resolve-locator and directory-contents directory-contents returns a even for a symlink that resolves to a directory. Add a `resolve-links?` keyword to resolve links. This uncovered a bug in resolve-locator such that it would always return a locator of the same class that it was passed, regardless of the file system entity it resolved to. --- .../library-reference/system/file-system.rst | 26 +++-- .../library-reference/system/locators.rst | 2 +- documentation/source/release-notes/2025.2.rst | 16 ++- sources/system/file-system/file-system.dylan | 78 +++++++-------- .../system/file-system/unix-file-system.dylan | 9 +- .../file-system/win32-file-system.dylan | 4 +- sources/system/library.dylan | 2 + sources/system/locators/locators.dylan | 12 ++- sources/system/tests/file-system.dylan | 98 ++++++++++++++++++- sources/system/tests/locators.dylan | 28 ------ sources/system/tests/specification.dylan | 1 + 11 files changed, 187 insertions(+), 89 deletions(-) diff --git a/documentation/source/library-reference/system/file-system.rst b/documentation/source/library-reference/system/file-system.rst index 24a81f7f07..647a0801e5 100644 --- a/documentation/source/library-reference/system/file-system.rst +++ b/documentation/source/library-reference/system/file-system.rst @@ -646,16 +646,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? @@ -841,7 +851,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 +1069,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 :func:`link-target` or :gf:`resolve-locator` on *file* first. + .. type:: The type representing all possible types of a file system entity. @@ -1120,6 +1133,7 @@ File-System module. :seealso: - :func:`create-symbolic-link` + - :gf:`resolve-locator` .. _make: @@ -1315,7 +1329,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..25e0203577 100644 --- a/documentation/source/library-reference/system/locators.rst +++ b/documentation/source/library-reference/system/locators.rst @@ -398,7 +398,7 @@ The locators Module :signature: resolve-locator (locator) => (resolved-locator) :parameter locator: An instance of :class:``. - :value simplified-locator: An instance of :class:``. + :value resolved-locator: An instance of :class:``. .. generic-function:: string-as-locator diff --git a/documentation/source/release-notes/2025.2.rst b/documentation/source/release-notes/2025.2.rst index 2c8dca172f..6314b5afd8 100644 --- a/documentation/source/release-notes/2025.2.rst +++ b/documentation/source/release-notes/2025.2.rst @@ -23,8 +23,20 @@ Compiler Tools ===== -Library Updates -=============== +Libraries +========= + +System +------ + +* :gf:`resolve-locator` now returns the correct class of locator, :class:`` + or :class:``, depending on the actual file type of the fully + resolved locator. 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-locator`. See the + :gf:`directory-contents` documentation for caveats. Contributors ============ diff --git a/sources/system/file-system/file-system.dylan b/sources/system/file-system/file-system.dylan index 73f694a78f..ac798e7d4a 100644 --- a/sources/system/file-system/file-system.dylan +++ b/sources/system/file-system/file-system.dylan @@ -316,37 +316,51 @@ 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; /// +// 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 +388,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 +514,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 +529,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-file-system.dylan b/sources/system/file-system/unix-file-system.dylan index 38f48b29d9..b91eafc51d 100644 --- a/sources/system/file-system/unix-file-system.dylan +++ b/sources/system/file-system/unix-file-system.dylan @@ -77,7 +77,7 @@ end function %shorten-pathname; define function %resolve-locator (locator :: ) - => (resolved-locator :: ) + => (resolved-locator :: ) let path = as(, locator); with-storage (resolved-path, $path-max) let result @@ -91,10 +91,9 @@ 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 diff --git a/sources/system/file-system/win32-file-system.dylan b/sources/system/file-system/win32-file-system.dylan index b5b34c6d26..a2ac97c6cb 100644 --- a/sources/system/file-system/win32-file-system.dylan +++ b/sources/system/file-system/win32-file-system.dylan @@ -67,7 +67,7 @@ end function %shorten-pathname; define function %resolve-locator (locator :: ) - => (resolved-locator :: ) + => (resolved-locator :: ) with-stack-path (path-buffer) let path-length = raw-as-integer (%call-c-function ("GetFullPathNameA", c-modifiers: "__stdcall") @@ -92,7 +92,7 @@ define function %resolve-locator elseif (~%file-exists?(locator, #t)) win32-file-system-error("resolve", "%s", locator) else - as(object-class(locator), copy-sequence(path-buffer, end: path-length)) + copy-sequence(path-buffer, end: path-length) end end end function; diff --git a/sources/system/library.dylan b/sources/system/library.dylan index 19089014ca..e32444cfa5 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, @@ -339,6 +340,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..6541635d76 100644 --- a/sources/system/locators/locators.dylan +++ b/sources/system/locators/locators.dylan @@ -216,12 +216,18 @@ end method; // inherits POSIX `realpath` semantics. define open generic resolve-locator (locator :: ) - => (simplified-locator :: ); + => (resolved-locator :: ); define method resolve-locator (locator :: ) - => (simplified-locator :: ) - %resolve-locator(locator) + => (resolved-locator :: ) + let resolved = %resolve-locator(locator); + let class = if (file-type(resolved) == #"directory") + + else + + end; + as(class, resolved) end method; diff --git a/sources/system/tests/file-system.dylan b/sources/system/tests/file-system.dylan index 11c59649d2..81902659f1 100644 --- a/sources/system/tests/file-system.dylan +++ b/sources/system/tests/file-system.dylan @@ -142,10 +142,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 +1675,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/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; From 8dc92d07ca13b040af71ac7f630f60e5ac42a8f3 Mon Sep 17 00:00:00 2001 From: Carl Gay Date: Wed, 25 Jun 2025 19:20:27 -0400 Subject: [PATCH 2/9] package: Update deft dependency to v0.13 --- dylan-package.json | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) 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", From 3d26ff5c9e3dc4745bfaefe819e57060df4881e4 Mon Sep 17 00:00:00 2001 From: Carl Gay Date: Thu, 26 Jun 2025 11:23:27 -0400 Subject: [PATCH 3/9] system: Replace resolve-locator:locators with resolve-file:file-system This is fundamentally a file-system operation so it was a mistake to put it in the locators module in the first place. The "file" terminology matches that used in most other file-system exports. I've switched the way arguments are passed to the internal `%resolve-file` function here. The internal function only deals with strings, instead of locators. This avoids some unnecessary conversions when the user passes a string. --- .../library-reference/system/file-system.rst | 27 +++++++++++++++++-- .../library-reference/system/locators.rst | 17 +++--------- documentation/source/release-notes/2025.2.rst | 15 ++++++----- sources/system/file-system/file-system.dylan | 25 +++++++++++++++++ .../system/file-system/unix-file-system.dylan | 6 ++--- .../file-system/win32-file-system.dylan | 23 ++++++++-------- sources/system/library.dylan | 3 ++- sources/system/locators/locators.dylan | 25 +++-------------- 8 files changed, 80 insertions(+), 61 deletions(-) diff --git a/documentation/source/library-reference/system/file-system.rst b/documentation/source/library-reference/system/file-system.rst index 647a0801e5..29af871e4c 100644 --- a/documentation/source/library-reference/system/file-system.rst +++ b/documentation/source/library-reference/system/file-system.rst @@ -80,6 +80,7 @@ properties of the file. - :func:`file-property` - :func:`file-type` - :func:`link-target` +- :gf:`resolve-file` File system locators -------------------- @@ -1070,7 +1071,7 @@ File-System module. another file or directory. This function does not resolve symbolic links. To find the file type of the link - target call :func:`link-target` or :gf:`resolve-locator` on *file* first. + target call :func:`link-target` or :gf:`resolve-file` on *file* first. .. type:: @@ -1133,7 +1134,29 @@ File-System module. :seealso: - :func:`create-symbolic-link` - - :gf:`resolve-locator` + - :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: diff --git a/documentation/source/library-reference/system/locators.rst b/documentation/source/library-reference/system/locators.rst index 25e0203577..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)``. +.. constant:: resolve-locator - :signature: resolve-locator (locator) => (resolved-locator) - - :parameter locator: An instance of :class:``. - :value resolved-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 6314b5afd8..c1855ff573 100644 --- a/documentation/source/release-notes/2025.2.rst +++ b/documentation/source/release-notes/2025.2.rst @@ -29,14 +29,17 @@ Libraries System ------ -* :gf:`resolve-locator` now returns the correct class of locator, :class:`` - or :class:``, depending on the actual file type of the fully - resolved locator. 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:`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-locator`. See the - :gf:`directory-contents` documentation for caveats. + symbolic links are resolved as with :gf:`resolve-file`. Contributors ============ diff --git a/sources/system/file-system/file-system.dylan b/sources/system/file-system/file-system.dylan index ac798e7d4a..2f1d627401 100644 --- a/sources/system/file-system/file-system.dylan +++ b/sources/system/file-system/file-system.dylan @@ -355,6 +355,31 @@ define method directory-contents 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). diff --git a/sources/system/file-system/unix-file-system.dylan b/sources/system/file-system/unix-file-system.dylan index b91eafc51d..1d45d65faa 100644 --- a/sources/system/file-system/unix-file-system.dylan +++ b/sources/system/file-system/unix-file-system.dylan @@ -75,10 +75,8 @@ 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( diff --git a/sources/system/file-system/win32-file-system.dylan b/sources/system/file-system/win32-file-system.dylan index a2ac97c6cb..cd05cc36ea 100644 --- a/sources/system/file-system/win32-file-system.dylan +++ b/sources/system/file-system/win32-file-system.dylan @@ -65,34 +65,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 - copy-sequence(path-buffer, end: path-length) + copy-sequence(path-buffer, end: new-length) end end end function; diff --git a/sources/system/library.dylan b/sources/system/library.dylan index e32444cfa5..07c5d604ef 100644 --- a/sources/system/library.dylan +++ b/sources/system/library.dylan @@ -147,7 +147,7 @@ define module locators file-locator, merge-locators, relative-locator, - resolve-locator, + resolve-locator, // deprecated, use resolve-file simplify-locator, subdirectory-locator; @@ -262,6 +262,7 @@ define module file-system file-exists?, file-type, link-target, + resolve-file, delete-file, copy-file, rename-file, diff --git a/sources/system/locators/locators.dylan b/sources/system/locators/locators.dylan index 6541635d76..3283e04fab 100644 --- a/sources/system/locators/locators.dylan +++ b/sources/system/locators/locators.dylan @@ -208,28 +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 :: ) - => (resolved-locator :: ); - -define method resolve-locator - (locator :: ) - => (resolved-locator :: ) - let resolved = %resolve-locator(locator); - let class = if (file-type(resolved) == #"directory") - - else - - end; - as(class, resolved) -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 From a89d0f100e142c564bd17f8ec75b8080ed1bc4c6 Mon Sep 17 00:00:00 2001 From: Carl Gay Date: Thu, 26 Jun 2025 16:29:18 -0400 Subject: [PATCH 4/9] system: Cleanup == instead of =, fix comments --- .../system/file-system/unix-file-system.dylan | 48 ++++++++----------- 1 file changed, 19 insertions(+), 29 deletions(-) diff --git a/sources/system/file-system/unix-file-system.dylan b/sources/system/file-system/unix-file-system.dylan index 1d45d65faa..a0f6424e35 100644 --- a/sources/system/file-system/unix-file-system.dylan +++ b/sources/system/file-system/unix-file-system.dylan @@ -75,6 +75,7 @@ define function %shorten-pathname path end function %shorten-pathname; + define function %resolve-file (path :: ) => (resolved :: ) with-storage (resolved-path, $path-max) @@ -98,6 +99,7 @@ define function %resolve-file end with-storage end function; + define function %file-exists? (file :: , follow-links? :: ) => (exists? :: ) @@ -122,9 +124,9 @@ define function %file-exists? end end function; -/// + define function %file-type - (file :: , #key if-not-exists = #f) + (file :: , #key if-does-not-exist = unsupplied()) => (file-type :: ) let file = %expand-pathname(file); with-stack-stat (st, file) @@ -134,14 +136,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" @@ -150,12 +152,12 @@ 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'); + while (%file-type(link, if-does-not-exist: #f) == #"link") + let bufsize = 8192; + let buffer = make(, size: bufsize, fill: '\0'); let count = raw-as-integer(%call-c-function ("readlink") (path :: , buffer :: , @@ -163,10 +165,10 @@ define function %link-target => (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) + if (count == -1) + unless (unix-errno() == $ENOENT | unix-errno() == $EINVAL) unix-file-error("readlink", "%s", link) end else @@ -178,7 +180,6 @@ define function %link-target end function %link-target; -/// define function %delete-file (file :: ) => () let file = %expand-pathname(file); @@ -192,9 +193,7 @@ 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") @@ -222,7 +221,6 @@ define function %copy-file end function %copy-file; -/// define function %rename-file (source :: , destination :: , #Key if-exists :: = #"signal") @@ -248,8 +246,6 @@ define function %rename-file end end function %rename-file; - -/// define function %file-properties (file :: ) => (properties :: ) @@ -394,7 +390,7 @@ define function accessible? (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 @@ -485,7 +481,6 @@ define method %file-property-setter end method %file-property-setter; -/// define constant $INVALID_DIRECTORY_FD = 0; define constant $NO_MORE_DIRENTRIES = 0; @@ -553,7 +548,6 @@ define function %do-directory end function %do-directory; -/// define function %create-directory (directory :: ) => (directory :: ) @@ -573,7 +567,6 @@ define function %create-directory end function %create-directory; -/// define function %delete-directory (directory :: ) => () let directory = %expand-pathname(directory); @@ -603,7 +596,6 @@ define function %directory-empty? end function %directory-empty?; -/// define function %home-directory () => (home-directory :: false-or()) let path = environment-variable("HOME"); @@ -612,7 +604,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 @@ -620,7 +613,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)), @@ -642,8 +635,6 @@ define function %working-directory end end function %working-directory; - -/// define function %working-directory-setter (new-working-directory :: ) => (new-working-directory :: ) @@ -659,7 +650,6 @@ define function %working-directory-setter end function %working-directory-setter; -/// define variable *temp-directory* = #f; define function %temp-directory From 138105a22b9b7823bf08d0b9d04b3ed027a94ad9 Mon Sep 17 00:00:00 2001 From: Carl Gay Date: Fri, 27 Jun 2025 16:40:37 -0400 Subject: [PATCH 5/9] system: Improve expand-pathname * Unix: Do not call expand-pathname from other file-system APIs. Username expansion should only be done explicitly by user code. * Unix: Fixed bug: expand-pathname("~") didn't work because "~" is turned into a file locator and %expand-pathname only handled directory locators. Same for "~user". * Windows: Rename %expand-pathname to %absolute-path (which is apparently what it was being used for) and re-implement %expand-pathname as a no-op. * Add a test. * Update documentation. Removed the method docs because they added no information over what the generic-function doc said. --- .../library-reference/system/file-system.rst | 29 +++-- sources/system/file-system/file-system.dylan | 8 +- .../system/file-system/unix-file-system.dylan | 122 ++++++++---------- .../file-system/win32-file-system.dylan | 44 ++++--- sources/system/tests/file-system.dylan | 30 +++++ 5 files changed, 136 insertions(+), 97 deletions(-) diff --git a/documentation/source/library-reference/system/file-system.rst b/documentation/source/library-reference/system/file-system.rst index 29af871e4c..c1c4d92212 100644 --- a/documentation/source/library-reference/system/file-system.rst +++ b/documentation/source/library-reference/system/file-system.rst @@ -769,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 diff --git a/sources/system/file-system/file-system.dylan b/sources/system/file-system/file-system.dylan index 2f1d627401..59aacbb41f 100644 --- a/sources/system/file-system/file-system.dylan +++ b/sources/system/file-system/file-system.dylan @@ -84,7 +84,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 :: ) diff --git a/sources/system/file-system/unix-file-system.dylan b/sources/system/file-system/unix-file-system.dylan index a0f6424e35..9cdfea3a97 100644 --- a/sources/system/file-system/unix-file-system.dylan +++ b/sources/system/file-system/unix-file-system.dylan @@ -7,43 +7,35 @@ 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); + let path = locator-path(dir); + let name = ~empty?(path) & path[0]; + if (~locator-relative?(dir) + | ~instance?(name, ) + | name.empty? + | name[0] ~== '~') + dir + else + let user = case + name = "~" => login-name(); + otherwise => copy-sequence(name, 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)); + (primitive-string-as-raw(user)) + end)); if (primitive-machine-word-equal?(primitive-unwrap-machine-word(passwd), integer-as-raw(0))) dir else let homedir = as(, passwd-dir(passwd)); - return(merge-locators(make(, - path: copy-sequence(elements, start: 1), - relative?: #t), - homedir)) + merge-locators(make(, + path: copy-sequence(path, start: 1), + relative?: #t), + homedir) end end end method; @@ -51,22 +43,46 @@ 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 passwd = primitive-wrap-machine-word + (primitive-cast-pointer-as-raw + (%call-c-function ("getpwnam") + (name :: ) => (passwd :: ) + (primitive-string-as-raw(user)) + end)); + if (primitive-machine-word-equal?(primitive-unwrap-machine-word(passwd), + integer-as-raw(0))) + unix-file-error("get user homedir", "for %s", user); + else + as(, passwd-dir(passwd)) + end + end end end method; -define method %expand-pathname - (path :: ) => (expanded-path :: ) - path -end method; - // No-op implementation for Windows-only feature. define function %shorten-pathname @@ -103,7 +119,6 @@ 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?) @@ -128,7 +143,6 @@ end function; define function %file-type (file :: , #key if-does-not-exist = unsupplied()) => (file-type :: ) - let file = %expand-pathname(file); with-stack-stat (st, file) if (primitive-raw-as-boolean (%call-c-function ("system_lstat") (path :: , st :: ) @@ -154,7 +168,6 @@ end function %file-type; define function %link-target (link :: ) => (target :: ) - let link = %expand-pathname(link); while (%file-type(link, if-does-not-exist: #f) == #"link") let bufsize = 8192; let buffer = make(, size: bufsize, fill: '\0'); @@ -182,7 +195,6 @@ 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? :: ) @@ -198,8 +210,6 @@ 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,8 +235,6 @@ 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) @@ -249,7 +257,6 @@ 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 @@ -283,7 +290,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 :: ) @@ -311,7 +317,6 @@ end method %file-property; 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 :: ) @@ -329,7 +334,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 :: ) @@ -347,7 +351,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 :: ) @@ -365,7 +368,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 :: ) @@ -383,7 +385,6 @@ 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? :: ) @@ -402,7 +403,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 :: ) @@ -486,7 +486,6 @@ 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 @@ -551,7 +550,6 @@ 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 :: ) @@ -569,7 +567,6 @@ 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? :: ) @@ -638,15 +635,14 @@ 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; @@ -673,9 +669,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 :: ) @@ -690,9 +683,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 cd05cc36ea..9799f23e76 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; /// @@ -100,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 :: ) @@ -156,7 +168,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 @@ -175,8 +187,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)) @@ -205,8 +217,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 @@ -307,7 +319,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 :: ) @@ -326,7 +338,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 :: ) @@ -359,7 +371,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 :: , @@ -398,7 +410,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) @@ -461,7 +473,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 :: ) @@ -479,7 +491,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 :: ) @@ -556,7 +568,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/tests/file-system.dylan b/sources/system/tests/file-system.dylan index 81902659f1..b8400f3766 100644 --- a/sources/system/tests/file-system.dylan +++ b/sources/system/tests/file-system.dylan @@ -61,6 +61,36 @@ 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"); + end; +end test; + define test test-file-exists? () let dir = test-temp-directory(); let file = file-locator(dir, "file"); From a76e8d7b537b3ee5e7a20bf2f6137f0c164bd0b6 Mon Sep 17 00:00:00 2001 From: Carl Gay Date: Mon, 30 Jun 2025 15:55:44 -0400 Subject: [PATCH 6/9] system: Use getpwnam_r on Unix platforms * Also adds a release note for expand-pathname --- documentation/source/release-notes/2025.2.rst | 13 ++++ sources/system/dump-magic-numbers.c | 3 +- sources/system/file-system/unix-ffi.dylan | 7 -- .../system/file-system/unix-file-system.dylan | 67 +++++++++++-------- sources/system/tests/file-system.dylan | 4 ++ sources/system/unix-portability.c | 24 +++++++ .../system/x86_64-darwin-magic-numbers.dylan | 3 +- 7 files changed, 81 insertions(+), 40 deletions(-) diff --git a/documentation/source/release-notes/2025.2.rst b/documentation/source/release-notes/2025.2.rst index c1855ff573..c554580bd6 100644 --- a/documentation/source/release-notes/2025.2.rst +++ b/documentation/source/release-notes/2025.2.rst @@ -41,5 +41,18 @@ System * :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`. + Contributors ============ diff --git a/sources/system/dump-magic-numbers.c b/sources/system/dump-magic-numbers.c index 171a3b54c5..642f3bbd9c 100644 --- a/sources/system/dump-magic-numbers.c +++ b/sources/system/dump-magic-numbers.c @@ -25,7 +25,7 @@ main(void) { printf("Module: system-internals\n"); printf("License: Public Domain\n"); - printf("\n// WARNING! This file is generated!\n"); + printf("\n// WARNING! This file is generated by running dump-magic-numbers.c!\n"); PRINT_USEDBY("file-system/unix-ffi.dylan"); @@ -48,7 +48,6 @@ main(void) { 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"); diff --git a/sources/system/file-system/unix-ffi.dylan b/sources/system/file-system/unix-ffi.dylan index 77ae98caac..e95e716c8f 100644 --- a/sources/system/file-system/unix-ffi.dylan +++ b/sources/system/file-system/unix-ffi.dylan @@ -99,13 +99,6 @@ define inline-only function passwd-name (passwd :: ) => (name :: < 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 diff --git a/sources/system/file-system/unix-file-system.dylan b/sources/system/file-system/unix-file-system.dylan index 9cdfea3a97..2f35af0aa4 100644 --- a/sources/system/file-system/unix-file-system.dylan +++ b/sources/system/file-system/unix-file-system.dylan @@ -17,25 +17,18 @@ define method %expand-pathname | name[0] ~== '~') dir else - let user = case - name = "~" => login-name(); - otherwise => copy-sequence(name, start: 1); - end; - let passwd = primitive-wrap-machine-word - (primitive-cast-pointer-as-raw - (%call-c-function ("getpwnam") - (name :: ) => (passwd :: ) - (primitive-string-as-raw(user)) - end)); - if (primitive-machine-word-equal?(primitive-unwrap-machine-word(passwd), - integer-as-raw(0))) - dir + 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)); - merge-locators(make(, - path: copy-sequence(path, 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; @@ -54,7 +47,7 @@ define method %expand-pathname extension: locator-extension(file)) end elseif (locator-extension(file)) - file // ~foo.bar ? + file // ~foo.bar else // 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 @@ -67,22 +60,37 @@ define method %expand-pathname home-directory() else let user = copy-sequence(base, start: 1); - let passwd = primitive-wrap-machine-word - (primitive-cast-pointer-as-raw - (%call-c-function ("getpwnam") - (name :: ) => (passwd :: ) - (primitive-string-as-raw(user)) - end)); - if (primitive-machine-word-equal?(primitive-unwrap-machine-word(passwd), - integer-as-raw(0))) - unix-file-error("get user homedir", "for %s", user); + let homedir = user-home-directory(user); + if (homedir) + as(, homedir) else - as(, passwd-dir(passwd)) + file // ~no-such-user end end end 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. define function %shorten-pathname @@ -299,6 +307,7 @@ define method %file-property end)) unix-file-error("get the author of", "%s", file) end; + // TODO(cgay): use getpwuid_r, see system_user_homedir let passwd = primitive-wrap-machine-word (primitive-cast-pointer-as-raw (%call-c-function ("getpwuid") diff --git a/sources/system/tests/file-system.dylan b/sources/system/tests/file-system.dylan index b8400f3766..251942f176 100644 --- a/sources/system/tests/file-system.dylan +++ b/sources/system/tests/file-system.dylan @@ -88,6 +88,10 @@ define test test-expand-pathname () 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; diff --git a/sources/system/unix-portability.c b/sources/system/unix-portability.c index cd768acd48..2c7670314c 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,24 @@ int system_concurrent_thread_count(void) } return (int) count; } + +// Store the homedir associated with `username` into `homedir`. Return 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; +} diff --git a/sources/system/x86_64-darwin-magic-numbers.dylan b/sources/system/x86_64-darwin-magic-numbers.dylan index bb92619992..89a0abd6ff 100644 --- a/sources/system/x86_64-darwin-magic-numbers.dylan +++ b/sources/system/x86_64-darwin-magic-numbers.dylan @@ -1,7 +1,7 @@ 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; @@ -20,7 +20,6 @@ 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; // Used by unix-date-interface.dylan From c29f6402eb54da8e6a5ea14fec0a306deb00751b Mon Sep 17 00:00:00 2001 From: Carl Gay Date: Mon, 30 Jun 2025 20:57:51 -0400 Subject: [PATCH 7/9] system: Remove obfuscation from dump-magic-numbers.c The macros were written to save a few characters rather than for clarity and searchability (i.e. grep). The "used by" comments could easily get out of date so I removed them. I added type specs to each constant because it seems like it can't hurt. --- sources/system/dump-magic-numbers.c | 71 +++++++++---------- .../system/x86_64-darwin-magic-numbers.dylan | 58 +++++++-------- 2 files changed, 65 insertions(+), 64 deletions(-) diff --git a/sources/system/dump-magic-numbers.c b/sources/system/dump-magic-numbers.c index 642f3bbd9c..5e7fde5560 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) { @@ -27,42 +25,43 @@ main(void) { printf("\n// WARNING! This file is generated by running dump-magic-numbers.c!\n"); - PRINT_USEDBY("file-system/unix-ffi.dylan"); + printf("\n"); + 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(ENOENT, "ENOENT"); - PRINT_CONSTANT(EINTR, "EINTR"); - PRINT_CONSTANT(EACCES, "EACCES"); - PRINT_CONSTANT(EINVAL, "EINVAL"); - PRINT_CONSTANT(ETXTBSY, "ETXTBSY"); - PRINT_CONSTANT(EROFS, "EROFS"); + printf("\n"); + PRINT_CONSTANT(PATH_MAX, "$path-max"); - 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"); - 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"); + printf("\n"); + PRINT_OFFSETOF(struct passwd, pw_name, "$pw-name-offset"); - PRINT_OFFSETOF(struct passwd, pw_name, "pw-name"); + printf("\n"); + PRINT_OFFSETOF(struct group, gr_name, "$gr-name-offset"); - 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"); + 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/x86_64-darwin-magic-numbers.dylan b/sources/system/x86_64-darwin-magic-numbers.dylan index 89a0abd6ff..e3034dfc63 100644 --- a/sources/system/x86_64-darwin-magic-numbers.dylan +++ b/sources/system/x86_64-darwin-magic-numbers.dylan @@ -3,32 +3,34 @@ License: Public Domain // 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 $gr-name-offset = 0; +define constant $ENOENT :: = 2; +define constant $EINTR :: = 4; +define constant $EACCES :: = 13; +define constant $EINVAL :: = 22; +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 $pw-name-offset :: = 0; + +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; From 31a6028953e0beb94980391b6f02966a366859b2 Mon Sep 17 00:00:00 2001 From: Carl Gay Date: Mon, 30 Jun 2025 21:41:14 -0400 Subject: [PATCH 8/9] system: Use getpwuid_r for file-property(file, #"author") --- sources/system/dump-magic-numbers.c | 3 -- sources/system/file-system/unix-ffi.dylan | 8 ---- .../system/file-system/unix-file-system.dylan | 44 +++++++++++++------ sources/system/tests/file-system.dylan | 10 ++++- sources/system/unix-portability.c | 25 ++++++++++- .../system/x86_64-darwin-magic-numbers.dylan | 2 - 6 files changed, 62 insertions(+), 30 deletions(-) diff --git a/sources/system/dump-magic-numbers.c b/sources/system/dump-magic-numbers.c index 5e7fde5560..6b79b8f549 100644 --- a/sources/system/dump-magic-numbers.c +++ b/sources/system/dump-magic-numbers.c @@ -46,9 +46,6 @@ main(void) { PRINT_OFFSETOF(struct stat, st_mtime, "$st-mtime-offset"); PRINT_OFFSETOF(struct stat, st_ctime, "$st-ctime-offset"); - printf("\n"); - PRINT_OFFSETOF(struct passwd, pw_name, "$pw-name-offset"); - printf("\n"); PRINT_OFFSETOF(struct group, gr_name, "$gr-name-offset"); diff --git a/sources/system/file-system/unix-ffi.dylan b/sources/system/file-system/unix-ffi.dylan index e95e716c8f..97800d5451 100644 --- a/sources/system/file-system/unix-ffi.dylan +++ b/sources/system/file-system/unix-ffi.dylan @@ -92,14 +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 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 2f35af0aa4..2b7e90ca06 100644 --- a/sources/system/file-system/unix-file-system.dylan +++ b/sources/system/file-system/unix-file-system.dylan @@ -307,22 +307,40 @@ define method %file-property end)) unix-file-error("get the author of", "%s", file) end; - // TODO(cgay): use getpwuid_r, see system_user_homedir - 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 :: ) diff --git a/sources/system/tests/file-system.dylan b/sources/system/tests/file-system.dylan index 251942f176..55fd0f7460 100644 --- a/sources/system/tests/file-system.dylan +++ b/sources/system/tests/file-system.dylan @@ -165,8 +165,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. diff --git a/sources/system/unix-portability.c b/sources/system/unix-portability.c index 2c7670314c..7f45a60d03 100644 --- a/sources/system/unix-portability.c +++ b/sources/system/unix-portability.c @@ -147,8 +147,8 @@ int system_concurrent_thread_count(void) return (int) count; } -// Store the homedir associated with `username` into `homedir`. Return 0 on success, -// -1 on failure. +// 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) { @@ -167,3 +167,24 @@ int system_user_homedir (const char* username, char* homedir, int homedir_size) 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_64-darwin-magic-numbers.dylan b/sources/system/x86_64-darwin-magic-numbers.dylan index e3034dfc63..6fbc522524 100644 --- a/sources/system/x86_64-darwin-magic-numbers.dylan +++ b/sources/system/x86_64-darwin-magic-numbers.dylan @@ -21,8 +21,6 @@ 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 $gr-name-offset :: = 0; define constant $tm-sec-offset :: = 0; From 048e1b9ad87e7dff27135cc9c7c4e6402e95a8fa Mon Sep 17 00:00:00 2001 From: Carl Gay Date: Sat, 5 Jul 2025 15:46:22 -0400 Subject: [PATCH 9/9] system: Fix infinite loop in link-target (on Unix) Also added `follow-links?` keyword argument and a test. `$EINVAL` became unused and started causing a warning. I removed it from *-magic-numbers.dylan for all platforms without testing since it's not exported and all Unixen share the same implementation of link-target, which was the only place it was used. Fixes #1408 --- .../library-reference/system/file-system.rst | 32 ++++++++++++----- documentation/source/release-notes/2025.2.rst | 6 ++++ .../system/aarch64-linux-magic-numbers.dylan | 1 - sources/system/arm-linux-magic-numbers.dylan | 1 - sources/system/dump-magic-numbers.c | 1 - sources/system/file-system/file-system.dylan | 25 +++++++++---- .../system/file-system/unix-file-system.dylan | 36 ++++++++++++------- .../file-system/win32-file-system.dylan | 3 +- .../system/riscv64-linux-magic-numbers.dylan | 1 - sources/system/tests/file-system.dylan | 19 ++++++++++ sources/system/tests/library.dylan | 2 ++ .../system/x86-freebsd-magic-numbers.dylan | 1 - sources/system/x86-linux-magic-numbers.dylan | 1 - sources/system/x86-netbsd-magic-numbers.dylan | 1 - .../system/x86_64-darwin-magic-numbers.dylan | 1 - .../system/x86_64-freebsd-magic-numbers.dylan | 1 - .../system/x86_64-linux-magic-numbers.dylan | 1 - .../system/x86_64-netbsd-magic-numbers.dylan | 1 - 18 files changed, 94 insertions(+), 40 deletions(-) diff --git a/documentation/source/library-reference/system/file-system.rst b/documentation/source/library-reference/system/file-system.rst index c1c4d92212..b33ea17479 100644 --- a/documentation/source/library-reference/system/file-system.rst +++ b/documentation/source/library-reference/system/file-system.rst @@ -79,7 +79,7 @@ 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 @@ -1072,7 +1072,7 @@ File-System module. another file or directory. This function does not resolve symbolic links. To find the file type of the link - target call :func:`link-target` or :gf:`resolve-file` on *file* first. + target call :gf:`link-target` or :gf:`resolve-file` on *file* first. .. type:: @@ -1120,17 +1120,33 @@ 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: @@ -1314,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` diff --git a/documentation/source/release-notes/2025.2.rst b/documentation/source/release-notes/2025.2.rst index c554580bd6..d25283253b 100644 --- a/documentation/source/release-notes/2025.2.rst +++ b/documentation/source/release-notes/2025.2.rst @@ -54,5 +54,11 @@ System 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/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 6b79b8f549..b630e70b67 100644 --- a/sources/system/dump-magic-numbers.c +++ b/sources/system/dump-magic-numbers.c @@ -29,7 +29,6 @@ main(void) { PRINT_CONSTANT(ENOENT, "$ENOENT"); PRINT_CONSTANT(EINTR, "$EINTR"); PRINT_CONSTANT(EACCES, "$EACCES"); - PRINT_CONSTANT(EINVAL, "$EINVAL"); PRINT_CONSTANT(ETXTBSY, "$ETXTBSY"); PRINT_CONSTANT(EROFS, "$EROFS"); diff --git a/sources/system/file-system/file-system.dylan b/sources/system/file-system/file-system.dylan index 59aacbb41f..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"); @@ -144,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; diff --git a/sources/system/file-system/unix-file-system.dylan b/sources/system/file-system/unix-file-system.dylan index 2b7e90ca06..629b3f72ac 100644 --- a/sources/system/file-system/unix-file-system.dylan +++ b/sources/system/file-system/unix-file-system.dylan @@ -150,7 +150,7 @@ end function; define function %file-type (file :: , #key if-does-not-exist = unsupplied()) - => (file-type :: ) + => (file-type :: ) with-stack-stat (st, file) if (primitive-raw-as-boolean (%call-c-function ("system_lstat") (path :: , st :: ) @@ -175,11 +175,12 @@ end function %file-type; define function %link-target - (link :: ) => (target :: ) - while (%file-type(link, if-does-not-exist: #f) == #"link") - let bufsize = 8192; + (link :: , follow-links? :: ) + => (target :: false-or()) + iterate loop (link = link) + let bufsize = $path-max; let buffer = make(, size: bufsize, fill: '\0'); - let count + let length = raw-as-integer(%call-c-function ("readlink") (path :: , buffer :: , bufsize :: ) @@ -188,16 +189,25 @@ define function %link-target primitive-string-as-raw(buffer), 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; diff --git a/sources/system/file-system/win32-file-system.dylan b/sources/system/file-system/win32-file-system.dylan index 9799f23e76..78cbeab5e4 100644 --- a/sources/system/file-system/win32-file-system.dylan +++ b/sources/system/file-system/win32-file-system.dylan @@ -158,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: #())) 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 55fd0f7460..6b690717ac 100644 --- a/sources/system/tests/file-system.dylan +++ b/sources/system/tests/file-system.dylan @@ -128,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; 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/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 6fbc522524..92cc30c588 100644 --- a/sources/system/x86_64-darwin-magic-numbers.dylan +++ b/sources/system/x86_64-darwin-magic-numbers.dylan @@ -6,7 +6,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; 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;