1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; indent-tabs-mode: nil -*-
6 (in-package :iolib.pathnames
)
8 ;;;-------------------------------------------------------------------------
10 ;;;-------------------------------------------------------------------------
12 (defclass file-path
()
13 ((host :initarg
:host
)
14 (device :initarg
:device
)
15 (directory :initarg
:directory
20 :reader file-path-directory-delimiter
22 (alternative-delimiter
23 :reader file-path-alternative-delimiter
25 (execution-path-delimiter
26 :reader file-path-execution-path-delimiter
30 ;;;-------------------------------------------------------------------------
32 ;;;-------------------------------------------------------------------------
34 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
35 (defconstant +file-path-host-type
+
36 #+unix
'unix-path
#+windows
'unc-path
))
38 (defconstant +directory-delimiter
+
39 #+unix
#\
/ #+windows
#\\)
41 (defconstant +alternative-delimiter
+
42 #+unix nil
#+windows
#\
/)
44 (defconstant (+split-directories-regex
+ :test
'equal
)
45 (if +alternative-delimiter
+
46 (format nil
"(~C|~C)" +directory-delimiter
+ +alternative-delimiter
+)
47 +directory-delimiter
+))
49 (defconstant (+absolute-directory-regex
+ :test
'equal
)
50 (format nil
"^~C" +split-directories-regex
+))
52 (defconstant +execution-path-delimiter
+
53 #+unix
#\
: #+windows
#\
;)
55 (declaim (special *default-file-path-defaults
*))
58 ;;;-------------------------------------------------------------------------
60 ;;;-------------------------------------------------------------------------
64 (defgeneric file-path-host
(path))
66 (defgeneric file-path-device
(path))
68 (defgeneric file-path-directory
(path &key namestring
))
70 (defgeneric file-path-name
(path))
72 (defgeneric file-path-namestring
(path))
76 (defgeneric make-file-path
(&key host device directory name defaults type
))
78 (defgeneric merge-file-paths
(path &optional defaults
))
80 (defgeneric enough-file-path
(path &optional defaults
))
82 (defgeneric concatenate-paths
(&rest paths
))
84 (defgeneric parse-file-path-type
(namestring type
&key start end
85 as-directory expand-user
))
87 (defgeneric parse-file-path
(namestring &key start end
88 as-directory expand-user
))
90 (defgeneric file-path
(pathspec))
92 (defgeneric expand-user-directory
(path))
94 ;;; Internal functions
96 (defgeneric %file-path-directory-namestring
(path &key trailing-delimiter
))
98 (defgeneric %expand-user-directory
(pathspec))
101 ;;;-------------------------------------------------------------------------
103 ;;;-------------------------------------------------------------------------
105 (defmethod file-path-host ((path file-path
))
106 (slot-value path
'host
))
108 (defmethod file-path-device ((path file-path
))
109 (slot-value path
'device
))
111 (defmethod file-path-directory ((path file-path
) &key namestring
)
113 (%file-path-directory-namestring path
)
114 (slot-value path
'directory
)))
116 (defmethod file-path-name ((path file-path
))
117 (slot-value path
'name
))
120 ;;;-------------------------------------------------------------------------
122 ;;;-------------------------------------------------------------------------
124 (defun directory-name-p (name)
125 (and (stringp name
) (not (ppcre:scan
+split-directories-regex
+ name
))))
127 (defun file-path-directory-p (directory)
128 (and (consp directory
)
129 (member (car directory
) '(:absolute
:relative
))
130 (every #'directory-name-p
(cdr directory
))))
132 (defmethod initialize-instance :after
((path file-path
) &key directory name
)
133 (check-type directory
(or null
(eql :unspecific
)
134 (satisfies file-path-directory-p
)))
135 (check-type name
(or null
(eql :unspecific
) string
)))
138 ;;;-------------------------------------------------------------------------
140 ;;;-------------------------------------------------------------------------
142 (defun file-path-p (thing)
143 (typep thing
'file-path
))
145 (defun file-path-absolute-p (thing)
146 (and (file-path-p thing
)
147 (eql :absolute
(car (file-path-directory thing
)))))
149 (defun file-path-relative-p (thing)
150 (and (file-path-p thing
)
151 (eql :relative
(car (file-path-directory thing
)))))
154 ;;;-------------------------------------------------------------------------
156 ;;;-------------------------------------------------------------------------
158 (defmethod make-file-path (&key
(type '#.
+file-path-host-type
+)
159 host device directory name defaults
)
160 (check-type defaults
(or null file-path
))
164 (file-path-host defaults
)
165 (file-path-host *default-file-path-defaults
*)))
167 (and defaults
(file-path-device defaults
)))
168 :directory
(or directory
169 (and defaults
(file-path-directory defaults
)))
171 (and defaults
(file-path-name defaults
)))))
173 (defmethod merge-file-paths ((path file-path
) &optional
174 (defaults *default-file-path-defaults
*))
175 (check-type defaults file-path
)
176 (make-instance (class-of path
)
177 :host
(or (file-path-host path
)
178 (file-path-host defaults
))
179 :device
(or (file-path-device path
)
180 (file-path-device defaults
))
181 :directory
(or (let ((dir (file-path-directory path
)))
182 (when (and dir
(eql :relative
(car dir
))
183 (listp (file-path-directory defaults
)))
184 (append dir
(file-path-directory defaults
))))
185 (file-path-directory defaults
))
186 :name
(or (file-path-name path
)
187 (file-path-name defaults
))))
189 (defmethod concatenate-paths (&rest paths
)
190 (assert (every #'file-path-p paths
))
191 (when (null paths
) (return* nil
))
193 (not (stringp (file-path-name (lastcar paths
)))))
195 (apply #'join
(file-path-directory-delimiter (car paths
))
196 (mapcar #'file-path-namestring paths
))))
197 (parse-file-path-type big-namestring
(type-of (car paths
))
198 :as-directory as-directory
)))
200 (defun split-directory-namestring (namestring &optional limit
)
201 (remove "" (ppcre:split
+split-directories-regex
+ namestring
205 (defmethod parse-file-path (namestring &key
(start 0) end
206 as-directory expand-user
)
207 (parse-file-path-type namestring
+file-path-host-type
+
208 :start start
:end end
209 :as-directory as-directory
210 :expand-user expand-user
))
212 (defmethod file-path ((pathspec file-path
))
215 (defmethod file-path ((pathspec string
))
216 (parse-file-path pathspec
))
219 ;;;-------------------------------------------------------------------------
221 ;;;-------------------------------------------------------------------------
223 (defmethod print-object ((path file-path
) stream
)
224 (print-unreadable-object (path stream
:type t
)
225 (format stream
"~S" (file-path-namestring path
))))