Raymond Toy pushed to branch master at cmucl / cmucl Commits: 58358927 by Raymond Toy at 2026-01-02T14:27:25-08:00 Fix #454 and #138: Signal errors for bad components for make-pathname - - - - - 97824b42 by Raymond Toy at 2026-01-02T14:27:25-08:00 Merge branch 'issue-454-signal-error-for-bad-pathname-parts' into 'master' Fix #454 and #138: Signal errors for bad components for make-pathname Closes #454 and #138 See merge request cmucl/cmucl!333 - - - - - 3 changed files: - src/code/pathname.lisp - src/i18n/locale/cmucl.pot - tests/pathname.lisp Changes: ===================================== src/code/pathname.lisp ===================================== @@ -838,14 +838,18 @@ a host-structure or string." (%pathname-directory defaults) diddle-defaults))) - ;; A bit of sanity checking on user arguments. + ;; A bit of sanity checking on user arguments. We don't allow a + ;; "/" or NUL in any string that's part of a pathname object. (flet ((check-component-validity (name name-or-type) (when (stringp name) - (let ((unix-directory-separator #\/)) - (when (eq host (%pathname-host *default-pathname-defaults*)) - (when (find unix-directory-separator name) - (warn (intl:gettext "Silly argument for a unix ~A: ~S") - name-or-type name))))))) + (when (eq host (%pathname-host *default-pathname-defaults*)) + (when (some #'(lambda (c) + ;; Illegal characters are a slash or NUL. + (case c + ((#\/ #\null) t))) + name) + (error _"Pathname component ~A cannot contain a slash or nul character: ~S" + name-or-type name)))))) (check-component-validity name :pathname-name) (check-component-validity type :pathname-type) (mapc #'(lambda (d) @@ -856,8 +860,9 @@ a host-structure or string." (not type)) (and (string= name ".") (not type)))) - ;; - (warn (intl:gettext "Silly argument for a unix PATHNAME-NAME: ~S") name))) + ;; + (cerror _"Continue anyway" + _"PATHNAME-NAME cannot be \".\" or \"..\""))) ;; More sanity checking (when dir ===================================== src/i18n/locale/cmucl.pot ===================================== @@ -7717,7 +7717,7 @@ msgstr "" msgid ", type=" msgstr "" -#: src/code/print.lisp +#: src/code/pathname.lisp src/code/print.lisp msgid "Continue anyway" msgstr "" @@ -9785,17 +9785,17 @@ msgid "~S is not allowed as a directory component." msgstr "" #: src/code/pathname.lisp -msgid "" -"Makes a new pathname from the component arguments. Note that host is\n" -"a host-structure or string." +msgid "Pathname component ~A cannot contain a slash or nul character: ~S" msgstr "" #: src/code/pathname.lisp -msgid "Silly argument for a unix ~A: ~S" +msgid "PATHNAME-NAME cannot be \".\" or \"..\"" msgstr "" #: src/code/pathname.lisp -msgid "Silly argument for a unix PATHNAME-NAME: ~S" +msgid "" +"Makes a new pathname from the component arguments. Note that host is\n" +"a host-structure or string." msgstr "" #: src/code/pathname.lisp ===================================== tests/pathname.lisp ===================================== @@ -153,4 +153,30 @@ ;; Now recursively delete the directory. (assert-true (ext:delete-directory (merge-pathnames "tmp/" path) :recursive t)) - (assert-false (directory "tmp/"))))) + (assert-false (directory (merge-pathnames "tmp/" path)))))) + +(define-test issue.454.illegal-pathname-chars + (:tag :issues) + ;; A slash (Unix directory separater) is not allowed. + (assert-error 'simple-error + (make-pathname :name "a/b")) + (assert-error 'simple-error + (make-pathname :type "a/b")) + (assert-error 'simple-error + (make-pathname :directory '(:relative "a/b"))) + ;; ASCII NUL characters are not allowed in Unix pathnames. + (let ((string-with-nul (concatenate 'string "a" (string #\nul) "b"))) + (assert-error 'simple-error + (make-pathname :name string-with-nul)) + (assert-error 'simple-error + (make-pathname :type string-with-nul)) + (assert-error 'simple-error + (make-pathname :directory (list :relative string-with-nul))))) + +(define-test issue.454.illegal-pathname-dot + (:tag :issues) + (assert-error 'simple-error + (make-pathname :name ".")) + (assert-error 'simple-error + (make-pathname :name ".."))) + View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/28de6c68defdaec3afac117... -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/28de6c68defdaec3afac117... You're receiving this email because of your account on gitlab.common-lisp.net.