pathname.lisp - clic - Clic is an command line interactive client for gopher written in Common LISP (HTM) git clone git://bitreich.org/clic/ git://enlrupgkhuxnvlhsf6lc3fziv5h2hhfrinws65d7roiv6bfj7d652fid.onion/clic/ (DIR) Log (DIR) Files (DIR) Refs (DIR) Tags (DIR) README (DIR) LICENSE --- pathname.lisp (37872B) --- 1 ;;;; ------------------------------------------------------------------------- 2 ;;;; Portability layer around Common Lisp pathnames 3 ;; This layer allows for portable manipulation of pathname objects themselves, 4 ;; which all is necessary prior to any access the filesystem or environment. 5 6 (uiop/package:define-package :uiop/pathname 7 (:nicknames :asdf/pathname) ;; deprecated. Used by ceramic 8 (:use :uiop/common-lisp :uiop/package :uiop/utility :uiop/os) 9 (:export 10 ;; Making and merging pathnames, portably 11 #:normalize-pathname-directory-component #:denormalize-pathname-directory-component 12 #:merge-pathname-directory-components #:*unspecific-pathname-type* #:make-pathname* 13 #:make-pathname-component-logical #:make-pathname-logical 14 #:merge-pathnames* 15 #:nil-pathname #:*nil-pathname* #:with-pathname-defaults 16 ;; Predicates 17 #:pathname-equal #:logical-pathname-p #:physical-pathname-p #:physicalize-pathname 18 #:absolute-pathname-p #:relative-pathname-p #:hidden-pathname-p #:file-pathname-p 19 ;; Directories 20 #:pathname-directory-pathname #:pathname-parent-directory-pathname 21 #:directory-pathname-p #:ensure-directory-pathname 22 ;; Parsing filenames 23 #:split-name-type #:parse-unix-namestring #:unix-namestring 24 #:split-unix-namestring-directory-components 25 ;; Absolute and relative pathnames 26 #:subpathname #:subpathname* 27 #:ensure-absolute-pathname 28 #:pathname-root #:pathname-host-pathname 29 #:subpathp #:enough-pathname #:with-enough-pathname #:call-with-enough-pathname 30 ;; Checking constraints 31 #:ensure-pathname ;; implemented in filesystem.lisp to accommodate for existence constraints 32 ;; Wildcard pathnames 33 #:*wild* #:*wild-file* #:*wild-file-for-directory* #:*wild-directory* 34 #:*wild-inferiors* #:*wild-path* #:wilden 35 ;; Translate a pathname 36 #:relativize-directory-component #:relativize-pathname-directory 37 #:directory-separator-for-host #:directorize-pathname-host-device 38 #:translate-pathname* 39 #:*output-translation-function*)) 40 (in-package :uiop/pathname) 41 42 ;;; Normalizing pathnames across implementations 43 44 (with-upgradability () 45 (defun normalize-pathname-directory-component (directory) 46 "Convert the DIRECTORY component from a format usable by the underlying 47 implementation's MAKE-PATHNAME and other primitives to a CLHS-standard format 48 that is a list and not a string." 49 (cond 50 #-(or cmucl sbcl scl) ;; these implementations already normalize directory components. 51 ((stringp directory) `(:absolute ,directory)) 52 ((or (null directory) 53 (and (consp directory) (member (first directory) '(:absolute :relative)))) 54 directory) 55 #+gcl 56 ((consp directory) 57 (cons :relative directory)) 58 (t 59 (parameter-error (compatfmt "~@<~S: Unrecognized pathname directory component ~S~@:>") 60 'normalize-pathname-directory-component directory)))) 61 62 (defun denormalize-pathname-directory-component (directory-component) 63 "Convert the DIRECTORY-COMPONENT from a CLHS-standard format to a format usable 64 by the underlying implementation's MAKE-PATHNAME and other primitives" 65 directory-component) 66 67 (defun merge-pathname-directory-components (specified defaults) 68 "Helper for MERGE-PATHNAMES* that handles directory components" 69 (let ((directory (normalize-pathname-directory-component specified))) 70 (ecase (first directory) 71 ((nil) defaults) 72 (:absolute specified) 73 (:relative 74 (let ((defdir (normalize-pathname-directory-component defaults)) 75 (reldir (cdr directory))) 76 (cond 77 ((null defdir) 78 directory) 79 ((not (eq :back (first reldir))) 80 (append defdir reldir)) 81 (t 82 (loop :with defabs = (first defdir) 83 :with defrev = (reverse (rest defdir)) 84 :while (and (eq :back (car reldir)) 85 (or (and (eq :absolute defabs) (null defrev)) 86 (stringp (car defrev)))) 87 :do (pop reldir) (pop defrev) 88 :finally (return (cons defabs (append (reverse defrev) reldir))))))))))) 89 90 ;; Giving :unspecific as :type argument to make-pathname is not portable. 91 ;; See CLHS make-pathname and 19.2.2.2.3. 92 ;; This will be :unspecific if supported, or NIL if not. 93 (defparameter *unspecific-pathname-type* 94 #+(or abcl allegro clozure cmucl lispworks sbcl scl) :unspecific 95 #+(or genera clasp clisp ecl mkcl gcl xcl #|These haven't been tested:|# cormanlisp mcl mezzano) nil 96 "Unspecific type component to use with the underlying implementation's MAKE-PATHNAME") 97 98 (defun make-pathname* (&rest keys &key directory host device name type version defaults 99 #+scl &allow-other-keys) 100 "Takes arguments like CL:MAKE-PATHNAME in the CLHS, and 101 tries hard to make a pathname that will actually behave as documented, 102 despite the peculiarities of each implementation. DEPRECATED: just use MAKE-PATHNAME." 103 (declare (ignore host device directory name type version defaults)) 104 (apply 'make-pathname keys)) 105 106 (defun make-pathname-component-logical (x) 107 "Make a pathname component suitable for use in a logical-pathname" 108 (typecase x 109 ((eql :unspecific) nil) 110 #+clisp (string (string-upcase x)) 111 #+clisp (cons (mapcar 'make-pathname-component-logical x)) 112 (t x))) 113 114 (defun make-pathname-logical (pathname host) 115 "Take a PATHNAME's directory, name, type and version components, 116 and make a new pathname with corresponding components and specified logical HOST" 117 (make-pathname 118 :host host 119 :directory (make-pathname-component-logical (pathname-directory pathname)) 120 :name (make-pathname-component-logical (pathname-name pathname)) 121 :type (make-pathname-component-logical (pathname-type pathname)) 122 :version (make-pathname-component-logical (pathname-version pathname)))) 123 124 (defun merge-pathnames* (specified &optional (defaults *default-pathname-defaults*)) 125 "MERGE-PATHNAMES* is like MERGE-PATHNAMES except that 126 if the SPECIFIED pathname does not have an absolute directory, 127 then the HOST and DEVICE both come from the DEFAULTS, whereas 128 if the SPECIFIED pathname does have an absolute directory, 129 then the HOST and DEVICE both come from the SPECIFIED pathname. 130 This is what users want on a modern Unix or Windows operating system, 131 unlike the MERGE-PATHNAMES behavior. 132 Also, if either argument is NIL, then the other argument is returned unmodified; 133 this is unlike MERGE-PATHNAMES which always merges with a pathname, 134 by default *DEFAULT-PATHNAME-DEFAULTS*, which cannot be NIL." 135 (when (null specified) (return-from merge-pathnames* defaults)) 136 (when (null defaults) (return-from merge-pathnames* specified)) 137 #+scl 138 (ext:resolve-pathname specified defaults) 139 #-scl 140 (let* ((specified (pathname specified)) 141 (defaults (pathname defaults)) 142 (directory (normalize-pathname-directory-component (pathname-directory specified))) 143 (name (or (pathname-name specified) (pathname-name defaults))) 144 (type (or (pathname-type specified) (pathname-type defaults))) 145 (version (or (pathname-version specified) (pathname-version defaults)))) 146 (labels ((unspecific-handler (p) 147 (if (typep p 'logical-pathname) #'make-pathname-component-logical #'identity))) 148 (multiple-value-bind (host device directory unspecific-handler) 149 (ecase (first directory) 150 ((:absolute) 151 (values (pathname-host specified) 152 (pathname-device specified) 153 directory 154 (unspecific-handler specified))) 155 ((nil :relative) 156 (values (pathname-host defaults) 157 (pathname-device defaults) 158 (merge-pathname-directory-components directory (pathname-directory defaults)) 159 (unspecific-handler defaults)))) 160 (make-pathname :host host :device device :directory directory 161 :name (funcall unspecific-handler name) 162 :type (funcall unspecific-handler type) 163 :version (funcall unspecific-handler version)))))) 164 165 (defun logical-pathname-p (x) 166 "is X a logical-pathname?" 167 (typep x 'logical-pathname)) 168 169 (defun physical-pathname-p (x) 170 "is X a pathname that is not a logical-pathname?" 171 (and (pathnamep x) (not (logical-pathname-p x)))) 172 173 (defun physicalize-pathname (x) 174 "if X is a logical pathname, use translate-logical-pathname on it." 175 ;; Ought to be the same as translate-logical-pathname, except the latter borks on CLISP 176 (let ((p (when x (pathname x)))) 177 (if (logical-pathname-p p) (translate-logical-pathname p) p))) 178 179 (defun nil-pathname (&optional (defaults *default-pathname-defaults*)) 180 "A pathname that is as neutral as possible for use as defaults 181 when merging, making or parsing pathnames" 182 ;; 19.2.2.2.1 says a NIL host can mean a default host; 183 ;; see also "valid physical pathname host" in the CLHS glossary, that suggests 184 ;; strings and lists of strings or :unspecific 185 ;; But CMUCL decides to die on NIL. 186 ;; MCL has issues with make-pathname, nil and defaulting 187 (declare (ignorable defaults)) 188 #.`(make-pathname :directory nil :name nil :type nil :version nil 189 :device (or #+(and mkcl os-unix) :unspecific) 190 :host (or #+cmucl lisp::*unix-host* #+(and mkcl os-unix) "localhost") 191 #+scl ,@'(:scheme nil :scheme-specific-part nil 192 :username nil :password nil :parameters nil :query nil :fragment nil) 193 ;; the default shouldn't matter, but we really want something physical 194 #-mcl ,@'(:defaults defaults))) 195 196 (defvar *nil-pathname* (nil-pathname (physicalize-pathname (user-homedir-pathname))) 197 "A pathname that is as neutral as possible for use as defaults 198 when merging, making or parsing pathnames") 199 200 (defmacro with-pathname-defaults ((&optional defaults) &body body) 201 "Execute BODY in a context where the *DEFAULT-PATHNAME-DEFAULTS* is as specified, 202 where leaving the defaults NIL or unspecified means a (NIL-PATHNAME), except 203 on ABCL, Genera and XCL, where it remains unchanged for it doubles as current-directory." 204 `(let ((*default-pathname-defaults* 205 ,(or defaults 206 #-(or abcl genera xcl) '*nil-pathname* 207 #+(or abcl genera xcl) '*default-pathname-defaults*))) 208 ,@body))) 209 210 211 ;;; Some pathname predicates 212 (with-upgradability () 213 (defun pathname-equal (p1 p2) 214 "Are the two pathnames P1 and P2 reasonably equal in the paths they denote?" 215 (when (stringp p1) (setf p1 (pathname p1))) 216 (when (stringp p2) (setf p2 (pathname p2))) 217 (flet ((normalize-component (x) 218 (unless (member x '(nil :unspecific :newest (:relative)) :test 'equal) 219 x))) 220 (macrolet ((=? (&rest accessors) 221 (flet ((frob (x) 222 (reduce 'list (cons 'normalize-component accessors) 223 :initial-value x :from-end t))) 224 `(equal ,(frob 'p1) ,(frob 'p2))))) 225 (or (and (null p1) (null p2)) 226 (and (pathnamep p1) (pathnamep p2) 227 (and (=? pathname-host) 228 #-(and mkcl os-unix) (=? pathname-device) 229 (=? normalize-pathname-directory-component pathname-directory) 230 (=? pathname-name) 231 (=? pathname-type) 232 #-mkcl (=? pathname-version))))))) 233 234 (defun absolute-pathname-p (pathspec) 235 "If PATHSPEC is a pathname or namestring object that parses as a pathname 236 possessing an :ABSOLUTE directory component, return the (parsed) pathname. 237 Otherwise return NIL" 238 (and pathspec 239 (typep pathspec '(or null pathname string)) 240 (let ((pathname (pathname pathspec))) 241 (and (eq :absolute (car (normalize-pathname-directory-component 242 (pathname-directory pathname)))) 243 pathname)))) 244 245 (defun relative-pathname-p (pathspec) 246 "If PATHSPEC is a pathname or namestring object that parses as a pathname 247 possessing a :RELATIVE or NIL directory component, return the (parsed) pathname. 248 Otherwise return NIL" 249 (and pathspec 250 (typep pathspec '(or null pathname string)) 251 (let* ((pathname (pathname pathspec)) 252 (directory (normalize-pathname-directory-component 253 (pathname-directory pathname)))) 254 (when (or (null directory) (eq :relative (car directory))) 255 pathname)))) 256 257 (defun hidden-pathname-p (pathname) 258 "Return a boolean that is true if the pathname is hidden as per Unix style, 259 i.e. its name starts with a dot." 260 (and pathname (equal (first-char (pathname-name pathname)) #\.))) 261 262 (defun file-pathname-p (pathname) 263 "Does PATHNAME represent a file, i.e. has a non-null NAME component? 264 265 Accepts NIL, a string (converted through PARSE-NAMESTRING) or a PATHNAME. 266 267 Note that this does _not_ check to see that PATHNAME points to an 268 actually-existing file. 269 270 Returns the (parsed) PATHNAME when true" 271 (when pathname 272 (let ((pathname (pathname pathname))) 273 (unless (and (member (pathname-name pathname) '(nil :unspecific "") :test 'equal) 274 (member (pathname-type pathname) '(nil :unspecific "") :test 'equal)) 275 pathname))))) 276 277 278 ;;; Directory pathnames 279 (with-upgradability () 280 (defun pathname-directory-pathname (pathname) 281 "Returns a new pathname with same HOST, DEVICE, DIRECTORY as PATHNAME, 282 and NIL NAME, TYPE and VERSION components" 283 (when pathname 284 (make-pathname :name nil :type nil :version nil :defaults pathname))) 285 286 (defun pathname-parent-directory-pathname (pathname) 287 "Returns a new pathname that corresponds to the parent of the current pathname's directory, 288 i.e. removing one level of depth in the DIRECTORY component. e.g. if pathname is 289 Unix pathname /foo/bar/baz/file.type then return /foo/bar/" 290 (when pathname 291 (make-pathname :name nil :type nil :version nil 292 :directory (merge-pathname-directory-components 293 '(:relative :back) (pathname-directory pathname)) 294 :defaults pathname))) 295 296 (defun directory-pathname-p (pathname) 297 "Does PATHNAME represent a directory? 298 299 A directory-pathname is a pathname _without_ a filename. The three 300 ways that the filename components can be missing are for it to be NIL, 301 :UNSPECIFIC or the empty string. 302 303 Note that this does _not_ check to see that PATHNAME points to an 304 actually-existing directory." 305 (when pathname 306 ;; I tried using Allegro's excl:file-directory-p, but this cannot be done, 307 ;; because it rejects apparently legal pathnames as 308 ;; ill-formed. [2014/02/10:rpg] 309 (let ((pathname (pathname pathname))) 310 (flet ((check-one (x) 311 (member x '(nil :unspecific) :test 'equal))) 312 (and (not (wild-pathname-p pathname)) 313 (check-one (pathname-name pathname)) 314 (check-one (pathname-type pathname)) 315 t))))) 316 317 (defun ensure-directory-pathname (pathspec &optional (on-error 'error)) 318 "Converts the non-wild pathname designator PATHSPEC to directory form." 319 (cond 320 ((stringp pathspec) 321 (ensure-directory-pathname (pathname pathspec))) 322 ((not (pathnamep pathspec)) 323 (call-function on-error (compatfmt "~@<Invalid pathname designator ~S~@:>") pathspec)) 324 ((wild-pathname-p pathspec) 325 (call-function on-error (compatfmt "~@<Can't reliably convert wild pathname ~3i~_~S~@:>") pathspec)) 326 ((directory-pathname-p pathspec) 327 pathspec) 328 (t 329 (handler-case 330 (make-pathname :directory (append (or (normalize-pathname-directory-component 331 (pathname-directory pathspec)) 332 (list :relative)) 333 (list #-genera (file-namestring pathspec) 334 ;; On Genera's native filesystem (LMFS), 335 ;; directories have a type and version 336 ;; which must be ignored when converting 337 ;; to a directory pathname 338 #+genera (if (typep pathspec 'fs:lmfs-pathname) 339 (pathname-name pathspec) 340 (file-namestring pathspec)))) 341 :name nil :type nil :version nil :defaults pathspec) 342 (error (c) (call-function on-error (compatfmt "~@<error while trying to create a directory pathname for ~S: ~A~@:>") pathspec c))))))) 343 344 345 ;;; Parsing filenames 346 (with-upgradability () 347 (declaim (ftype function ensure-pathname)) ; forward reference 348 349 (defun split-unix-namestring-directory-components 350 (unix-namestring &key ensure-directory dot-dot) 351 "Splits the path string UNIX-NAMESTRING, returning four values: 352 A flag that is either :absolute or :relative, indicating 353 how the rest of the values are to be interpreted. 354 A directory path --- a list of strings and keywords, suitable for 355 use with MAKE-PATHNAME when prepended with the flag value. 356 Directory components with an empty name or the name . are removed. 357 Any directory named .. is read as DOT-DOT, or :BACK if it's NIL (not :UP). 358 A last-component, either a file-namestring including type extension, 359 or NIL in the case of a directory pathname. 360 A flag that is true iff the unix-style-pathname was just 361 a file-namestring without / path specification. 362 ENSURE-DIRECTORY forces the namestring to be interpreted as a directory pathname: 363 the third return value will be NIL, and final component of the namestring 364 will be treated as part of the directory path. 365 366 An empty string is thus read as meaning a pathname object with all fields nil. 367 368 Note that colon characters #\: will NOT be interpreted as host specification. 369 Absolute pathnames are only appropriate on Unix-style systems. 370 371 The intention of this function is to support structured component names, 372 e.g., \(:file \"foo/bar\"\), which will be unpacked to relative pathnames." 373 (check-type unix-namestring string) 374 (check-type dot-dot (member nil :back :up)) 375 (if (and (not (find #\/ unix-namestring)) (not ensure-directory) 376 (plusp (length unix-namestring))) 377 (values :relative () unix-namestring t) 378 (let* ((components (split-string unix-namestring :separator "/")) 379 (last-comp (car (last components)))) 380 (multiple-value-bind (relative components) 381 (if (equal (first components) "") 382 (if (equal (first-char unix-namestring) #\/) 383 (values :absolute (cdr components)) 384 (values :relative nil)) 385 (values :relative components)) 386 (setf components (remove-if #'(lambda (x) (member x '("" ".") :test #'equal)) 387 components)) 388 (setf components (substitute (or dot-dot :back) ".." components :test #'equal)) 389 (cond 390 ((equal last-comp "") 391 (values relative components nil nil)) ; "" already removed from components 392 (ensure-directory 393 (values relative components nil nil)) 394 (t 395 (values relative (butlast components) last-comp nil))))))) 396 397 (defun split-name-type (filename) 398 "Split a filename into two values NAME and TYPE that are returned. 399 We assume filename has no directory component. 400 The last . if any separates name and type from from type, 401 except that if there is only one . and it is in first position, 402 the whole filename is the NAME with an empty type. 403 NAME is always a string. 404 For an empty type, *UNSPECIFIC-PATHNAME-TYPE* is returned." 405 (check-type filename string) 406 (assert (plusp (length filename))) 407 (destructuring-bind (name &optional (type *unspecific-pathname-type*)) 408 (split-string filename :max 2 :separator ".") 409 (if (equal name "") 410 (values filename *unspecific-pathname-type*) 411 (values name type)))) 412 413 (defun parse-unix-namestring (name &rest keys &key type defaults dot-dot ensure-directory 414 &allow-other-keys) 415 "Coerce NAME into a PATHNAME using standard Unix syntax. 416 417 Unix syntax is used whether or not the underlying system is Unix; 418 on such non-Unix systems it is reliably usable only for relative pathnames. 419 This function is especially useful to manipulate relative pathnames portably, 420 where it is of crucial to possess a portable pathname syntax independent of the underlying OS. 421 This is what PARSE-UNIX-NAMESTRING provides, and why we use it in ASDF. 422 423 When given a PATHNAME object, just return it untouched. 424 When given NIL, just return NIL. 425 When given a non-null SYMBOL, first downcase its name and treat it as a string. 426 When given a STRING, portably decompose it into a pathname as below. 427 428 #\\/ separates directory components. 429 430 The last #\\/-separated substring is interpreted as follows: 431 1- If TYPE is :DIRECTORY or ENSURE-DIRECTORY is true, 432 the string is made the last directory component, and NAME and TYPE are NIL. 433 if the string is empty, it's the empty pathname with all slots NIL. 434 2- If TYPE is NIL, the substring is a file-namestring, and its NAME and TYPE 435 are separated by SPLIT-NAME-TYPE. 436 3- If TYPE is a string, it is the given TYPE, and the whole string is the NAME. 437 438 Directory components with an empty name or the name \".\" are removed. 439 Any directory named \"..\" is read as DOT-DOT, 440 which must be one of :BACK or :UP and defaults to :BACK. 441 442 HOST, DEVICE and VERSION components are taken from DEFAULTS, 443 which itself defaults to *NIL-PATHNAME*, also used if DEFAULTS is NIL. 444 No host or device can be specified in the string itself, 445 which makes it unsuitable for absolute pathnames outside Unix. 446 447 For relative pathnames, these components (and hence the defaults) won't matter 448 if you use MERGE-PATHNAMES* but will matter if you use MERGE-PATHNAMES, 449 which is an important reason to always use MERGE-PATHNAMES*. 450 451 Arbitrary keys are accepted, and the parse result is passed to ENSURE-PATHNAME 452 with those keys, removing TYPE DEFAULTS and DOT-DOT. 453 When you're manipulating pathnames that are supposed to make sense portably 454 even though the OS may not be Unixish, we recommend you use :WANT-RELATIVE T 455 to throw an error if the pathname is absolute" 456 (block nil 457 (check-type type (or null string (eql :directory))) 458 (when ensure-directory 459 (setf type :directory)) 460 (etypecase name 461 ((or null pathname) (return name)) 462 (symbol 463 (setf name (string-downcase name))) 464 (string)) 465 (multiple-value-bind (relative path filename file-only) 466 (split-unix-namestring-directory-components 467 name :dot-dot dot-dot :ensure-directory (eq type :directory)) 468 (multiple-value-bind (name type) 469 (cond 470 ((or (eq type :directory) (null filename)) 471 (values nil nil)) 472 (type 473 (values filename type)) 474 (t 475 (split-name-type filename))) 476 (apply 'ensure-pathname 477 (make-pathname 478 :directory (unless file-only (cons relative path)) 479 :name name :type type 480 :defaults (or #-mcl defaults *nil-pathname*)) 481 (remove-plist-keys '(:type :dot-dot :defaults) keys)))))) 482 483 (defun unix-namestring (pathname) 484 "Given a non-wild PATHNAME, return a Unix-style namestring for it. 485 If the PATHNAME is NIL or a STRING, return it unchanged. 486 487 This only considers the DIRECTORY, NAME and TYPE components of the pathname. 488 This is a portable solution for representing relative pathnames, 489 But unless you are running on a Unix system, it is not a general solution 490 to representing native pathnames. 491 492 An error is signaled if the argument is not NULL, a STRING or a PATHNAME, 493 or if it is a PATHNAME but some of its components are not recognized." 494 (etypecase pathname 495 ((or null string) pathname) 496 (pathname 497 (with-output-to-string (s) 498 (flet ((err () (parameter-error "~S: invalid unix-namestring ~S" 499 'unix-namestring pathname))) 500 (let* ((dir (normalize-pathname-directory-component (pathname-directory pathname))) 501 (name (pathname-name pathname)) 502 (name (and (not (eq name :unspecific)) name)) 503 (type (pathname-type pathname)) 504 (type (and (not (eq type :unspecific)) type))) 505 (cond 506 ((member dir '(nil :unspecific))) 507 ((eq dir '(:relative)) (princ "./" s)) 508 ((consp dir) 509 (destructuring-bind (relabs &rest dirs) dir 510 (or (member relabs '(:relative :absolute)) (err)) 511 (when (eq relabs :absolute) (princ #\/ s)) 512 (loop :for x :in dirs :do 513 (cond 514 ((member x '(:back :up)) (princ "../" s)) 515 ((equal x "") (err)) 516 ;;((member x '("." "..") :test 'equal) (err)) 517 ((stringp x) (format s "~A/" x)) 518 (t (err)))))) 519 (t (err))) 520 (cond 521 (name 522 (unless (and (stringp name) (or (null type) (stringp type))) (err)) 523 (format s "~A~@[.~A~]" name type)) 524 (t 525 (or (null type) (err))))))))))) 526 527 ;;; Absolute and relative pathnames 528 (with-upgradability () 529 (defun subpathname (pathname subpath &key type) 530 "This function takes a PATHNAME and a SUBPATH and a TYPE. 531 If SUBPATH is already a PATHNAME object (not namestring), 532 and is an absolute pathname at that, it is returned unchanged; 533 otherwise, SUBPATH is turned into a relative pathname with given TYPE 534 as per PARSE-UNIX-NAMESTRING with :WANT-RELATIVE T :TYPE TYPE, 535 then it is merged with the PATHNAME-DIRECTORY-PATHNAME of PATHNAME." 536 (or (and (pathnamep subpath) (absolute-pathname-p subpath)) 537 (merge-pathnames* (parse-unix-namestring subpath :type type :want-relative t) 538 (pathname-directory-pathname pathname)))) 539 540 (defun subpathname* (pathname subpath &key type) 541 "returns NIL if the base pathname is NIL, otherwise like SUBPATHNAME." 542 (and pathname 543 (subpathname (ensure-directory-pathname pathname) subpath :type type))) 544 545 (defun pathname-root (pathname) 546 "return the root directory for the host and device of given PATHNAME" 547 (make-pathname :directory '(:absolute) 548 :name nil :type nil :version nil 549 :defaults pathname ;; host device, and on scl, *some* 550 ;; scheme-specific parts: port username password, not others: 551 . #.(or #+scl '(:parameters nil :query nil :fragment nil)))) 552 553 (defun pathname-host-pathname (pathname) 554 "return a pathname with the same host as given PATHNAME, and all other fields NIL" 555 (make-pathname :directory nil 556 :name nil :type nil :version nil :device nil 557 :defaults pathname ;; host device, and on scl, *some* 558 ;; scheme-specific parts: port username password, not others: 559 . #.(or #+scl '(:parameters nil :query nil :fragment nil)))) 560 561 (defun ensure-absolute-pathname (path &optional defaults (on-error 'error)) 562 "Given a pathname designator PATH, return an absolute pathname as specified by PATH 563 considering the DEFAULTS, or, if not possible, use CALL-FUNCTION on the specified ON-ERROR behavior, 564 with a format control-string and other arguments as arguments" 565 (cond 566 ((absolute-pathname-p path)) 567 ((stringp path) (ensure-absolute-pathname (pathname path) defaults on-error)) 568 ((not (pathnamep path)) (call-function on-error "not a valid pathname designator ~S" path)) 569 ((let ((default-pathname (if (pathnamep defaults) defaults (call-function defaults)))) 570 (or (if (absolute-pathname-p default-pathname) 571 (absolute-pathname-p (merge-pathnames* path default-pathname)) 572 (call-function on-error "Default pathname ~S is not an absolute pathname" 573 default-pathname)) 574 (call-function on-error "Failed to merge ~S with ~S into an absolute pathname" 575 path default-pathname)))) 576 (t (call-function on-error 577 "Cannot ensure ~S is evaluated as an absolute pathname with defaults ~S" 578 path defaults)))) 579 580 (defun subpathp (maybe-subpath base-pathname) 581 "if MAYBE-SUBPATH is a pathname that is under BASE-PATHNAME, return a pathname object that 582 when used with MERGE-PATHNAMES* with defaults BASE-PATHNAME, returns MAYBE-SUBPATH." 583 (and (pathnamep maybe-subpath) (pathnamep base-pathname) 584 (absolute-pathname-p maybe-subpath) (absolute-pathname-p base-pathname) 585 (directory-pathname-p base-pathname) (not (wild-pathname-p base-pathname)) 586 (pathname-equal (pathname-root maybe-subpath) (pathname-root base-pathname)) 587 (with-pathname-defaults (*nil-pathname*) 588 (let ((enough (enough-namestring maybe-subpath base-pathname))) 589 (and (relative-pathname-p enough) (pathname enough)))))) 590 591 (defun enough-pathname (maybe-subpath base-pathname) 592 "if MAYBE-SUBPATH is a pathname that is under BASE-PATHNAME, return a pathname object that 593 when used with MERGE-PATHNAMES* with defaults BASE-PATHNAME, returns MAYBE-SUBPATH." 594 (let ((sub (when maybe-subpath (pathname maybe-subpath))) 595 (base (when base-pathname (ensure-absolute-pathname (pathname base-pathname))))) 596 (or (and base (subpathp sub base)) sub))) 597 598 (defun call-with-enough-pathname (maybe-subpath defaults-pathname thunk) 599 "In a context where *DEFAULT-PATHNAME-DEFAULTS* is bound to DEFAULTS-PATHNAME (if not null, 600 or else to its current value), call THUNK with ENOUGH-PATHNAME for MAYBE-SUBPATH 601 given DEFAULTS-PATHNAME as a base pathname." 602 (let ((enough (enough-pathname maybe-subpath defaults-pathname)) 603 (*default-pathname-defaults* (or defaults-pathname *default-pathname-defaults*))) 604 (funcall thunk enough))) 605 606 (defmacro with-enough-pathname ((pathname-var &key (pathname pathname-var) 607 (defaults *default-pathname-defaults*)) 608 &body body) 609 "Shorthand syntax for CALL-WITH-ENOUGH-PATHNAME" 610 `(call-with-enough-pathname ,pathname ,defaults #'(lambda (,pathname-var) ,@body)))) 611 612 613 ;;; Wildcard pathnames 614 (with-upgradability () 615 (defparameter *wild* (or #+cormanlisp "*" :wild) 616 "Wild component for use with MAKE-PATHNAME") 617 (defparameter *wild-directory-component* (or :wild) 618 "Wild directory component for use with MAKE-PATHNAME") 619 (defparameter *wild-inferiors-component* (or :wild-inferiors) 620 "Wild-inferiors directory component for use with MAKE-PATHNAME") 621 (defparameter *wild-file* 622 (make-pathname :directory nil :name *wild* :type *wild* 623 :version (or #-(or allegro abcl xcl) *wild*)) 624 "A pathname object with wildcards for matching any file with TRANSLATE-PATHNAME") 625 (defparameter *wild-file-for-directory* 626 (make-pathname :directory nil :name *wild* :type (or #-(or clisp gcl) *wild*) 627 :version (or #-(or allegro abcl clisp gcl xcl) *wild*)) 628 "A pathname object with wildcards for matching any file with DIRECTORY") 629 (defparameter *wild-directory* 630 (make-pathname :directory `(:relative ,*wild-directory-component*) 631 :name nil :type nil :version nil) 632 "A pathname object with wildcards for matching any subdirectory") 633 (defparameter *wild-inferiors* 634 (make-pathname :directory `(:relative ,*wild-inferiors-component*) 635 :name nil :type nil :version nil) 636 "A pathname object with wildcards for matching any recursive subdirectory") 637 (defparameter *wild-path* 638 (merge-pathnames* *wild-file* *wild-inferiors*) 639 "A pathname object with wildcards for matching any file in any recursive subdirectory") 640 641 (defun wilden (path) 642 "From a pathname, return a wildcard pathname matching any file in any subdirectory of given pathname's directory" 643 (merge-pathnames* *wild-path* path))) 644 645 646 ;;; Translate a pathname 647 (with-upgradability () 648 (defun relativize-directory-component (directory-component) 649 "Given the DIRECTORY-COMPONENT of a pathname, return an otherwise similar relative directory component" 650 (let ((directory (normalize-pathname-directory-component directory-component))) 651 (cond 652 ((stringp directory) 653 (list :relative directory)) 654 ((eq (car directory) :absolute) 655 (cons :relative (cdr directory))) 656 (t 657 directory)))) 658 659 (defun relativize-pathname-directory (pathspec) 660 "Given a PATHNAME, return a relative pathname with otherwise the same components" 661 (let ((p (pathname pathspec))) 662 (make-pathname 663 :directory (relativize-directory-component (pathname-directory p)) 664 :defaults p))) 665 666 (defun directory-separator-for-host (&optional (pathname *default-pathname-defaults*)) 667 "Given a PATHNAME, return the character used to delimit directory names on this host and device." 668 (let ((foo (make-pathname :directory '(:absolute "FOO") :defaults pathname))) 669 (last-char (namestring foo)))) 670 671 #-scl 672 (defun directorize-pathname-host-device (pathname) 673 "Given a PATHNAME, return a pathname that has representations of its HOST and DEVICE components 674 added to its DIRECTORY component. This is useful for output translations." 675 (os-cond 676 ((os-unix-p) 677 (when (physical-pathname-p pathname) 678 (return-from directorize-pathname-host-device pathname)))) 679 (let* ((root (pathname-root pathname)) 680 (wild-root (wilden root)) 681 (absolute-pathname (merge-pathnames* pathname root)) 682 (separator (directory-separator-for-host root)) 683 (root-namestring (namestring root)) 684 (root-string 685 (substitute-if #\/ 686 #'(lambda (x) (or (eql x #\:) 687 (eql x separator))) 688 root-namestring))) 689 (multiple-value-bind (relative path filename) 690 (split-unix-namestring-directory-components root-string :ensure-directory t) 691 (declare (ignore relative filename)) 692 (let ((new-base (make-pathname :defaults root :directory `(:absolute ,@path)))) 693 (translate-pathname absolute-pathname wild-root (wilden new-base)))))) 694 695 #+scl 696 (defun directorize-pathname-host-device (pathname) 697 (let ((scheme (ext:pathname-scheme pathname)) 698 (host (pathname-host pathname)) 699 (port (ext:pathname-port pathname)) 700 (directory (pathname-directory pathname))) 701 (flet ((specificp (x) (and x (not (eq x :unspecific))))) 702 (if (or (specificp port) 703 (and (specificp host) (plusp (length host))) 704 (specificp scheme)) 705 (let ((prefix "")) 706 (when (specificp port) 707 (setf prefix (format nil ":~D" port))) 708 (when (and (specificp host) (plusp (length host))) 709 (setf prefix (strcat host prefix))) 710 (setf prefix (strcat ":" prefix)) 711 (when (specificp scheme) 712 (setf prefix (strcat scheme prefix))) 713 (assert (and directory (eq (first directory) :absolute))) 714 (make-pathname :directory `(:absolute ,prefix ,@(rest directory)) 715 :defaults pathname))) 716 pathname))) 717 718 (defun* (translate-pathname*) (path absolute-source destination &optional root source) 719 "A wrapper around TRANSLATE-PATHNAME to be used by the ASDF output-translations facility. 720 PATH is the pathname to be translated. 721 ABSOLUTE-SOURCE is an absolute pathname to use as source for translate-pathname, 722 DESTINATION is either a function, to be called with PATH and ABSOLUTE-SOURCE, 723 or a relative pathname, to be merged with ROOT and used as destination for translate-pathname 724 or an absolute pathname, to be used as destination for translate-pathname. 725 In that last case, if ROOT is non-NIL, PATH is first transformated by DIRECTORIZE-PATHNAME-HOST-DEVICE." 726 (declare (ignore source)) 727 (cond 728 ((functionp destination) 729 (funcall destination path absolute-source)) 730 ((eq destination t) 731 path) 732 ((not (pathnamep destination)) 733 (parameter-error "~S: Invalid destination" 'translate-pathname*)) 734 ((not (absolute-pathname-p destination)) 735 (translate-pathname path absolute-source (merge-pathnames* destination root))) 736 (root 737 (translate-pathname (directorize-pathname-host-device path) absolute-source destination)) 738 (t 739 (translate-pathname path absolute-source destination)))) 740 741 (defvar *output-translation-function* 'identity 742 "Hook for output translations. 743 744 This function needs to be idempotent, so that actions can work 745 whether their inputs were translated or not, 746 which they will be if we are composing operations. e.g. if some 747 create-lisp-op creates a lisp file from some higher-level input, 748 you need to still be able to use compile-op on that lisp file."))