1 ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*-
8 ;;;; Environment access
10 (defclass environment
()
11 ((variables :initarg
:variables
12 :initform
(make-hash-table :test
#'equal
)
13 :accessor environment-variables
)))
15 (defmethod print-object ((env environment
) stream
)
16 (print-unreadable-object (env stream
:type t
:identity nil
)
17 (let ((keys (sort (hash-table-keys (environment-variables env
))
20 (format stream
"~A variables: ~S ... ~S"
22 (car keys
) (lastcar keys
))
23 (format stream
"empty")))))
25 (declaim (inline %obj-getenv %obj-setenv %obj-unsetenv %obj-clearenv
))
27 (defun %obj-getenv
(env name
)
28 (gethash name
(environment-variables env
)))
30 (defun %obj-setenv
(env name value overwrite
)
32 (not (nth-value 1 (%obj-getenv env name
))))
33 (setf (gethash name
(environment-variables env
))
36 (defun %obj-unsetenv
(env name
)
37 (remhash name
(environment-variables env
)))
39 (defun %obj-clearenv
(env)
40 (clrhash (environment-variables env
)))
42 (defun environment-variable (name &optional env
)
43 "ENVIRONMENT-VARIABLE returns the environment variable
44 identified by NAME, or NIL if one does not exist. NAME can
45 either be a symbol or a string."
46 (let ((name (string name
)))
51 (%obj-getenv env name
)))))
53 (defun (setf environment-variable
) (value name
&optional env
55 "SETF ENVIRONMENT-VARIABLE sets the environment variable
56 identified by NAME to VALUE. Both NAME and VALUE can be either a
57 symbols or strings. Signals an error on failure."
58 (let ((value (string value
))
62 (isys:setenv name value overwrite
))
64 (%obj-setenv env name value overwrite
)))
67 (defun makunbound-environment-variable (name &optional env
)
68 "Removes the environment variable identified by NAME from the
69 current environment. NAME can be either a string or a symbol.
70 Returns the string designated by NAME. Signals an error on
72 (let ((name (string name
)))
77 (%obj-unsetenv env name
)))
80 (defun clear-environment (&optional env
)
81 "Removes all variables from an environment."
90 "Return the current global environment."
91 (let ((env (make-instance 'environment
))
92 (envptr (isys:os-environ
)))
93 (if (null-pointer-p envptr
)
95 (loop :for i
:from
0 :by
1
96 :for string
:= (mem-aref envptr
:string i
)
97 :for split
:= (position #\
= string
)
99 (let ((name (subseq string
0 split
))
100 (value (subseq string
(1+ split
))))
101 (%obj-setenv env name value t
))))
104 (defun (setf environment
) (newenv)
105 "SETF ENVIRONMENT replaces the contents of the global environment
106 with that of its argument.
108 Often it is preferable to use SETF ENVIRONMENT-VARIABLE and
109 MAKUNBOUND-ENVIRONMENT-VARIABLE to modify the environment instead
110 of SETF ENVIRONMENT."
111 (check-type newenv environment
)
113 (maphash (lambda (name value
)
114 (isys:setenv name value t
))
115 (environment-variables newenv
))
118 (defun allocate-env (argv variables
)
121 (maphash (lambda (k v
)
122 (setf (mem-aref argv
:pointer
(incf offset
))
123 (foreign-string-alloc (concatenate 'string k
"=" v
))))
126 (defun delocate-null-ended-list (argv)
128 :for ptr
:= (mem-aref argv
:pointer i
)
129 :if
(null-pointer-p ptr
) :do
(loop-finish)
130 :else
:do
(foreign-free ptr
)))
132 (defmacro with-c-environment
((var environment
) &body body
)
133 (with-gensyms (body-fn ptr count
)
134 `(flet ((,body-fn
(,ptr
)
137 (etypecase ,environment
139 (,body-fn
(null-pointer)))
141 (,body-fn
(isys:os-environ
)))
143 (let ((,count
(1+ (hash-table-count
144 (environment-variables ,environment
)))))
145 (with-foreign-object (,ptr
:pointer
,count
)
146 (isys:bzero
,ptr
(* ,count
(isys:sizeof
:pointer
)))
149 (allocate-env ,ptr
(environment-variables ,environment
))
151 (delocate-null-ended-list ,ptr
)))))))))
154 ;;;; Current directory
156 (defun current-directory ()
157 "CURRENT-DIRECTORY returns the operating system's current
158 directory, which may or may not correspond to
159 *DEFAULT-FILE-PATH-DEFAULTS*."
160 (let ((cwd (isys:getcwd
)))
162 (parse-file-path cwd
:expand-user nil
)
163 (isys:syscall-error
"Could not get current directory."))))
165 (defun (setf current-directory
) (pathspec)
166 "SETF CURRENT-DIRECTORY changes the operating system's current
167 directory to the PATHSPEC. An error is signalled if PATHSPEC
169 (let ((path (file-path pathspec
)))
170 (isys:chdir
(file-path-namestring path
))))
172 (defmacro with-current-directory
(pathspec &body body
)
174 `(let ((,old
(current-directory)))
177 (setf (current-directory) (file-path ,pathspec
))
179 (setf (current-directory) ,old
)))))
182 ;;;; File-path manipulations
184 (defun absolute-file-path (pathspec &optional
185 (defaults *default-file-path-defaults
*))
186 (let ((path (file-path pathspec
)))
187 (if (absolute-file-path-p path
)
189 (let ((tmp (merge-file-paths path defaults
)))
190 (if (absolute-file-path-p tmp
)
192 (merge-file-paths tmp
(current-directory)))))))
194 (defun strip-dots (path)
195 (multiple-value-bind (root nodes
)
196 (split-root/nodes
(file-path-components path
))
197 (let (new-components)
202 (pop new-components
))
203 (t (push n new-components
))))
204 (make-file-path :components
(if root
205 (cons root
(nreverse new-components
))
206 (nreverse new-components
))
209 (defun resolve-symlinks (path)
210 (let* ((namestring (file-path-namestring path
))
211 (realpath (isys:realpath namestring
)))
212 (parse-file-path realpath
)))
214 (defun resolve-file-path (pathspec &key
215 (defaults *default-file-path-defaults
*)
217 "Returns an absolute file-path corresponding to PATHSPEC by
218 merging it with DEFAULT, and (CURRENT-DIRECTORY) if necessary.
219 If CANONICALIZE is non-NIL, the path is canonicalised: if it is :STRIP-DOTS,
220 then just remove \".\" and \"..\", otherwise symlinks are resolved too."
221 (let ((absolute-file-path (absolute-file-path pathspec defaults
)))
223 ((nil) absolute-file-path
)
224 (:strip-dots
(strip-dots absolute-file-path
))
225 (t (resolve-symlinks absolute-file-path
)))))
230 ;;; FIXME: make sure that GET-FILE-KIND be able to signal
231 ;;; only conditions of type FILE-ERROR, either by
232 ;;; wrapping POSIX-ERRORs or making sure that some
233 ;;; POSIX-ERRORS subclass FILE-ERROR
234 (defun get-file-kind (file follow-p
)
235 (let ((namestring (file-path-namestring file
)))
237 (let ((mode (isys:stat-mode
239 (isys:stat namestring
)
240 (isys:lstat namestring
)))))
241 (switch ((logand isys
:s-ifmt mode
) :test
#'=)
242 (isys:s-ifdir
:directory
)
243 (isys:s-ifchr
:character-device
)
244 (isys:s-ifblk
:block-device
)
245 (isys:s-ifreg
:regular-file
)
246 (isys:s-iflnk
:symbolic-link
)
247 (isys:s-ifsock
:socket
)
249 (t (bug "Unknown file mode: ~A." mode
))))
250 ((or isys
:enoent isys
:eloop
) ()
252 ;; stat() returned ENOENT: either FILE does not exist
253 ;; or it is a broken symlink
256 (isys:lstat namestring
)
257 ((or isys
:enoent isys
:eloop
) ())
259 (declare (ignore stat
))
260 (values :symbolic-link
:broken
))))
261 ;; lstat() returned ENOENT: FILE does not exist
264 (defun file-kind (pathspec &key follow-symlinks
)
265 "Returns a keyword indicating the kind of file designated by PATHSPEC,
266 or NIL if the file does not exist. Does not follow symbolic
269 Possible file-kinds in addition to NIL are: :REGULAR-FILE,
270 :SYMBOLIC-LINK, :DIRECTORY, :PIPE, :SOCKET, :CHARACTER-DEVICE, and
272 If FOLLOW-SYMLINKS is non-NIL and PATHSPEC designates a broken symlink
273 returns :BROKEN as second value."
274 (get-file-kind (merge-file-paths pathspec
) follow-symlinks
))
276 (defun file-exists-p (pathspec &optional file-kind
)
277 "Checks whether the file named by the file-path designator
278 PATHSPEC exists, if this is the case and FILE-KIND is specified
279 it also checks the file kind. If the tests succeed, return two values:
280 truename and file kind of PATHSPEC, NIL otherwise.
281 Follows symbolic links."
282 (let* ((path (file-path pathspec
))
283 (follow (if (eql :symbolic-link file-kind
) nil t
))
284 (actual-kind (file-kind path
:follow-symlinks follow
)))
285 (when (and actual-kind
286 (if file-kind
(eql file-kind actual-kind
) t
))
287 (values (resolve-file-path path
)
290 (defun regular-file-exists-p (pathspec)
291 "Checks whether the file named by the file-path designator
292 PATHSPEC exists and is a regular file. Returns its truename
293 if this is the case, NIL otherwise. Follows symbolic links."
294 (nth-value 0 (file-exists-p pathspec
:regular-file
)))
296 (defun directory-exists-p (pathspec)
297 "Checks whether the file named by the file-path designator
298 PATHSPEC exists and is a directory. Returns its truename
299 if this is the case, NIL otherwise. Follows symbolic links."
300 (nth-value 0 (file-exists-p pathspec
:directory
)))
302 (defun good-symlink-exists-p (pathspec)
303 "Checks whether the file named by the file-path designator
304 PATHSPEC exists and is a symlink pointing to an existent file."
305 (eql :broken
(nth-value 1 (file-kind pathspec
:follow-symlinks t
))))
310 (defvar *temporary-directory
*
311 (let ((system-tmpdir (or (environment-variable "TMPDIR")
312 (environment-variable "TMP")
314 (parse-file-path system-tmpdir
:expand-user nil
)))
317 ;;;; Symbolic and hard links
319 (defun read-symlink (pathspec)
320 "Returns the file-path pointed to by the symbolic link
321 designated by PATHSPEC. If the link is relative, then the
322 returned file-path is relative to the link, not
323 *DEFAULT-FILE-PATH-DEFAULTS*.
325 Signals an error if PATHSPEC is not a symbolic link."
326 ;; Note: the previous version tried much harder to provide a buffer
327 ;; big enough to fit the link's name. OTOH, %SYS-READLINK stack
328 ;; allocates on most lisps.
329 (file-path (isys:readlink
330 (file-path-namestring
331 (absolute-file-path pathspec
*default-file-path-defaults
*)))))
333 (defun make-symlink (link target
)
334 "Creates symbolic LINK that points to TARGET.
335 Returns the file-path of the link.
337 Relative targets are resolved against the link. Relative links
338 are resolved against *DEFAULT-FILE-PATH-DEFAULTS*.
340 Signals an error if TARGET does not exist, or LINK exists already."
341 (let ((link (file-path link
))
342 (target (file-path target
)))
343 (with-current-directory
344 (absolute-file-path *default-file-path-defaults
* nil
)
345 (isys:symlink
(file-path-namestring target
)
346 (file-path-namestring link
))
349 (defun make-hardlink (link target
)
350 "Creates hard LINK that points to TARGET.
351 Returns the file-path of the link.
353 Relative targets are resolved against the link. Relative links
354 are resolved against *DEFAULT-FILE-PATH-DEFAULTS*.
356 Signals an error if TARGET does not exist, or LINK exists already."
357 (let ((link (file-path link
))
358 (target (file-path target
)))
359 (with-current-directory
360 (absolute-file-path *default-file-path-defaults
* nil
)
361 (isys:link
(file-path-namestring
362 (merge-file-paths target link
))
367 ;;;; File permissions
369 (defconstant (+permissions
+ :test
#'equal
)
370 `((:user-read .
,isys
:s-irusr
)
371 (:user-write .
,isys
:s-iwusr
)
372 (:user-exec .
,isys
:s-ixusr
)
373 (:group-read .
,isys
:s-irgrp
)
374 (:group-write .
,isys
:s-iwgrp
)
375 (:group-exec .
,isys
:s-ixgrp
)
376 (:other-read .
,isys
:s-iroth
)
377 (:other-write .
,isys
:s-iwoth
)
378 (:other-exec .
,isys
:s-ixoth
)
379 (:set-user-id .
,isys
:s-isuid
)
380 (:set-group-id .
,isys
:s-isgid
)
381 (:sticky .
,isys
:s-isvtx
)))
383 (defun file-permissions (pathspec)
384 "FILE-PERMISSIONS returns a list of keywords identifying the
385 permissions of PATHSPEC.
387 SETF FILE-PERMISSIONS sets the permissions of PATHSPEC as
388 identified by the symbols in list.
390 If PATHSPEC designates a symbolic link, that link is implicitly
393 Permission symbols consist of :USER-READ, :USER-WRITE, :USER-EXEC,
394 :GROUP-READ, :GROUP-WRITE, :GROUP-EXEC, :OTHER-READ, :OTHER-WRITE,
395 :OTHER-EXEC, :SET-USER-ID, :SET-GROUP-ID, and :STICKY.
397 Both signal an error if PATHSPEC doesn't designate an existing file."
398 (let ((mode (isys:stat-mode
399 (isys:stat
(file-path-namestring pathspec
)))))
400 (loop :for
(name . value
) :in
+permissions
+
401 :when
(plusp (logand mode value
))
404 (defun (setf file-permissions
) (perms pathspec
)
405 (isys:chmod
(file-path-namestring pathspec
)
406 (reduce (lambda (a b
)
407 (logior a
(cdr (assoc b
+permissions
+))))
408 perms
:initial-value
0)))
411 ;;;; Directory access
413 (defmacro with-directory-iterator
((iterator pathspec
) &body body
)
414 "PATHSPEC must be a valid directory designator:
415 *DEFAULT-FILE-PATH-DEFAULTS* is bound, and (CURRENT-DIRECTORY) is set
416 to the designated directory for the dynamic scope of the body.
418 Within the lexical scope of the body, ITERATOR is defined via
419 macrolet such that successive invocations of (ITERATOR) return
420 the directory entries, one by one. Both files and directories
421 are returned, except '.' and '..'. The order of entries is not
422 guaranteed. The entries are returned as relative file-paths
423 against the designated directory. Entries that are symbolic
424 links are not resolved, but links that point to directories are
425 interpreted as directory designators. Once all entries have been
426 returned, further invocations of (ITERATOR) will all return NIL.
428 The value returned is the value of the last form evaluated in
429 body. Signals an error if PATHSPEC is not a directory."
430 (with-unique-names (one-iter)
431 `(call-with-directory-iterator
434 (declare (type function
,one-iter
))
435 (macrolet ((,iterator
()
436 `(funcall ,',one-iter
)))
439 (defun call-with-directory-iterator (pathspec fn
)
440 (let* ((dir (resolve-file-path pathspec
:canonicalize nil
))
441 (dp (isys:opendir
(file-path-namestring dir
))))
442 (labels ((one-iter ()
443 (let ((name (isys:readdir dp
)))
446 ((member name
'("." "..") :test
#'string
=)
449 (parse-file-path name
)))))))
451 (let ((*default-file-path-defaults
* dir
))
452 (funcall fn
#'one-iter
))
453 (isys:closedir dp
)))))
455 (defun mapdir (function pathspec
)
456 "Applies function to each entry in directory designated by
457 PATHSPEC in turn and returns a list of the results. Binds
458 *DEFAULT-FILE-PATH-DEFAULTS* to the directory designated by
459 pathspec round to function call.
461 If PATHSPEC designates a symbolic link, it is implicitly resolved.
463 Signals an error if PATHSPEC is not a directory."
464 (with-directory-iterator (next pathspec
)
465 (loop :for entry
:= (next)
467 :collect
(funcall function entry
))))
469 (defun list-directory (pathspec)
470 "Returns a fresh list of file-paths corresponding to all files
471 within the directory named by PATHSPEC."
472 (with-directory-iterator (next pathspec
)
473 (loop :for entry
:= (next)
474 :while entry
:collect entry
)))
476 (defun walk-directory (directory fn
&key
(if-does-not-exist :error
)
477 follow-symlinks
(directories :before
)
478 (mindepth 1) (maxdepth 65535)
479 (test (constantly t
)) (key #'identity
))
480 "Recursively applies the function FN to all files within the
481 directory named by the FILE-PATH designator DIRNAME and all of
482 the files and directories contained within. Returns T on success."
483 (assert (<= 0 mindepth maxdepth
))
484 (labels ((walk (name depth parent
)
486 (file-kind name
:follow-symlinks follow-symlinks
))
487 (name-key (funcall key name
)))
488 (flet ((maybe-callfn ()
489 (when (and (<= mindepth depth maxdepth
)
490 (funcall test name-key kind
))
491 (callfn name-key kind parent depth
)))
493 (when (or (< depth mindepth
)
494 (and (< depth maxdepth
)
495 (funcall test name-key kind
)))
496 (walkdir name depth parent
))))
499 (when (eql :before directories
) (maybe-callfn))
501 (when (eql :after directories
) (maybe-callfn)))
502 (t (maybe-callfn))))))
503 (walkdir (name depth parent
)
504 (mapdir (lambda (dir)
507 ((zerop depth
) (list "."))
509 (cons (file-path-file name
) parent
))
512 (callfn (key kind parent depth
)
515 (and parent
(make-file-path :components
(reverse parent
)))))
516 (funcall fn key kind parent depth
))
517 (ignore-file-system-error ()
518 :report
"Ignore file system error and continue"))))
519 (let* ((directory (file-path directory
))
522 (file-kind directory
:follow-symlinks t
)
524 (ecase if-does-not-exist
525 (:error
(isys:syscall-error
"Directory ~S does not exist"
527 ((nil) (return* nil
))))
529 (isys:syscall-error
"Search permission is denied for ~S"
531 (unless (eql :directory kind
)
532 (isys:syscall-error
"~S is not a directory" directory
))
533 (walk directory
0 nil
)
536 (defun delete-files (pathspec &key recursive follow-symlinks
)
537 (labels ((%delete-file
(file)
538 (isys:unlink
(file-path-namestring
539 (absolute-file-path file
))))
540 (%delete-directory
(directory)
541 (isys:rmdir
(file-path-namestring
542 (absolute-file-path directory
)))))
543 (let* ((pathspec (file-path pathspec
))
544 (kind (file-kind pathspec
:follow-symlinks follow-symlinks
)))
548 (walk-directory pathspec
549 (lambda (name kind parent depth
)
550 (declare (ignore parent depth
))
552 (:directory
(%delete-directory name
))
553 (t (%delete-file name
))))
556 (%delete-directory pathspec
)))
557 (t (%delete-file pathspec
))))))
560 ;;;; User information
562 (defun user-info (id)
563 "USER-INFO returns the password entry for the given name or
564 numerical user ID, as an assoc-list."
565 (multiple-value-bind (name password uid gid gecos home shell
)
567 (string (isys:getpwnam id
))
568 (integer (isys:getpwuid id
)))
569 (declare (ignore password
))
571 (list (cons :name name
)