configuration.lisp - clic - Clic is an command line interactive client for goph… | |
git clone git://bitreich.org/clic/ git://enlrupgkhuxnvlhsf6lc3fziv5h2hhfrinws65… | |
Log | |
Files | |
Refs | |
Tags | |
README | |
LICENSE | |
--- | |
configuration.lisp (22555B) | |
--- | |
1 ;;;; -------------------------------------------------------------------… | |
2 ;;;; Generic support for configuration files | |
3 | |
4 (uiop/package:define-package :uiop/configuration | |
5 (:recycle :uiop/configuration :asdf/configuration) ;; necessary to upg… | |
6 (:use :uiop/package :uiop/common-lisp :uiop/utility | |
7 :uiop/os :uiop/pathname :uiop/filesystem :uiop/stream :uiop/image :ui… | |
8 (:export | |
9 #:user-configuration-directories #:system-configuration-directories ;… | |
10 #:in-first-directory #:in-user-configuration-directory #:in-system-co… | |
11 #:get-folder-path | |
12 #:xdg-data-home #:xdg-config-home #:xdg-data-dirs #:xdg-config-dirs | |
13 #:xdg-cache-home #:xdg-runtime-dir #:system-config-pathnames | |
14 #:filter-pathname-set #:xdg-data-pathnames #:xdg-config-pathnames | |
15 #:find-preferred-file #:xdg-data-pathname #:xdg-config-pathname | |
16 #:validate-configuration-form #:validate-configuration-file #:validat… | |
17 #:configuration-inheritance-directive-p | |
18 #:report-invalid-form #:invalid-configuration #:*ignored-configuratio… | |
19 #:*clear-configuration-hook* #:clear-configuration #:register-clear-c… | |
20 #:resolve-location #:location-designator-p #:location-function-p #:*h… | |
21 #:resolve-relative-location #:resolve-absolute-location #:upgrade-con… | |
22 #:uiop-directory)) | |
23 (in-package :uiop/configuration) | |
24 | |
25 (with-upgradability () | |
26 (define-condition invalid-configuration () | |
27 ((form :reader condition-form :initarg :form) | |
28 (location :reader condition-location :initarg :location) | |
29 (format :reader condition-format :initarg :format) | |
30 (arguments :reader condition-arguments :initarg :arguments :initfor… | |
31 (:report (lambda (c s) | |
32 (format s (compatfmt "~@<~? (will be skipped)~@:>") | |
33 (condition-format c) | |
34 (list* (condition-form c) (condition-location c) | |
35 (condition-arguments c)))))) | |
36 | |
37 (defun configuration-inheritance-directive-p (x) | |
38 "Is X a configuration inheritance directive?" | |
39 (let ((kw '(:inherit-configuration :ignore-inherited-configuration))) | |
40 (or (member x kw) | |
41 (and (length=n-p x 1) (member (car x) kw))))) | |
42 | |
43 (defun report-invalid-form (reporter &rest args) | |
44 "Report an invalid form according to REPORTER and various ARGS" | |
45 (etypecase reporter | |
46 (null | |
47 (apply 'error 'invalid-configuration args)) | |
48 (function | |
49 (apply reporter args)) | |
50 ((or symbol string) | |
51 (apply 'error reporter args)) | |
52 (cons | |
53 (apply 'apply (append reporter args))))) | |
54 | |
55 (defvar *ignored-configuration-form* nil | |
56 "Have configuration forms been ignored while parsing the configurati… | |
57 | |
58 (defun validate-configuration-form (form tag directive-validator | |
59 &key location invalid-form-r… | |
60 "Validate a configuration FORM. By default it will raise an error if… | |
61 FORM is not valid. Otherwise it will return the validated form. | |
62 Arguments control the behavior: | |
63 The configuration FORM should be of the form (TAG . <rest>) | |
64 Each element of <rest> will be checked by first seeing if it's a co… | |
65 directive (see CONFIGURATION-INHERITANCE-DIRECTIVE-P) then invoking DIRE… | |
66 on it. | |
67 In the event of an invalid form, INVALID-FORM-REPORTER will be used… | |
68 reporting (see REPORT-INVALID-FORM) with LOCATION providing information … | |
69 the configuration form appeared." | |
70 (unless (and (consp form) (eq (car form) tag)) | |
71 (setf *ignored-configuration-form* t) | |
72 (report-invalid-form invalid-form-reporter :form form :location lo… | |
73 (return-from validate-configuration-form nil)) | |
74 (loop :with inherit = 0 :with ignore-invalid-p = nil :with x = (list… | |
75 :for directive :in (cdr form) | |
76 :when (cond | |
77 ((configuration-inheritance-directive-p directive) | |
78 (incf inherit) t) | |
79 ((eq directive :ignore-invalid-entries) | |
80 (setf ignore-invalid-p t) t) | |
81 ((funcall directive-validator directive) | |
82 t) | |
83 (ignore-invalid-p | |
84 nil) | |
85 (t | |
86 (setf *ignored-configuration-form* t) | |
87 (report-invalid-form invalid-form-reporter :form dire… | |
88 nil)) | |
89 :do (push directive x) | |
90 :finally | |
91 (unless (= inherit 1) | |
92 (report-invalid-form invalid-form-reporter | |
93 :form form :location location | |
94 ;; we throw away the form and locati… | |
95 ;; this is necessary because of the … | |
96 :format (compatfmt "~@<Invalid sourc… | |
97 One and only one… | |
98 :arguments '(:inherit-configuration … | |
99 (return (nreverse x)))) | |
100 | |
101 (defun validate-configuration-file (file validator &key description) | |
102 "Validate a configuration FILE. The configuration file should have … | |
103 in it, which will be checked with the VALIDATOR FORM. DESCRIPTION argum… | |
104 reporting." | |
105 (let ((forms (read-file-forms file))) | |
106 (unless (length=n-p forms 1) | |
107 (error (compatfmt "~@<One and only one form allowed for ~A. Got:… | |
108 description forms)) | |
109 (funcall validator (car forms) :location file))) | |
110 | |
111 (defun validate-configuration-directory (directory tag validator &key … | |
112 "Map the VALIDATOR across the .conf files in DIRECTORY, the TAG will | |
113 be applied to the results to yield a configuration form. Current | |
114 values of TAG include :source-registry and :output-translations." | |
115 (let ((files (sort (ignore-errors ;; SORT w/o COPY-LIST is OK: DIREC… | |
116 (remove-if | |
117 'hidden-pathname-p | |
118 (directory* (make-pathname :name *wild* :type "… | |
119 #'string< :key #'namestring))) | |
120 `(,tag | |
121 ,@(loop :for file :in files :append | |
122 (loop :with ignore-invalid-p = nil | |
123 :for form :in (read-file-forms… | |
124 :when (eq form :ignore-invalid… | |
125 :do (setf ignore-invalid-p t) | |
126 :else | |
127 :when (funcall validator for… | |
128 :collect form | |
129 :else | |
130 :when ignore-invalid-p | |
131 :do (setf *ignored-configu… | |
132 :else | |
133 :do (report-invalid-form inv… | |
134 :inherit-configuration))) | |
135 | |
136 (defun resolve-relative-location (x &key ensure-directory wilden) | |
137 "Given a designator X for an relative location, resolve it to a path… | |
138 (ensure-pathname | |
139 (etypecase x | |
140 (null nil) | |
141 (pathname x) | |
142 (string (parse-unix-namestring | |
143 x :ensure-directory ensure-directory)) | |
144 (cons | |
145 (if (null (cdr x)) | |
146 (resolve-relative-location | |
147 (car x) :ensure-directory ensure-directory :wilden wilden) | |
148 (let* ((car (resolve-relative-location | |
149 (car x) :ensure-directory t :wilden nil))) | |
150 (merge-pathnames* | |
151 (resolve-relative-location | |
152 (cdr x) :ensure-directory ensure-directory :wilden wilde… | |
153 car)))) | |
154 ((eql :*/) *wild-directory*) | |
155 ((eql :**/) *wild-inferiors*) | |
156 ((eql :*.*.*) *wild-file*) | |
157 ((eql :implementation) | |
158 (parse-unix-namestring | |
159 (implementation-identifier) :ensure-directory t)) | |
160 ((eql :implementation-type) | |
161 (parse-unix-namestring | |
162 (string-downcase (implementation-type)) :ensure-directory t)) | |
163 ((eql :hostname) | |
164 (parse-unix-namestring (hostname) :ensure-directory t))) | |
165 :wilden (and wilden (not (pathnamep x)) (not (member x '(:*/ :**/ :… | |
166 :want-relative t)) | |
167 | |
168 (defvar *here-directory* nil | |
169 "This special variable is bound to the currect directory during call… | |
170 PROCESS-SOURCE-REGISTRY in order that we be able to interpret the :here | |
171 directive.") | |
172 | |
173 (defvar *user-cache* nil | |
174 "A specification as per RESOLVE-LOCATION of where the user keeps his… | |
175 | |
176 (defun resolve-absolute-location (x &key ensure-directory wilden) | |
177 "Given a designator X for an absolute location, resolve it to a path… | |
178 (ensure-pathname | |
179 (etypecase x | |
180 (null nil) | |
181 (pathname x) | |
182 (string | |
183 (let ((p #-mcl (parse-namestring x) | |
184 #+mcl (probe-posix x))) | |
185 #+mcl (unless p (error "POSIX pathname ~S does not exist" x)) | |
186 (if ensure-directory (ensure-directory-pathname p) p))) | |
187 (cons | |
188 (return-from resolve-absolute-location | |
189 (if (null (cdr x)) | |
190 (resolve-absolute-location | |
191 (car x) :ensure-directory ensure-directory :wilden wilden) | |
192 (merge-pathnames* | |
193 (resolve-relative-location | |
194 (cdr x) :ensure-directory ensure-directory :wilden wilde… | |
195 (resolve-absolute-location | |
196 (car x) :ensure-directory t :wilden nil))))) | |
197 ((eql :root) | |
198 ;; special magic! we return a relative pathname, | |
199 ;; but what it means to the output-translations is | |
200 ;; "relative to the root of the source pathname's host and devic… | |
201 (return-from resolve-absolute-location | |
202 (let ((p (make-pathname :directory '(:relative)))) | |
203 (if wilden (wilden p) p)))) | |
204 ((eql :home) (user-homedir-pathname)) | |
205 ((eql :here) (resolve-absolute-location | |
206 (or *here-directory* (pathname-directory-pathname (… | |
207 :ensure-directory t :wilden nil)) | |
208 ((eql :user-cache) (resolve-absolute-location | |
209 *user-cache* :ensure-directory t :wilden nil)… | |
210 :wilden (and wilden (not (pathnamep x))) | |
211 :resolve-symlinks *resolve-symlinks* | |
212 :want-absolute t)) | |
213 | |
214 ;; Try to override declaration in previous versions of ASDF. | |
215 (declaim (ftype (function (t &key (:directory boolean) (:wilden boolea… | |
216 (:ensure-directory boolean)) t) resolve-l… | |
217 | |
218 (defun* (resolve-location) (x &key ensure-directory wilden directory) | |
219 "Resolve location designator X into a PATHNAME" | |
220 ;; :directory backward compatibility, until 2014-01-16: accept direc… | |
221 (loop* :with dirp = (or directory ensure-directory) | |
222 :with (first . rest) = (if (atom x) (list x) x) | |
223 :with path = (or (resolve-absolute-location | |
224 first :ensure-directory (and (or dirp rest)… | |
225 :wilden (and wilden (null rest))) | |
226 (return nil)) | |
227 :for (element . morep) :on rest | |
228 :for dir = (and (or morep dirp) t) | |
229 :for wild = (and wilden (not morep)) | |
230 :for sub = (merge-pathnames* | |
231 (resolve-relative-location | |
232 element :ensure-directory dir :wilden wild) | |
233 path) | |
234 :do (setf path (if (absolute-pathname-p sub) (resolve-symlink… | |
235 :finally (return path))) | |
236 | |
237 (defun location-designator-p (x) | |
238 "Is X a designator for a location?" | |
239 ;; NIL means "skip this entry", or as an output translation, same as… | |
240 ;; T means "any input" for a translation, or as output, same as tran… | |
241 (flet ((absolute-component-p (c) | |
242 (typep c '(or string pathname | |
243 (member :root :home :here :user-cache)))) | |
244 (relative-component-p (c) | |
245 (typep c '(or string pathname | |
246 (member :*/ :**/ :*.*.* :implementation :impleme… | |
247 (or (typep x 'boolean) | |
248 (absolute-component-p x) | |
249 (and (consp x) (absolute-component-p (first x)) (every #'relat… | |
250 | |
251 (defun location-function-p (x) | |
252 "Is X the specification of a location function?" | |
253 ;; Location functions are allowed in output translations, and notabl… | |
254 (and (length=n-p x 2) (eq (car x) :function))) | |
255 | |
256 (defvar *clear-configuration-hook* '()) | |
257 | |
258 (defun register-clear-configuration-hook (hook-function &optional call… | |
259 "Register a function to be called when clearing configuration" | |
260 (register-hook-function '*clear-configuration-hook* hook-function ca… | |
261 | |
262 (defun clear-configuration () | |
263 "Call the functions in *CLEAR-CONFIGURATION-HOOK*" | |
264 (call-functions *clear-configuration-hook*)) | |
265 | |
266 (register-image-dump-hook 'clear-configuration) | |
267 | |
268 (defun upgrade-configuration () | |
269 "If a previous version of ASDF failed to read some configuration, tr… | |
270 (when *ignored-configuration-form* | |
271 (clear-configuration) | |
272 (setf *ignored-configuration-form* nil))) | |
273 | |
274 | |
275 (defun get-folder-path (folder) | |
276 "Semi-portable implementation of a subset of LispWorks' sys:get-fold… | |
277 this function tries to locate the Windows FOLDER for one of | |
278 :LOCAL-APPDATA, :APPDATA or :COMMON-APPDATA. | |
279 Returns NIL when the folder is not defined (e.g., not on Windows)." | |
280 (or #+(and lispworks os-windows) (sys:get-folder-path folder) | |
281 ;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\W… | |
282 (ecase folder | |
283 (:local-appdata (or (getenv-absolute-directory "LOCALAPPDATA") | |
284 (subpathname* (get-folder-path :appdata) "… | |
285 (:appdata (getenv-absolute-directory "APPDATA")) | |
286 (:common-appdata (or (getenv-absolute-directory "ALLUSERSAPPDA… | |
287 (subpathname* (getenv-absolute-directory … | |
288 | |
289 | |
290 ;; Support for the XDG Base Directory Specification | |
291 (defun xdg-data-home (&rest more) | |
292 "Returns an absolute pathname for the directory containing user-spec… | |
293 MORE may contain specifications for a subpath relative to this directory… | |
294 subpathname specification and keyword arguments as per RESOLVE-LOCATION … | |
295 also \"Configuration DSL\"\) in the ASDF manual." | |
296 (resolve-absolute-location | |
297 `(,(or (getenv-absolute-directory "XDG_DATA_HOME") | |
298 (os-cond | |
299 ((os-windows-p) (get-folder-path :local-appdata)) | |
300 (t (subpathname (user-homedir-pathname) ".local/share/")))) | |
301 ,more))) | |
302 | |
303 (defun xdg-config-home (&rest more) | |
304 "Returns a pathname for the directory containing user-specific confi… | |
305 MORE may contain specifications for a subpath relative to this directory… | |
306 subpathname specification and keyword arguments as per RESOLVE-LOCATION … | |
307 also \"Configuration DSL\"\) in the ASDF manual." | |
308 (resolve-absolute-location | |
309 `(,(or (getenv-absolute-directory "XDG_CONFIG_HOME") | |
310 (os-cond | |
311 ((os-windows-p) (xdg-data-home "config/")) | |
312 (t (subpathname (user-homedir-pathname) ".config/")))) | |
313 ,more))) | |
314 | |
315 (defun xdg-data-dirs (&rest more) | |
316 "The preference-ordered set of additional paths to search for data f… | |
317 Returns a list of absolute directory pathnames. | |
318 MORE may contain specifications for a subpath relative to these director… | |
319 subpathname specification and keyword arguments as per RESOLVE-LOCATION … | |
320 also \"Configuration DSL\"\) in the ASDF manual." | |
321 (mapcar #'(lambda (d) (resolve-location `(,d ,more))) | |
322 (or (remove nil (getenv-absolute-directories "XDG_DATA_DIRS"… | |
323 (os-cond | |
324 ((os-windows-p) (mapcar 'get-folder-path '(:appdata :co… | |
325 (t (mapcar 'parse-unix-namestring '("/usr/local/share/"… | |
326 | |
327 (defun xdg-config-dirs (&rest more) | |
328 "The preference-ordered set of additional base paths to search for c… | |
329 Returns a list of absolute directory pathnames. | |
330 MORE may contain specifications for a subpath relative to these director… | |
331 subpathname specification and keyword arguments as per RESOLVE-LOCATION … | |
332 also \"Configuration DSL\"\) in the ASDF manual." | |
333 (mapcar #'(lambda (d) (resolve-location `(,d ,more))) | |
334 (or (remove nil (getenv-absolute-directories "XDG_CONFIG_DIR… | |
335 (os-cond | |
336 ((os-windows-p) (xdg-data-dirs "config/")) | |
337 (t (mapcar 'parse-unix-namestring '("/etc/xdg/"))))))) | |
338 | |
339 (defun xdg-cache-home (&rest more) | |
340 "The base directory relative to which user specific non-essential da… | |
341 Returns an absolute directory pathname. | |
342 MORE may contain specifications for a subpath relative to this directory… | |
343 subpathname specification and keyword arguments as per RESOLVE-LOCATION … | |
344 also \"Configuration DSL\"\) in the ASDF manual." | |
345 (resolve-absolute-location | |
346 `(,(or (getenv-absolute-directory "XDG_CACHE_HOME") | |
347 (os-cond | |
348 ((os-windows-p) (xdg-data-home "cache/")) | |
349 (t (subpathname* (user-homedir-pathname) ".cache/")))) | |
350 ,more))) | |
351 | |
352 (defun xdg-runtime-dir (&rest more) | |
353 "Pathname for user-specific non-essential runtime files and other fi… | |
354 such as sockets, named pipes, etc. | |
355 Returns an absolute directory pathname. | |
356 MORE may contain specifications for a subpath relative to this directory… | |
357 subpathname specification and keyword arguments as per RESOLVE-LOCATION … | |
358 also \"Configuration DSL\"\) in the ASDF manual." | |
359 ;; The XDG spec says that if not provided by the login system, the a… | |
360 ;; issue a warning and provide a replacement. UIOP is not equipped t… | |
361 (resolve-absolute-location `(,(getenv-absolute-directory "XDG_RUNTIM… | |
362 | |
363 ;;; NOTE: modified the docstring because "system user configuration | |
364 ;;; directories" seems self-contradictory. I'm not sure my wording is … | |
365 (defun system-config-pathnames (&rest more) | |
366 "Return a list of directories where are stored the system's default … | |
367 MORE may contain specifications for a subpath relative to these director… | |
368 subpathname specification and keyword arguments as per RESOLVE-LOCATION … | |
369 also \"Configuration DSL\"\) in the ASDF manual." | |
370 (declare (ignorable more)) | |
371 (os-cond | |
372 ((os-unix-p) (list (resolve-absolute-location `(,(parse-unix-namest… | |
373 | |
374 (defun filter-pathname-set (dirs) | |
375 "Parse strings as unix namestrings and remove duplicates and non abs… | |
376 (remove-duplicates (remove-if-not #'absolute-pathname-p dirs) :from-… | |
377 | |
378 (defun xdg-data-pathnames (&rest more) | |
379 "Return a list of absolute pathnames for application data directorie… | |
380 returns directory for data for that application, without APP, returns th… | |
381 for storing all application configurations. | |
382 MORE may contain specifications for a subpath relative to these director… | |
383 subpathname specification and keyword arguments as per RESOLVE-LOCATION … | |
384 also \"Configuration DSL\"\) in the ASDF manual." | |
385 (filter-pathname-set | |
386 `(,(xdg-data-home more) | |
387 ,@(xdg-data-dirs more)))) | |
388 | |
389 (defun xdg-config-pathnames (&rest more) | |
390 "Return a list of pathnames for application configuration. | |
391 MORE may contain specifications for a subpath relative to these director… | |
392 subpathname specification and keyword arguments as per RESOLVE-LOCATION … | |
393 also \"Configuration DSL\"\) in the ASDF manual." | |
394 (filter-pathname-set | |
395 `(,(xdg-config-home more) | |
396 ,@(xdg-config-dirs more)))) | |
397 | |
398 (defun find-preferred-file (files &key (direction :input)) | |
399 "Find first file in the list of FILES that exists (for direction :in… | |
400 or just the first one (for direction :output or :io). | |
401 Note that when we say \"file\" here, the files in question may be di… | |
402 (find-if (ecase direction ((:probe :input) 'probe-file*) ((:output :… | |
403 | |
404 (defun xdg-data-pathname (&optional more (direction :input)) | |
405 (find-preferred-file (xdg-data-pathnames more) :direction direction)) | |
406 | |
407 (defun xdg-config-pathname (&optional more (direction :input)) | |
408 (find-preferred-file (xdg-config-pathnames more) :direction directio… | |
409 | |
410 (defun compute-user-cache () | |
411 "Compute (and return) the location of the default user-cache for tra… | |
412 objects. Side-effects for cached file location computation." | |
413 (setf *user-cache* (xdg-cache-home "common-lisp" :implementation))) | |
414 (register-image-restore-hook 'compute-user-cache) | |
415 | |
416 (defun uiop-directory () | |
417 "Try to locate the UIOP source directory at runtime" | |
418 (labels ((pf (x) (ignore-errors (probe-file* x))) | |
419 (sub (x y) (pf (subpathname x y))) | |
420 (ssd (x) (ignore-errors (symbol-call :asdf :system-source-d… | |
421 ;; NB: conspicuously *not* including searches based on #.(current-… | |
422 (or | |
423 ;; Look under uiop if available as source override, under asdf if… | |
424 (ssd "uiop") | |
425 (sub (ssd "asdf") "uiop/") | |
426 ;; Look in recommended path for user-visible source installation | |
427 (sub (user-homedir-pathname) "common-lisp/asdf/uiop/") | |
428 ;; Look in XDG paths under known package names for user-invisible… | |
429 (xdg-data-pathname "common-lisp/source/asdf/uiop/") | |
430 (xdg-data-pathname "common-lisp/source/cl-asdf/uiop/") ; traditio… | |
431 ;; The last one below is useful for Fare, primary (sole?) known u… | |
432 (sub (user-homedir-pathname) "cl/asdf/uiop/") | |
433 (cerror "Configure source registry to include UIOP source directo… | |
434 "Unable to find UIOP directory") | |
435 (uiop-directory))))) |