1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; indent-tabs-mode: nil -*-
6 (in-package :iolib.pathnames
)
8 ;;;-------------------------------------------------------------------------
10 ;;;-------------------------------------------------------------------------
12 (defclass unix-path
(file-path)
15 (alternative-delimiter
17 (execution-path-delimiter
19 (:default-initargs
:host
:unspecific
23 ;;;-------------------------------------------------------------------------
25 ;;;-------------------------------------------------------------------------
27 (defun unix-path-p (thing)
28 (typep thing
'unix-path
))
30 (defun absolute-namestring-p (namestring)
31 (not (null (ppcre:scan
+absolute-directory-regex
+ namestring
))))
34 ;;;-------------------------------------------------------------------------
36 ;;;-------------------------------------------------------------------------
38 (defmethod enough-file-path ((path unix-path
) &optional
39 (defaults *default-file-path-defaults
*))
41 ((or (file-path-relative-p path
)
42 (file-path-relative-p defaults
))
45 (multiple-value-bind (dirtype enough-directory
)
46 (if (equal (cadr (file-path-directory path
))
47 (cadr (file-path-directory defaults
)))
49 (loop :for rest1
:on
(cddr (file-path-directory path
))
50 :for rest2
:on
(cddr (file-path-directory defaults
))
51 :if
(not (equal (car rest1
) (car rest2
))) :do
(loop-finish)
52 :finally
(return rest1
)))
53 (values :absolute
(cdr (file-path-directory path
))))
54 (make-instance 'unix-path
:directory
(list* dirtype enough-directory
)
55 :name
(file-path-name path
))))))
57 (defmethod file-path-namestring ((path unix-path
))
58 (with-slots (directory name
)
60 (with-output-to-string (stream)
61 (princ (%file-path-directory-namestring path
:trailing-delimiter t
)
64 (princ name stream
)))))
66 (defmethod %file-path-directory-namestring
((path unix-path
) &key trailing-delimiter
)
67 (with-slots (directory)
69 (with-output-to-string (stream)
70 (when (consp directory
)
71 (destructuring-bind (directory-type &rest dirs
)
74 (nil t
) ; no directory
76 (princ (file-path-directory-delimiter path
) stream
))
78 (princ (apply #'join
(file-path-directory-delimiter path
)
79 (if trailing-delimiter
(append dirs
(list "")) dirs
))
82 (defun split-directory-namestring (namestring &optional limit
)
83 (remove "" (ppcre:split
+split-directories-regex
+ namestring
87 (defmethod parse-file-path-type ((namestring string
)
88 (type (eql 'unix-path
))
90 as-directory expand-user
)
91 (let* ((actual-namestring (subseq namestring start end
))
92 (expansion (or (when expand-user
93 (ignore-some-conditions (isys:posix-error
)
94 (%expand-user-directory actual-namestring
)))
96 (components (remove "." (split-directory-namestring expansion
)
98 (dirname (if as-directory components
(butlast components
)))
99 (basename (if as-directory nil
(lastcar components
)))
100 (directory-type (if (absolute-namestring-p expansion
)
103 (make-instance type
:directory
(cons directory-type dirname
)
104 :name
(if (string= "" basename
) nil basename
))))
106 (defmethod %expand-user-directory
((pathspec string
))
107 (flet ((user-homedir (user)
108 (nth-value 5 (isys:%sys-getpwnam user
)))
110 (nth-value 5 (isys:%sys-getpwuid uid
)))
111 (concat-homedir (dir rest
)
112 (join +directory-delimiter
+ dir rest
)))
113 (destructuring-bind (first &optional rest
)
114 (split-directory-namestring pathspec
2)
118 (or (isys:%sys-getenv
"HOME")
120 (or (isys:%sys-getenv
"USER")
121 (isys:%sys-getenv
"LOGIN"))))
123 (user-homedir username
)
124 (uid-homedir (isys:%sys-getuid
)))))))
125 (return* (concat-homedir homedir rest
))))
126 ((char= #\~
(char first
0))
128 (and (user-homedir (subseq first
1))
130 (return* (concat-homedir homedir rest
))))
134 (defmethod expand-user-directory ((path unix-path
))
135 (with-slots (directory)
137 (assert (and (consp directory
)
138 (eql :relative
(first directory
))
139 (stringp (second directory
))))
140 (let ((dirs (split-directory-namestring
142 (%expand-user-directory
(second directory
))
143 (isys:posix-error
() (return* path
))))))
145 (append (list :absolute
) dirs
(cddr directory
)))))
149 ;;;-------------------------------------------------------------------------
151 ;;;-------------------------------------------------------------------------
153 (defparameter *default-file-path-defaults
*
154 (or (ignore-some-conditions (isys:posix-error
)
155 (parse-file-path (isys:%sys-getcwd
) :as-directory t
))
156 (ignore-some-conditions (isys:posix-error
)
157 (parse-file-path (%expand-user-directory
"~") :as-directory t
))
158 (parse-file-path "/")))
160 (defparameter *default-execution-path
*
162 (parse-file-path p
:as-directory t
))
163 (split-sequence +execution-path-delimiter
+ (isys:%sys-getenv
"PATH")
164 :remove-empty-subseqs t
)))