├── .gitignore ├── .github └── workflows │ └── cl.yaml ├── filepaths.asd ├── CHANGELOG.md ├── tests └── tests.lisp ├── LICENSE ├── README.org └── src └── filepaths.lisp /.gitignore: -------------------------------------------------------------------------------- 1 | *.abcl 2 | *.fasl 3 | *.dx32fsl 4 | *.dx64fsl 5 | *.lx32fsl 6 | *.lx64fsl 7 | *.x86f 8 | *~ 9 | .#* 10 | .qlot/* 11 | vendored/* 12 | -------------------------------------------------------------------------------- /.github/workflows/cl.yaml: -------------------------------------------------------------------------------- 1 | on: 2 | push: 3 | branches: [master] 4 | pull_request: 5 | 6 | jobs: 7 | test: 8 | runs-on: ubuntu-latest 9 | name: Unit Tests 10 | steps: 11 | - name: Clone the Project 12 | uses: actions/checkout@v4 13 | 14 | - name: Set up Common Lisp 15 | uses: fosskers/common-lisp@v1 16 | 17 | - name: Test 18 | run: | 19 | vend test 20 | -------------------------------------------------------------------------------- /filepaths.asd: -------------------------------------------------------------------------------- 1 | (defsystem "filepaths" 2 | :version "1.0.3" 3 | :author "Colin Woodbury " 4 | :license "LGPL-3.0-only" 5 | :depends-on () 6 | :components ((:module "src" :components ((:file "filepaths")))) 7 | :description "Modern and consistent filepath manipulation." 8 | :in-order-to ((test-op (test-op :filepaths/tests)))) 9 | 10 | (defsystem "filepaths/tests" 11 | :depends-on (:filepaths :parachute) 12 | :components ((:module "tests" :components ((:file "tests")))) 13 | :description "Test system for filepaths" 14 | :perform (test-op (op c) (symbol-call :parachute :test :filepaths/tests))) 15 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # filepaths 2 | 3 | ## 1.0.3 (2025-08-17) 4 | 5 | #### Added 6 | 7 | - CMUCL support. 8 | 9 | #### Fixed 10 | 11 | - `ensure-directory` on paths that end in `*` or `**`. 12 | 13 | ## 1.0.2 (2025-06-26) 14 | 15 | #### Added 16 | 17 | - Windows support, by accounting for the `:device` field of `pathname`. 18 | 19 | ## 1.0.1 (2025-05-12) 20 | 21 | #### Fixed 22 | 23 | - Support `*` (`:wild`) in extension position. 24 | - `ensure-directory` on a relative path with one component (e.g. `foo -> foo/`). 25 | 26 | ## 1.0.0 (2025-02-15) 27 | 28 | Finalising `1.0.0` since it's been stable for over a year without issues. 29 | 30 | #### Added 31 | 32 | - `?`-suffixed aliases for the various predicate functions. 33 | 34 | ## 0.1.3 (2024-07-22) 35 | 36 | #### Fixed 37 | 38 | - A minor issue involving `**` when used with Allegro. 39 | 40 | ## 0.1.2 (2024-03-07) 41 | 42 | #### Fixed 43 | 44 | - Arguments to `join` can now be composite themselves, like: `(join "/foo/bar" "baz/test.json")` 45 | 46 | ## 0.1.1 (2024-01-27) 47 | 48 | #### Fixed 49 | 50 | - Handling of special path components like `..`. 51 | 52 | ## 0.1.0 (2024-01-24) 53 | 54 | Initial release with confirmed support for SBCL, ECL, ABCL. 55 | 56 | -------------------------------------------------------------------------------- /tests/tests.lisp: -------------------------------------------------------------------------------- 1 | (defpackage filepaths/tests 2 | (:use :cl :parachute) 3 | (:local-nicknames (:p :filepaths))) 4 | 5 | (in-package :filepaths/tests) 6 | 7 | (define-test suite) 8 | 9 | (define-test "Structural Tests" 10 | :parent suite 11 | (true (p:rootp "/")) 12 | (false (p:rootp "/foo")) 13 | (true (p:emptyp "")) 14 | (false (p:emptyp "/foo")) 15 | (true (p:absolutep "/home/colin/foo.txt")) 16 | (false (p:absolutep "colin/foo.txt")) 17 | (true (p:absolutep "/")) 18 | (false (p:absolutep "")) 19 | (false (p:relativep "/home/colin/foo.txt")) 20 | (true (p:relativep "foo.txt")) 21 | (true (p:starts-with-p "/foo/bar/baz/zing.json" "/foo/bar")) 22 | (true (p:ends-with-p "/foo/bar/baz/zing.json" "baz/zing.json")) 23 | (true (p:directoryp "/foo/bar/")) 24 | (true (p:directoryp #p"/foo/bar/")) 25 | (false (p:directoryp "/foo/bar/baz.txt")) 26 | (false (p:directoryp #p"/foo/bar/baz.txt"))) 27 | 28 | (define-test "Construction" 29 | :parent suite 30 | (is equal #p"/foo/bar/baz/test.json" (p:join "/foo" "bar" "baz" "test.json")) 31 | (is equal #p"/bar/baz/foo.json" (p:join #p"/bar/baz/" #p"foo.json")) 32 | (is equal #p"/bar/baz/foo.json" (p:join #p"/bar/baz" #p"foo.json")) 33 | (is equal #p"/foo/bar/baz/test.json" (p:join "/foo" "" "bar" "/" "baz" "test.json")) 34 | (is equal #p"/bar/baz/test.json" (p:join "/" "bar" "baz" "test.json")) 35 | (is equal #p"/foo/bar/baz/test.json" (p:join "/foo/bar" "baz/test.json")) 36 | ;; Naughty under CCL and Allegro. 37 | (is equal #p"/foo/bar/.././../baz/stuff.json" (p:join "/" "foo" "bar" ".." "." ".." "baz" "stuff.json")) 38 | (fail (p:join "/foo" "/")) 39 | (fail (p:join "/foo" ""))) 40 | 41 | (define-test "Wild Cards" 42 | :parent suite 43 | (is equal #p"/foo/*.*" (p:join "/foo" "*.*")) 44 | #-(or clasp ecl) 45 | (is equal #p"/foo/**.json" (p:join "/foo" "**.json")) 46 | (is equal #p"/foo/**/*.json" (p:join "/foo" "**" "*.json")) 47 | (isnt equal #p"/foo/bar/*" #p"/foo/bar/*/") 48 | (is equal #p"/foo/bar/*/" (p:ensure-directory #p"/foo/bar/*")) 49 | #-ecl 50 | (is equal #p"/foo/bar/**/" (p:ensure-directory #p"/foo/bar/**"))) 51 | 52 | (define-test "Component Access" 53 | :parent suite 54 | (is equal "baz" (p:base "/foo/bar/baz.txt")) 55 | (is equal "ゆびわ" (p:base #p"/foo/bar/ゆびわ.txt")) 56 | (is equal "baz.txt" (p:base "/foo/bar/baz.txt.zip")) 57 | (is equal "*" (p:base "/foo/bar/*.zip")) 58 | #-(or clasp ecl) 59 | (is equal "**" (p:base "/foo/bar/**.zip")) 60 | (fail (p:base "/foo/bar/")) 61 | (is equal #p"/foo/bar/jack.txt" (p:with-base "/foo/bar/baz.txt" "jack")) 62 | (is equal "baz.txt" (p:name "baz.txt")) 63 | (is equal "baz.txt" (p:name "/foo/bar/baz.txt")) 64 | (fail (p:name "/foo/bar/")) 65 | (fail (p:name "")) 66 | (is equal #p"/foo/bar/jack.json" (p:with-name "/foo/bar/baz.txt" "jack.json")) 67 | (is equal #p"/foo/bar/" (p:parent "/foo/bar/baz.txt")) 68 | (is equal #p"/foo/" (p:parent "/foo/bar/")) 69 | (is equal #p"/" (p:parent "/foo/")) 70 | (fail (p:parent "/")) 71 | (fail (p:parent "")) 72 | (is equal #p"/zing/baz.json" (p:with-parent "/foo/bar/baz.json" "/zing")) 73 | (is equal "json" (p:extension "/foo/bar.json")) 74 | (is equal :wild (p:extension "*.*")) 75 | (false (p:extension "/")) 76 | (is equal #p"/foo/bar/baz.json" (p:with-extension "/foo/bar/baz.txt" "json")) 77 | (fail (p:with-extension "/foo/bar/" "json")) 78 | (is equal #p"/foo/bar/baz" (p:drop-extension #p"/foo/bar/baz.json")) 79 | (is equal #p"/foo/bar/baz.json" (p:drop-extension #p"/foo/bar/baz.json.zip")) 80 | (is equal #p"/foo/bar/baz.txt.zip" (p:add-extension "/foo/bar/baz.txt" "zip")) 81 | (is equal #p"/foo/bar/baz.txt" (p:add-extension "/foo/bar/baz" "txt")) 82 | (fail (p:add-extension "/foo/bar/" "txt"))) 83 | 84 | (define-test "Conversion" 85 | :parent suite 86 | (is equal '("/" "foo" "bar" "baz.json") (p:components "/foo/bar/baz.json")) 87 | (is equal '("foo" "bar" "baz.json") (p:components "foo/bar/baz.json")) 88 | (is equal '("/") (p:components "/")) 89 | (is equal '() (p:components "")) 90 | (is equal '(".") (p:components ".")) 91 | #-(or cmucl allegro) 92 | (is equal '("foo" ".") (p:components "foo/.")) 93 | (is equal '("/" ".") (p:components "/.")) 94 | (is equal #p"" (p:from-list '())) 95 | (is equal #p"foo" (p:from-list '("foo"))) 96 | (is equal #p"foo/bar/baz" (p:from-list '("foo" "bar" "baz"))) 97 | (let ((path #p"/foo/bar/baz/file.txt")) 98 | (is equal path (p:from-list (p:components path)))) 99 | (let ((path #p"/foo/bar/.././../baz/stuff.json")) 100 | (is equal path (p:from-list (p:components path)))) 101 | (let ((path #p"/foo/bar/baz/")) 102 | (is equal path (p:ensure-directory path))) 103 | (is equal #p"foobar/" (p:ensure-directory "foobar")) 104 | (is equal #p"/foo/bar/baz/" (p:ensure-directory "/foo/bar/baz")) 105 | (is equal #p"/foo/bar/baz.json/" (p:ensure-directory "/foo/bar/baz.json")) 106 | (of-type string (p:ensure-string #p"/foo")) 107 | (of-type pathname (p:ensure-path "/foo"))) 108 | 109 | #+win32 110 | (define-test "Windows" 111 | :parent suite 112 | (is equal #p"Z:/foo/bar" (p:join #p"Z:/foo" "bar")) 113 | (is equal #p"Z:/foo/bar.json" (p:with-extension #p"Z:/foo/bar.txt" "json")) 114 | (is equal #p"Z:/foo/bar" (p:drop-extension #p"Z:/foo/bar.txt")) 115 | (is equal #p"Z:/foo/bar.tar.gz" (p:add-extension #p"Z:/foo/bar.tar" "gz")) 116 | (is equal #p"Z:/zing/baz.json" (p:with-parent #p"C:/foo/bar/baz.json" #p"Z:/zing")) 117 | (is equal #p"Z:/foo/bar/jack.json" (p:with-name #p"Z:/foo/bar/baz.txt" "jack.json")) 118 | (is equal #p"Z:/foo/bar/jack.txt" (p:with-base #p"Z:/foo/bar/baz.txt" "jack")) 119 | (is equal #p"Z:/foo/bar/baz/" (p:ensure-directory #p"Z:/foo/bar/baz"))) 120 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | GNU LESSER GENERAL PUBLIC LICENSE 2 | Version 3, 29 June 2007 3 | 4 | Copyright (C) 2007 Free Software Foundation, Inc. 5 | Everyone is permitted to copy and distribute verbatim copies 6 | of this license document, but changing it is not allowed. 7 | 8 | 9 | This version of the GNU Lesser General Public License incorporates 10 | the terms and conditions of version 3 of the GNU General Public 11 | License, supplemented by the additional permissions listed below. 12 | 13 | 0. Additional Definitions. 14 | 15 | As used herein, "this License" refers to version 3 of the GNU Lesser 16 | General Public License, and the "GNU GPL" refers to version 3 of the GNU 17 | General Public License. 18 | 19 | "The Library" refers to a covered work governed by this License, 20 | other than an Application or a Combined Work as defined below. 21 | 22 | An "Application" is any work that makes use of an interface provided 23 | by the Library, but which is not otherwise based on the Library. 24 | Defining a subclass of a class defined by the Library is deemed a mode 25 | of using an interface provided by the Library. 26 | 27 | A "Combined Work" is a work produced by combining or linking an 28 | Application with the Library. The particular version of the Library 29 | with which the Combined Work was made is also called the "Linked 30 | Version". 31 | 32 | The "Minimal Corresponding Source" for a Combined Work means the 33 | Corresponding Source for the Combined Work, excluding any source code 34 | for portions of the Combined Work that, considered in isolation, are 35 | based on the Application, and not on the Linked Version. 36 | 37 | The "Corresponding Application Code" for a Combined Work means the 38 | object code and/or source code for the Application, including any data 39 | and utility programs needed for reproducing the Combined Work from the 40 | Application, but excluding the System Libraries of the Combined Work. 41 | 42 | 1. Exception to Section 3 of the GNU GPL. 43 | 44 | You may convey a covered work under sections 3 and 4 of this License 45 | without being bound by section 3 of the GNU GPL. 46 | 47 | 2. Conveying Modified Versions. 48 | 49 | If you modify a copy of the Library, and, in your modifications, a 50 | facility refers to a function or data to be supplied by an Application 51 | that uses the facility (other than as an argument passed when the 52 | facility is invoked), then you may convey a copy of the modified 53 | version: 54 | 55 | a) under this License, provided that you make a good faith effort to 56 | ensure that, in the event an Application does not supply the 57 | function or data, the facility still operates, and performs 58 | whatever part of its purpose remains meaningful, or 59 | 60 | b) under the GNU GPL, with none of the additional permissions of 61 | this License applicable to that copy. 62 | 63 | 3. Object Code Incorporating Material from Library Header Files. 64 | 65 | The object code form of an Application may incorporate material from 66 | a header file that is part of the Library. You may convey such object 67 | code under terms of your choice, provided that, if the incorporated 68 | material is not limited to numerical parameters, data structure 69 | layouts and accessors, or small macros, inline functions and templates 70 | (ten or fewer lines in length), you do both of the following: 71 | 72 | a) Give prominent notice with each copy of the object code that the 73 | Library is used in it and that the Library and its use are 74 | covered by this License. 75 | 76 | b) Accompany the object code with a copy of the GNU GPL and this license 77 | document. 78 | 79 | 4. Combined Works. 80 | 81 | You may convey a Combined Work under terms of your choice that, 82 | taken together, effectively do not restrict modification of the 83 | portions of the Library contained in the Combined Work and reverse 84 | engineering for debugging such modifications, if you also do each of 85 | the following: 86 | 87 | a) Give prominent notice with each copy of the Combined Work that 88 | the Library is used in it and that the Library and its use are 89 | covered by this License. 90 | 91 | b) Accompany the Combined Work with a copy of the GNU GPL and this license 92 | document. 93 | 94 | c) For a Combined Work that displays copyright notices during 95 | execution, include the copyright notice for the Library among 96 | these notices, as well as a reference directing the user to the 97 | copies of the GNU GPL and this license document. 98 | 99 | d) Do one of the following: 100 | 101 | 0) Convey the Minimal Corresponding Source under the terms of this 102 | License, and the Corresponding Application Code in a form 103 | suitable for, and under terms that permit, the user to 104 | recombine or relink the Application with a modified version of 105 | the Linked Version to produce a modified Combined Work, in the 106 | manner specified by section 6 of the GNU GPL for conveying 107 | Corresponding Source. 108 | 109 | 1) Use a suitable shared library mechanism for linking with the 110 | Library. A suitable mechanism is one that (a) uses at run time 111 | a copy of the Library already present on the user's computer 112 | system, and (b) will operate properly with a modified version 113 | of the Library that is interface-compatible with the Linked 114 | Version. 115 | 116 | e) Provide Installation Information, but only if you would otherwise 117 | be required to provide such information under section 6 of the 118 | GNU GPL, and only to the extent that such information is 119 | necessary to install and execute a modified version of the 120 | Combined Work produced by recombining or relinking the 121 | Application with a modified version of the Linked Version. (If 122 | you use option 4d0, the Installation Information must accompany 123 | the Minimal Corresponding Source and Corresponding Application 124 | Code. If you use option 4d1, you must provide the Installation 125 | Information in the manner specified by section 6 of the GNU GPL 126 | for conveying Corresponding Source.) 127 | 128 | 5. Combined Libraries. 129 | 130 | You may place library facilities that are a work based on the 131 | Library side by side in a single library together with other library 132 | facilities that are not Applications and are not covered by this 133 | License, and convey such a combined library under terms of your 134 | choice, if you do both of the following: 135 | 136 | a) Accompany the combined library with a copy of the same work based 137 | on the Library, uncombined with any other library facilities, 138 | conveyed under the terms of this License. 139 | 140 | b) Give prominent notice with the combined library that part of it 141 | is a work based on the Library, and explaining where to find the 142 | accompanying uncombined form of the same work. 143 | 144 | 6. Revised Versions of the GNU Lesser General Public License. 145 | 146 | The Free Software Foundation may publish revised and/or new versions 147 | of the GNU Lesser General Public License from time to time. Such new 148 | versions will be similar in spirit to the present version, but may 149 | differ in detail to address new problems or concerns. 150 | 151 | Each version is given a distinguishing version number. If the 152 | Library as you received it specifies that a certain numbered version 153 | of the GNU Lesser General Public License "or any later version" 154 | applies to it, you have the option of following the terms and 155 | conditions either of that published version or of any later version 156 | published by the Free Software Foundation. If the Library as you 157 | received it does not specify a version number of the GNU Lesser 158 | General Public License, you may choose any version of the GNU Lesser 159 | General Public License ever published by the Free Software Foundation. 160 | 161 | If the Library as you received it specifies that a proxy can decide 162 | whether future versions of the GNU Lesser General Public License shall 163 | apply, that proxy's public statement of acceptance of any version is 164 | permanent authorization for you to choose that version for the 165 | Library. 166 | -------------------------------------------------------------------------------- /README.org: -------------------------------------------------------------------------------- 1 | #+title: filepaths 2 | 3 | Inspired by [[https://github.com/vindarel/cl-str][str]], this library offers modern and consistent filepath manipulation 4 | for Common Lisp. 5 | 6 | It addresses three main issues found with the status quo, namely: 7 | 8 | - Centrality: Functionality is spread across the standard library and =uiop=. 9 | - Completeness: A number of common operations found in newer languages are missing entirely. 10 | - Clarity: Function names are often unintuitive. 11 | 12 | The =filepaths= library solves these issues by offering functions commonly found 13 | elsewhere while naming them what you'd generally expect them to be. For 14 | instance: 15 | 16 | #+begin_src lisp :exports both 17 | (filepaths:join "/home/you/code" "common-lisp" "hello.lisp") 18 | #+end_src 19 | 20 | #+RESULTS: 21 | : #P"/home/you/code/common-lisp/hello.lisp" 22 | 23 | There are many more functions available. 24 | 25 | Note that this library supports both Unix and Windows, but doesn't offer 26 | functions for communicating with the filesystem to test if files exist, etc. 27 | 28 | * Table of Contents :TOC_5_gh:noexport: 29 | - [[#compatibility][Compatibility]] 30 | - [[#installation][Installation]] 31 | - [[#usage][Usage]] 32 | - [[#structural-tests][Structural Tests]] 33 | - [[#root-empty][root?, empty?]] 34 | - [[#absolute-relative][absolute?, relative?]] 35 | - [[#starts-with-ends-with][starts-with?, ends-with?]] 36 | - [[#directory][directory?]] 37 | - [[#construction][Construction]] 38 | - [[#join][join]] 39 | - [[#component-access][Component Access]] 40 | - [[#base-with-base][base, with-base]] 41 | - [[#name-with-name][name, with-name]] 42 | - [[#parent-with-parent][parent, with-parent]] 43 | - [[#extension-with-extension-add-extension-drop-extension][extension, with-extension, add-extension, drop-extension]] 44 | - [[#conversion][Conversion]] 45 | - [[#components-from-list][components, from-list]] 46 | - [[#ensure-directory-ensure-string-ensure-path][ensure-directory, ensure-string, ensure-path]] 47 | - [[#to-string-from-string][to-string, from-string]] 48 | - [[#conditions][Conditions]] 49 | - [[#see-also][See Also]] 50 | 51 | * Compatibility 52 | 53 | | Compiler | ~**.json~ | Verbatum ~..~ | Unicode Paths | 54 | |----------+---------+-------------+---------------| 55 | | SBCL | Yes | Yes | Yes | 56 | | ECL | [[https://gitlab.com/embeddable-common-lisp/ecl/-/issues/751][No]] | Yes | Yes | 57 | | ABCL | Yes | [[https://github.com/armedbear/abcl/issues/672][No]] | Yes | 58 | | CMUCL | Yes | Yes | Yes | 59 | | CCL | Yes | [[https://github.com/Clozure/ccl/issues/477][No]] | Yes | 60 | | Clasp | [[https://github.com/clasp-developers/clasp/issues/1594][No]] | Yes | Yes (2.7) | 61 | | Allegro | Yes | No | Yes | 62 | 63 | * Installation 64 | 65 | This library is available on [[https://ultralisp.org/projects/fosskers/filepaths][Ultralisp]]. It uses only standard library functions 66 | and has no external dependencies. 67 | 68 | * Usage 69 | 70 | It is recommended that you import this library with the nickname =path= or =p=, 71 | although the usage examples further down all use the full name, =filepaths=. 72 | 73 | #+begin_src lisp 74 | (:local-nicknames (:p :filepaths)) 75 | #+end_src 76 | 77 | Note that nearly every function here can be passed either a =pathname= or a 78 | =string=. 79 | 80 | ** Structural Tests 81 | 82 | *** root?, empty? 83 | 84 | Is the given PATH the root directory? 85 | 86 | #+begin_src lisp :exports both 87 | (filepaths:root? #p"/") 88 | #+end_src 89 | 90 | #+RESULTS: 91 | : T 92 | 93 | Is the given PATH an empty string? 94 | 95 | #+begin_src lisp :exports both 96 | (filepaths:empty? #p"") 97 | #+end_src 98 | 99 | #+RESULTS: 100 | : T 101 | 102 | *** absolute?, relative? 103 | 104 | Yields T when the given PATH is a full, absolute path. 105 | 106 | #+begin_src lisp :exports both 107 | (filepaths:absolute? "/home/colin/foo.txt") 108 | #+end_src 109 | 110 | #+RESULTS: 111 | : T 112 | 113 | Yields T when the given PATH is a relative one. 114 | 115 | #+begin_src lisp :exports both 116 | (filepaths:relative? #p"bar/foo.txt") 117 | #+end_src 118 | 119 | #+RESULTS: 120 | : T 121 | 122 | *** starts-with?, ends-with? 123 | 124 | Are the initial components of a PATH some BASE? 125 | 126 | #+begin_src lisp :exports both 127 | (filepaths:starts-with? #p"/foo/bar/baz/zing.json" "/foo/bar") 128 | #+end_src 129 | 130 | #+RESULTS: 131 | : T 132 | 133 | Are the final components of a PATH some given CHILD? 134 | 135 | #+begin_src lisp :exports both 136 | (filepaths:ends-with? #p"/foo/bar/baz/zing.json" "baz/zing.json") 137 | #+end_src 138 | 139 | #+RESULTS: 140 | : T 141 | 142 | *** directory? 143 | 144 | Yields T if the PATH represents a directory. It only tests for structure; the 145 | filesystem isn't probed. 146 | 147 | #+begin_src lisp :exports both 148 | (filepaths:directory? #p"/foo/bar/") 149 | #+end_src 150 | 151 | #+RESULTS: 152 | : T 153 | 154 | #+begin_src lisp :exports both 155 | (filepaths:directory? #p"/foo/bar/baz.txt") 156 | #+end_src 157 | 158 | #+RESULTS: 159 | : NIL 160 | 161 | ** Construction 162 | 163 | *** join 164 | 165 | Combine two or more components together. 166 | 167 | #+begin_src lisp :exports both 168 | (filepaths:join "/foo" "bar" "baz" "test.json") 169 | #+end_src 170 | 171 | #+RESULTS: 172 | : #P"/foo/bar/baz/test.json" 173 | 174 | #+begin_src lisp :exports both 175 | (filepaths:join #p"/bar/baz/" #p"foo.json") 176 | #+end_src 177 | 178 | #+RESULTS: 179 | : #P"/bar/baz/foo.json" 180 | 181 | ** Component Access 182 | 183 | *** base, with-base 184 | 185 | The non-extension, non-directory portion of the filename of a PATH. 186 | 187 | #+begin_src lisp :exports both 188 | (filepaths:base #p"/foo/bar/baz.txt") 189 | #+end_src 190 | 191 | #+RESULTS: 192 | : baz 193 | 194 | Swap the base portion of a PATH with a NEW one. Yields a new path object. 195 | 196 | #+begin_src lisp :exports both 197 | (filepaths:with-base #p"/foo/bar/baz.txt" "jack") 198 | #+end_src 199 | 200 | #+RESULTS: 201 | : #P"/foo/bar/jack.txt" 202 | 203 | *** name, with-name 204 | 205 | The filename of a PATH with no other directory components. 206 | 207 | #+begin_src lisp :exports both 208 | (filepaths:name #p"/foo/bar/baz.txt") 209 | #+end_src 210 | 211 | #+RESULTS: 212 | : baz.txt 213 | 214 | Swap the filename portion of a PATH with a NEW one. Yields a new path object. 215 | 216 | #+begin_src lisp :exports both 217 | (filepaths:with-name #p"/foo/bar/baz.txt" "jack.json") 218 | #+end_src 219 | 220 | #+RESULTS: 221 | : #P"/foo/bar/jack.json" 222 | 223 | *** parent, with-parent 224 | 225 | Yield PATH without its final component, if there is one. 226 | 227 | #+begin_src lisp :exports both 228 | (filepaths:parent #p"/foo/bar/baz.txt") 229 | #+end_src 230 | 231 | #+RESULTS: 232 | : #P"/foo/bar/" 233 | 234 | Swap the parent portion of a PATH. 235 | 236 | #+begin_src lisp :exports both 237 | (filepaths:with-parent #p"/foo/bar/baz.json" #p"/zing") 238 | #+end_src 239 | 240 | #+RESULTS: 241 | : #P"/zing/baz.json" 242 | 243 | *** extension, with-extension, add-extension, drop-extension 244 | 245 | The extension of a given PATH. 246 | 247 | #+begin_src lisp :exports both 248 | (filepaths:extension #p"/foo/bar.json") 249 | #+end_src 250 | 251 | #+RESULTS: 252 | : json 253 | 254 | Swap the entire extension of a given PATH. Yields a new path object. 255 | 256 | #+begin_src lisp :exports both 257 | (filepaths:with-extension #p"/foo/bar/baz.txt" "json") 258 | #+end_src 259 | 260 | #+RESULTS: 261 | : #P"/foo/bar/baz.json" 262 | 263 | 264 | Add an extension to the given path, even if it already has one. 265 | 266 | #+begin_src lisp :exports both 267 | (filepaths:add-extension #p"/foo/bar/baz.txt" "zip") 268 | #+end_src 269 | 270 | #+RESULTS: 271 | : #P"/foo/bar/baz.txt.zip" 272 | 273 | Remove an extension from a PATH. 274 | 275 | #+begin_src lisp :exports both 276 | (filepaths:drop-extension #p"/foo/bar/baz.json") 277 | #+end_src 278 | 279 | #+RESULTS: 280 | : #P"/foo/bar/baz" 281 | 282 | #+begin_src lisp :exports both 283 | (filepaths:drop-extension #p"/foo/bar/baz.json.zip") 284 | #+end_src 285 | 286 | #+RESULTS: 287 | : #P"/foo/bar/baz.json" 288 | 289 | ** Conversion 290 | 291 | *** components, from-list 292 | 293 | Every component of a PATH broken up as a list. 294 | 295 | #+begin_src lisp :results verbatim :exports both 296 | (filepaths:components #p"/foo/bar/baz.json") 297 | #+end_src 298 | 299 | #+RESULTS: 300 | : ("/" "foo" "bar" "baz.json") 301 | 302 | Given a LIST of path components, construct a proper pathname object. 303 | 304 | #+begin_src lisp :exports both 305 | (filepaths:from-list '("foo" "bar" "baz")) 306 | #+end_src 307 | 308 | #+RESULTS: 309 | : #P"foo/bar/baz" 310 | 311 | #+begin_src lisp :exports both 312 | (filepaths:from-list (filepaths:components "/foo/bar/baz/file.txt")) 313 | #+end_src 314 | 315 | #+RESULTS: 316 | : #P"/foo/bar/baz/file.txt" 317 | 318 | *** ensure-directory, ensure-string, ensure-path 319 | 320 | If a given PATH doesn't end in a path separator, add one. 321 | 322 | #+begin_src lisp :exports both 323 | (filepaths:ensure-directory #p"/foo/bar/baz") 324 | #+end_src 325 | 326 | #+RESULTS: 327 | : #P"/foo/bar/baz/" 328 | 329 | A PATH is definitely a string after this. 330 | 331 | #+begin_src lisp :results verbatim :exports both 332 | (type-of (filepaths:ensure-string #p"/foo/bar")) 333 | #+end_src 334 | 335 | #+RESULTS: 336 | : (SIMPLE-BASE-STRING 8) 337 | 338 | A PATH is definitely a pathname after this. 339 | 340 | #+begin_src lisp :exports both 341 | (type-of (filepaths:ensure-path "/foo/bar")) 342 | #+end_src 343 | 344 | #+RESULTS: 345 | : PATHNAME 346 | 347 | *** to-string, from-string 348 | 349 | Convert a PATH object into string. 350 | 351 | #+begin_src lisp :exports both 352 | (filepaths:to-string #p"/foo/bar/baz.txt") 353 | #+end_src 354 | 355 | #+RESULTS: 356 | : /foo/bar/baz.txt 357 | 358 | Convert a string into a proper filepath object. 359 | 360 | #+begin_src lisp :exports both 361 | (filepaths:from-string "/foo/bar/baz.txt") 362 | #+end_src 363 | 364 | #+RESULTS: 365 | : #P"/foo/bar/baz.txt" 366 | 367 | ** Conditions 368 | 369 | For certain functions in this library, it is not appropriate to return =nil= in 370 | case of an error. The following conditions are thus triggered under certain 371 | circumstances: 372 | 373 | - =no-filename= 374 | - =empty-path= 375 | - =root-no-parent= 376 | 377 | * See Also 378 | 379 | - https://shinmera.github.io/pathname-utils/ 380 | - https://codeberg.org/fourier/ppath 381 | - https://quickdocs.org/uiop 382 | -------------------------------------------------------------------------------- /src/filepaths.lisp: -------------------------------------------------------------------------------- 1 | (defpackage filepaths 2 | (:use :cl) 3 | ;; --- Structural tests --- ;; 4 | (:export #:root? #:rootp #:empty? #:emptyp 5 | #:starts-with? #:starts-with-p #:ends-with? #:ends-with-p 6 | #:absolute? #:absolutep #:relative? #:relativep 7 | #:directory? #:directoryp) 8 | ;; --- Construction --- ;; 9 | (:export #:join) 10 | ;; --- Component Access --- ;; 11 | (:export #:base #:with-base 12 | #:name #:with-name 13 | #:parent #:with-parent 14 | #:extension #:with-extension #:drop-extension #:add-extension) 15 | ;; --- Conversion --- ;; 16 | (:export #:components #:from-list 17 | #:ensure-directory #:ensure-string #:ensure-path 18 | #:to-string #:from-string) 19 | ;; --- Conditions --- ;; 20 | (:export #:no-filename 21 | #:empty-path 22 | #:root-no-parent) 23 | (:documentation "Modern and consistent filepath manipulation.")) 24 | 25 | (in-package :filepaths) 26 | 27 | (defconstant +empty-path+ #p"") 28 | (defconstant +filesystem-root+ #p"/") 29 | (defconstant +separator+ #\/) 30 | 31 | (defmacro rootp (path) 32 | `(root? ,path)) 33 | 34 | (declaim (ftype (function ((or pathname string)) boolean) root?)) 35 | (defun root? (path) 36 | "Is the given PATH the root directory?" 37 | (or (and (stringp path) 38 | (string-equal "/" path)) 39 | (and (pathnamep path) 40 | (equal +filesystem-root+ path)))) 41 | 42 | #+nil 43 | (rootp #p"/") 44 | 45 | (defmacro emptyp (path) 46 | `(empty? ,path)) 47 | 48 | (declaim (ftype (function ((or pathname string)) boolean) empty?)) 49 | (defun empty? (path) 50 | "Is the given PATH an empty string?" 51 | (or (and (stringp path) 52 | (= 0 (length path))) 53 | (and (pathnamep path) 54 | (equal +empty-path+ path)))) 55 | 56 | #+nil 57 | (emptyp #p"") 58 | 59 | (defmacro starts-with-p (path base) 60 | `(starts-with? ,path ,base)) 61 | 62 | (defun starts-with? (path base) 63 | "Are the initial components of a PATH some BASE?" 64 | (let ((bools (mapcar #'equal (components path) (components base)))) 65 | (reduce (lambda (a b) (and a b)) bools :initial-value t))) 66 | 67 | #+nil 68 | (starts-with-p #p"/foo/bar/baz/zing.json" "/foo/bar") 69 | 70 | (defmacro ends-with-p (path child) 71 | `(ends-with? ,path ,child)) 72 | 73 | (defun ends-with? (path child) 74 | "Are the final components of a PATH some given CHILD?" 75 | (let ((bools (mapcar #'equal 76 | (reverse (components path)) 77 | (reverse (components child))))) 78 | (reduce (lambda (a b) (and a b)) bools :initial-value t))) 79 | 80 | #+nil 81 | (ends-with-p #p"/foo/bar/baz/zing.json" "baz/zing.json") 82 | 83 | (defmacro absolutep (path) 84 | `(absolute? ,path)) 85 | 86 | (declaim (ftype (function ((or pathname string)) boolean) absolute?)) 87 | (defun absolute? (path) 88 | "Yields T when the given PATH is a full, absolute path." 89 | (if (pathnamep path) 90 | (eq :absolute (car (pathname-directory path))) 91 | (and (< 0 (length path)) 92 | (equal +separator+ (char path 0))))) 93 | 94 | #+nil 95 | (absolutep "/home/colin/foo.txt") 96 | 97 | (defmacro relativep (path) 98 | `(relative? ,path)) 99 | 100 | (declaim (ftype (function ((or pathname string)) boolean) relative?)) 101 | (defun relative? (path) 102 | "Yields T when the given PATH is a relative one." 103 | (not (absolutep path))) 104 | 105 | #+nil 106 | (relativep #p"/home/colin/foo.txt") 107 | #+nil 108 | (relativep #p"foo.txt") 109 | 110 | (defmacro directoryp (path) 111 | `(directory? ,path)) 112 | 113 | (declaim (ftype (function ((or pathname string)) boolean) directory?)) 114 | (defun directory? (path) 115 | "Yields T if the PATH represents a directory. 116 | 117 | Note that this only checks the formatting of the path, and does not query the 118 | filesystem." 119 | (if (pathnamep path) 120 | (and (not (null (pathname-directory path))) 121 | (not (pathname-name path))) 122 | (equal +separator+ (char path (1- (length path)))))) 123 | 124 | #+nil 125 | (directoryp "/foo/bar/") 126 | #+nil 127 | (directoryp "/foo/bar/baz.txt") 128 | 129 | (declaim (ftype (function ((or pathname string)) simple-string) base)) 130 | (defun base (path) 131 | "The non-extension, non-directory portion of the filename of a PATH." 132 | (let ((b (pathname-name path))) 133 | (if (not b) 134 | (error 'no-filename :path path) 135 | (string-if-keyword-impl-specific b)))) 136 | 137 | #+nil 138 | (base "/foo/bar/baz.txt") 139 | #+nil 140 | (base #p"/foo/bar/ゆびわ.txt") 141 | 142 | (declaim (ftype (function ((or pathname string) string) pathname) with-base)) 143 | (defun with-base (path new) 144 | "Swap the base portion of a PATH with a NEW one. Yields a new path object." 145 | (let ((path (ensure-path path))) 146 | (make-pathname :name new 147 | :type (pathname-type path) 148 | :device (pathname-device path) 149 | :directory (pathname-directory path) 150 | :version :newest))) 151 | 152 | #+nil 153 | (with-base #p"/foo/bar/baz.txt" "jack") 154 | 155 | (declaim (ftype (function ((or pathname string)) simple-string) name)) 156 | (defun name (path) 157 | "The filename of a PATH with no other directory components." 158 | (let ((n (file-namestring path))) 159 | (if (= 0 (length n)) 160 | (error 'no-filename :path path) 161 | n))) 162 | 163 | #+nil 164 | (name "/foo/bar/baz.txt") 165 | 166 | (declaim (ftype (function ((or pathname string) (or pathname string)) pathname) with-name)) 167 | (defun with-name (path new) 168 | "Swap the filename portion of a PATH with a NEW one. Yields a new path object." 169 | (let ((path (ensure-path path))) 170 | (make-pathname :name (base new) 171 | :type (extension new) 172 | :device (pathname-device path) 173 | :directory (pathname-directory path) 174 | :version :newest))) 175 | 176 | #+nil 177 | (with-name #p"/foo/bar/baz.txt" "jack.json") 178 | 179 | (declaim (ftype (function ((or pathname string)) pathname) parent)) 180 | (defun parent (path) 181 | "Yield PATH without its final component, if there is one." 182 | (cond ((emptyp path) (error 'empty-path)) 183 | ((rootp path) (error 'root-no-parent)) 184 | (t (let* ((s (ensure-string path)) 185 | (path (if (directoryp s) 186 | (string-right-trim "/" s) 187 | s))) 188 | (from-string (directory-namestring path)))))) 189 | 190 | #+nil 191 | (parent "/foo/bar/baz.txt") 192 | #+nil 193 | (parent "/foo/bar/") 194 | #+nil 195 | (parent "/foo/") 196 | 197 | (declaim (ftype (function ((or pathname string) (or pathname string)) pathname) with-parent)) 198 | (defun with-parent (path parent) 199 | "Swap the parent portion of a PATH." 200 | (join parent (name path))) 201 | 202 | #+nil 203 | (with-parent #p"/foo/bar/baz.json" #p"/zing") 204 | 205 | (declaim (ftype (function ((or pathname string)) (or simple-string keyword null)) extension)) 206 | (defun extension (path) 207 | "The extension of a given PATH." 208 | (pathname-type path)) 209 | 210 | #+nil 211 | (extension #p"/foo/bar.json") 212 | #+nil 213 | (extension #p"/") 214 | #++ 215 | (extension #p"*.*") 216 | 217 | (declaim (ftype (function ((or pathname string) string) pathname) with-extension)) 218 | (defun with-extension (path ext) 219 | "Swap the entire extension of a given PATH. Yields a new path object." 220 | (let ((path (ensure-path path))) 221 | (if (directoryp path) 222 | (error 'no-filename :path path) 223 | (make-pathname :name (base path) 224 | :type ext 225 | :device (pathname-device path) 226 | :directory (pathname-directory path) 227 | :version :newest)))) 228 | 229 | #+nil 230 | (with-extension #p"/foo/bar/baz.txt" "json") 231 | #+nil 232 | (with-extension #p"/foo/bar/" "json") 233 | 234 | (declaim (ftype (function ((or pathname string)) pathname) drop-extension)) 235 | (defun drop-extension (path) 236 | "Remove an extension from a PATH." 237 | (let* ((path (ensure-path path)) 238 | (stem (base path)) 239 | (ext (extension stem)) 240 | (name (if ext (base stem) stem))) 241 | ;; Similar to `add-extension', there's some cleverness here where we need to 242 | ;; check if we must move an "inner" extension back outward. For instance, in 243 | ;; the case of foo.json.zip. It looks like we're always setting `:type' to 244 | ;; something concrete, but this will properly be NIL in the normal case 245 | ;; where only one extension was present. 246 | (make-pathname :name name 247 | :type ext 248 | :device (pathname-device path) 249 | :directory (pathname-directory path) 250 | :version :newest))) 251 | 252 | #+nil 253 | (drop-extension #p"/foo/bar/baz.json") 254 | #+nil 255 | (drop-extension #p"/foo/bar/baz.json.zip") 256 | 257 | (declaim (ftype (function ((or pathname string) string) pathname) add-extension)) 258 | (defun add-extension (path ext) 259 | "Add an extension to the given path, even if it already has one." 260 | (let* ((path (ensure-path path)) 261 | (already (extension path))) 262 | (if already 263 | ;; The pathname type only wants a single extension present in the 264 | ;; `:type' field, or else there is strange behaviour elsewhere (for 265 | ;; instance involving `to-string'). The old extension must thus become 266 | ;; part of the stem, and the only value reported by `extension' is the 267 | ;; new one, not the composite. This behaviour reflects that of Rust's 268 | ;; standard library. 269 | (make-pathname :name (concatenate 'string (base path) "." already) 270 | :type ext 271 | :device (pathname-device path) 272 | :directory (pathname-directory path) 273 | :version :newest) 274 | (with-extension path ext)))) 275 | 276 | #+nil 277 | (add-extension #p"/foo/bar/baz.txt" "zip") 278 | 279 | (declaim (ftype (function ((or pathname string) (or pathname string) &rest (or pathname string)) pathname) join)) 280 | (defun join (parent child &rest components) 281 | "Combine two or more components together." 282 | (let* ((parent (ensure-path parent)) 283 | (combined (remove-if (lambda (s) 284 | (or (string= +separator+ s) 285 | (string= "" s))) 286 | (mapcan #'components (cons child components)))) 287 | (final (car (last combined))) 288 | (rest (butlast combined)) 289 | (abs-or-rel (if (absolutep parent) :absolute :relative)) 290 | (par-comps (components parent)) 291 | (final-base (base final))) 292 | (make-pathname :name (cond 293 | #+sbcl 294 | ((string= "**" final-base) (sbcl-wildcard)) 295 | #+cmucl 296 | ((string= "**" final-base) (cmucl-wildcard)) 297 | #+(or abcl ccl allegro) 298 | ((string= "**" final-base) final-base) 299 | (t (keyword-if-special final-base))) 300 | :type (extension final) 301 | :version :newest 302 | :device (pathname-device parent) 303 | :directory (cons abs-or-rel 304 | (mapcar #'keyword-if-special 305 | (append (if (absolutep parent) 306 | (cdr par-comps) 307 | par-comps) 308 | rest)))))) 309 | 310 | #+nil 311 | #p"**.json" 312 | 313 | #+nil 314 | (join "/foo" "**.json") 315 | #+nil 316 | (join "/" "foo" "bar" ".." "." ".." "baz" "stuff.json") 317 | #+nil 318 | #p"/foo/bar/.././../baz/stuff.json" 319 | 320 | #+nil 321 | (join "/foo" "bar" "**" "*.json") 322 | 323 | #+nil 324 | (join "/foo" "bar" "**.json") 325 | 326 | #++ 327 | (join "/foo/" "*.*") 328 | 329 | #+nil 330 | (join "/foo" "bar" "baz" "test.json") 331 | #+nil 332 | (join "/foo/bar" "baz/test.json") 333 | 334 | (declaim (ftype (function ((or pathname string)) list) components)) 335 | (defun components (path) 336 | "Every component of a PATH broken up as a list." 337 | (cond ((empty? path) '()) 338 | ;; HACK 2024-06-17 Until ECL/Clasp support `**' in `:name' position. 339 | ;; 340 | ;; And not even a good hack, since it can be broken in cases where the 341 | ;; `**' comes at the end. 342 | #+(or ecl clasp) 343 | ((and (stringp path) (string= "**" path)) '("**")) 344 | (t (let* ((path (ensure-path path)) 345 | (comp (mapcar #'string-if-keyword (directory-parts path))) 346 | (list (if (directoryp path) 347 | comp 348 | (let* ((ext (extension path)) 349 | (file (if ext 350 | (concatenate 'string (base path) "." 351 | (string-if-keyword ext)) 352 | (base path)))) 353 | (append comp (list file)))))) 354 | (if (absolutep path) 355 | (cons "/" list) 356 | list))))) 357 | 358 | #+nil 359 | (components "/foo/bar/baz.json") 360 | #+nil 361 | (components "/foo/bar/.././../baz/stuff.json") 362 | #+nil 363 | (components "/foo/bar/./baz/stuff.json") 364 | #++ 365 | (components "foo/*.*") 366 | #+nil 367 | (components ".") 368 | #+nil 369 | (components "/.") 370 | #+nil 371 | (components "foo/.") 372 | #+nil 373 | #p"foo/." 374 | 375 | #+nil 376 | (pathname-directory #p"foo/bar/baz") 377 | #+nil 378 | (pathname-directory #p"./") 379 | 380 | (defun directory-parts (path) 381 | "Light post-processing around `pathname-directory' to ensure sanity." 382 | (let ((parts (pathname-directory path))) 383 | (if (and (eq :relative (car parts)) 384 | (null (cdr parts))) 385 | '(".") 386 | (cdr parts)))) 387 | 388 | #+nil 389 | (directory-parts #p"/foo/bar/baz.txt") 390 | #+nil 391 | (directory-parts #p"/.") 392 | #+nil 393 | (directory-parts #p"foo/.") 394 | #+nil 395 | (directory-parts #p"foo/./") 396 | 397 | (declaim (ftype (function (list) pathname) from-list)) 398 | (defun from-list (list) 399 | "Given a LIST of path components, construct a proper pathname object." 400 | (if (null list) 401 | #p"" 402 | (destructuring-bind (parent &rest rest) list 403 | (if (null rest) 404 | (ensure-path parent) 405 | (apply #'join parent (car rest) (cdr rest)))))) 406 | 407 | #+nil 408 | (from-list '("foo" "bar" "baz")) 409 | #+nil 410 | (from-list '("foo" "bar" "." "baz")) 411 | 412 | (declaim (ftype (function ((or pathname string)) pathname) ensure-directory)) 413 | (defun ensure-directory (path) 414 | "If a given PATH doesn't end in a path separator, add one." 415 | (let ((path (ensure-path path))) 416 | (if (directoryp path) 417 | path 418 | (make-pathname :name nil 419 | :type nil 420 | :device (pathname-device path) 421 | ;; NOTE: 2025-05-12 The result of `pathname-directory' 422 | ;; will be nil when a relative path with a single 423 | ;; component is given. In that case, we must help it 424 | ;; yield the correct structure to be appended to 425 | ;; immediately afterward. 426 | :directory (append (or (pathname-directory path) 427 | '(:relative)) 428 | (list (keyword-if-special (name path)))))))) 429 | 430 | #+nil 431 | (ensure-directory #p"/foo/bar/baz") 432 | #+nil 433 | (ensure-directory "/foo") 434 | #+nil 435 | (ensure-directory "foo") 436 | #+nil 437 | (ensure-directory #p"/foo/bar/*") 438 | #+nil 439 | (ensure-directory #p"/foo/bar/**") 440 | 441 | (declaim (ftype (function ((or pathname string)) simple-string) ensure-string)) 442 | (defun ensure-string (path) 443 | "A PATH is definitely a string after this." 444 | (if (pathnamep path) (to-string path) path)) 445 | 446 | (declaim (ftype (function (pathname) simple-string) to-string)) 447 | (defun to-string (path) 448 | "Convert a PATH object into string." 449 | (namestring path)) 450 | 451 | (declaim (ftype (function ((or pathname string)) pathname) ensure-path)) 452 | (defun ensure-path (path) 453 | "A PATH is definitely a pathname after this." 454 | (if (pathnamep path) path (from-string path))) 455 | 456 | #+nil 457 | (ensure-path ".") 458 | #+nil 459 | (ensure-path "/.") 460 | #+nil 461 | (ensure-path "foo/bar/.") 462 | #+nil 463 | (ensure-path "/foo/./bar/foo.txt") 464 | 465 | #p"foo/./bar/./baz" 466 | 467 | ;; NOTE: 2025-08-17 Unfortunately, CMUCL can't be stopped from stripping "." 468 | ;; components from the directory field. Even if I manually add them back in a 469 | ;; `make-pathname', it still strips them. This effect trickles up to 470 | ;; `components', which suffers if a dot exists in the input. 471 | (declaim (ftype (function (string) pathname) from-string)) 472 | (defun from-string (s) 473 | "Convert a string into a proper filepath object." 474 | (pathname s)) 475 | 476 | #+nil 477 | (from-string ".") 478 | 479 | #+nil 480 | (from-string "foo/.") 481 | 482 | #+nil 483 | (join "/" "foo" "bar" ".." "." ".." "baz" "stuff.json") 484 | 485 | #+nil 486 | (pathname "/foo/bar/.././../baz/test.json") 487 | 488 | #+nil 489 | (pathname "/foo/bar/../baz/test.json") 490 | 491 | #+nil 492 | #p"/foo/bar/.././../baz/test.json" 493 | 494 | ;; --- Conditions --- ;; 495 | 496 | (define-condition no-filename (error) 497 | ((path :initarg :path :reader no-filename-path)) 498 | (:documentation "The given path was expected to be a filename, but it may have been a directory 499 | or empty string instead.") 500 | (:report (lambda (condition stream) 501 | (format stream "The given path was expected to be a filename: ~a" 502 | (no-filename-path condition))))) 503 | 504 | (define-condition empty-path (error) 505 | () 506 | (:documentation "A non-empty path was expected, but an empty one was given.") 507 | (:report (lambda (condition stream) 508 | (declare (ignore condition)) 509 | (format stream "Empty path given where a concrete one was expected.")))) 510 | 511 | (define-condition root-no-parent (error) 512 | () 513 | (:documentation "The filesystem root has no parent.") 514 | (:report (lambda (condition stream) 515 | (declare (ignore condition)) 516 | (format stream "The filesystem root has no parent.")))) 517 | 518 | ;; --- Utilities --- ;; 519 | 520 | (declaim (ftype (function (t) string) string-if-keyword-impl-specific)) 521 | (defun string-if-keyword-impl-specific (item) 522 | "Like `string-if-keyword' but with special consideration for implementations. 523 | Assumed to be used internally within `base' to account for when the file base is 524 | a wildcard character." 525 | (cond 526 | #+sbcl 527 | ((sb-impl::pattern-p item) "**") ; FIXME 2024-06-16 Actually check the contents. 528 | #+cmucl 529 | ((lisp::pattern-p item) "**") 530 | (t (string-if-keyword item)))) 531 | 532 | (declaim (ftype (function ((or string keyword)) string) string-if-keyword)) 533 | (defun string-if-keyword (item) 534 | "There are certain keywords that represent special path components. These need to 535 | be converted back into their original string representations if present." 536 | (cond ((or (eq item :up) (eq item :back)) "..") 537 | ((eq item :wild) "*") 538 | ((eq item :wild-inferiors) "**") 539 | (t item))) 540 | 541 | #+nil 542 | (string-if-keyword :up) 543 | 544 | (declaim (ftype (function (string) (or string keyword)) keyword-if-special)) 545 | (defun keyword-if-special (item) 546 | "Like `string-if-keyword', certain strings need to be converted to keywords 547 | before being stored in the `:directory' portion of a pathname." 548 | (cond ((string-equal ".." item) :up) 549 | ((string-equal "**" item) :wild-inferiors) 550 | ((string-equal "*" item) :wild) 551 | (t item))) 552 | 553 | #+sbcl 554 | (defun sbcl-wildcard () 555 | "A SBCL-specific pattern type created when a ** appears in a path." 556 | (sb-impl::make-pattern '(:multi-char-wild :multi-char-wild))) 557 | 558 | #+cmucl 559 | (defun cmucl-wildcard () 560 | "A CMUCL-specific pattern type created when a ** appears in a path." 561 | (lisp::make-pattern '(:multi-char-wild :multi-char-wild))) 562 | --------------------------------------------------------------------------------