src/os/os-unix.lisp

   1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; indent-tabs-mode: nil -*-
   2 ;;;
   3 ;;; --- OS interface.
   4 ;;;
   5
   6 (in-package :iolib.os)
   7
   8 ;;;; Environment access
   9
  10 (defclass environment ()
  11   ((variables :initarg :variables
  12               :initform (make-hash-table :test #'equal)
  13               :accessor environment-variables)))
  14
  15 (defun %envar (env name)
  16   (gethash name (environment-variables env)))
  17
  18 (defun (setf %envar) (value env name)
  19   (setf (gethash name (environment-variables env))
  20         value))
  21
  22 (defun %remvar (env name)
  23   (remhash name (environment-variables env)))
  24
  25 (defun environment-variable (name &key env)
  26   "ENVIRONMENT-VARIABLE returns the environment variable
  27 identified by NAME, or NIL if one does not exist.  NAME can
  28 either be a symbol or a string.
  29
  30 SETF ENVIRONMENT-VARIABLE sets the environment variable
  31 identified by NAME to VALUE.  Both NAME and VALUE can be either a
  32 symbols or strings. Signals an error on failure."
  33   (let ((name (string name)))
  34     (cond
  35       (env
  36        (check-type env environment)
  37        (%envar env name))
  38       (t
  39        (isys:%sys-getenv name)))))
  40
  41 (defun (setf environment-variable) (value name &key env (overwrite t))
  42   (check-type value string)
  43   (let ((name (string name)))
  44     (cond
  45       (env
  46        (check-type env environment)
  47        (when (or overwrite
  48                  (null (nth-value 1 (%envar env name))))
  49          (setf (%envar env name) value)))
  50       (t
  51        (isys:%sys-setenv (string name) value overwrite))))
  52   value)
  53
  54 (defun makunbound-environment-variable (name &key env)
  55   "Removes the environment variable identified by NAME from the
  56 current environment.  NAME can be either a string or a symbol.
  57 Returns the string designated by NAME.  Signals an error on
  58 failure."
  59   (let ((name (string name)))
  60     (cond
  61       (env
  62        (check-type env environment)
  63        (%remvar env name))
  64       (t
  65        (isys:%sys-unsetenv (string name)))))
  66   (values name))
  67
  68 (defun %environment ()
  69   (loop :with env := (make-instance 'environment)
  70         :for i :from 0 :by 1
  71         :for string := (mem-aref isys:*environ* :string i)
  72         :for split := (position #\= string)
  73         :while string :do
  74         (let ((var (subseq string 0 split))
  75               (val (subseq string (1+ split))))
  76           (setf (environment-variable var :env env) val))
  77         :finally (return env)))
  78
  79 (defun environment (&optional env)
  80   "If ENV is non-NIL, ENVIRONMENT copies ENV, otherwise returns the
  81 current global environment.
  82 SETF ENVIRONMENT replaces the contents of the global environment
  83 with that of its argument.
  84
  85 Often it is preferable to use SETF ENVIRONMENT-VARIABLE and
  86 MAKUNBOUND-ENVIRONMENT-VARIABLE to modify the environment instead
  87 of SETF ENVIRONMENT."
  88   (cond
  89     (env
  90      (check-type env environment)
  91      (make-instance 'environment
  92                     :variables (copy-hash-table
  93                                 (environment-variables env))))
  94     (t
  95      (%environment))))
  96
  97 (defun (setf environment) (newenv)
  98   (check-type newenv environment)
  99   (let ((oldenv (environment)))
 100     (maphash (lambda (k v)
 101                (setf (environment-variable k) v)
 102                (makunbound-environment-variable k :env oldenv))
 103              (environment-variables newenv))
 104     (maphash (lambda (k v) (declare (ignore v))
 105                (makunbound-environment-variable k))
 106              (environment-variables oldenv)))
 107   newenv)
 108 \f
 109
 110 ;;;; Current directory
 111
 112 (defun current-directory ()
 113   "CURRENT-DIRECTORY returns the operating system's current
 114 directory, which may or may not correspond to
 115 *DEFAULT-FILE-PATH-DEFAULTS*.
 116
 117 SETF CURRENT-DIRECTORY changes the operating system's current
 118 directory to the PATHSPEC.  An error is signalled if PATHSPEC
 119 is not a directory."
 120   (let ((cwd (isys:%sys-getcwd)))
 121     (if cwd
 122         (parse-file-path cwd :expand-user nil)
 123         (isys:syscall-error "Could not get current directory."))))
 124
 125 (defun (setf current-directory) (pathspec)
 126   (let ((path (file-path pathspec)))
 127     (isys:%sys-chdir (file-path-namestring path))))
 128
 129 (defmacro with-current-directory (pathspec &body body)
 130   (with-gensyms (old)
 131     `(let ((,old (current-directory)))
 132        (unwind-protect
 133             (progn
 134               (setf (current-directory) (file-path ,pathspec))
 135               ,@body)
 136          (setf (current-directory) ,old)))))
 137 \f
 138
 139 ;;;; File-path manipulations
 140
 141 (defun absolute-file-path (pathspec defaults)
 142   (let ((path (file-path pathspec)))
 143     (if (absolute-file-path-p path)
 144         path
 145         (let ((tmp (merge-file-paths path defaults)))
 146           (if (absolute-file-path-p tmp)
 147               tmp
 148               (merge-file-paths tmp (current-directory)))))))
 149
 150 (defun strip-dots (path)
 151   (multiple-value-bind (root nodes)
 152       (split-root/nodes (file-path-components path))
 153     (let (new-components)
 154       (dolist (n nodes)
 155         (cond
 156           ((string= n "."))
 157           ((string= n "..")
 158            (pop new-components))
 159           (t (push n new-components))))
 160       (make-file-path :components (if root
 161                                       (cons root (nreverse new-components))
 162                                       (nreverse new-components))
 163                       :defaults path))))
 164
 165 (defun resolve-symlinks (path)
 166   (let* ((namestring (file-path-namestring path))
 167          (realpath (isys:%sys-realpath namestring)))
 168     (parse-file-path realpath)))
 169
 170 (defun resolve-file-path (pathspec &key
 171                           (defaults *default-file-path-defaults*)
 172                           (canonicalize t))
 173   "Returns an absolute file-path corresponding to PATHSPEC by
 174 merging it with DEFAULT, and (CURRENT-DIRECTORY) if necessary.
 175 If CANONICALIZE is non-NIL, the path is canonicalised: if it is :STRIP-DOTS,
 176 then just remove «.» and «..», otherwise symlinks are resolved too."
 177   (let ((absolute-file-path (absolute-file-path pathspec defaults)))
 178     (case canonicalize
 179       ((nil)       absolute-file-path)
 180       (:strip-dots (strip-dots absolute-file-path))
 181       (t           (resolve-symlinks absolute-file-path)))))
 182 \f
 183
 184 ;;;; File kind
 185
 186 ;;; FIXME: make sure that GET-FILE-KIND be able to signal
 187 ;;;        only conditions of type FILE-ERROR, either by
 188 ;;;        wrapping POSIX-ERRORs or making sure that some
 189 ;;;        POSIX-ERRORS subclass FILE-ERROR
 190 (defun get-file-kind (file follow-p)
 191   (let ((namestring (file-path-namestring file)))
 192     (handler-case
 193         (let ((mode (isys:stat-mode
 194                      (if follow-p
 195                          (isys:%sys-stat namestring)
 196                          (isys:%sys-lstat namestring)))))
 197           (switch ((logand isys:s-ifmt mode) :test #'=)
 198             (isys:s-ifdir  :directory)
 199             (isys:s-ifchr  :character-device)
 200             (isys:s-ifblk  :block-device)
 201             (isys:s-ifreg  :regular-file)
 202             (isys:s-iflnk  :symbolic-link)
 203             (isys:s-ifsock :socket)
 204             (isys:s-ififo  :pipe)
 205             (t (bug "Unknown file mode: ~A." mode))))
 206       ((or isys:enoent isys:eloop) ()
 207         (cond
 208           ;; stat() returned ENOENT: either FILE does not exist
 209           ;; or it is a broken symlink
 210           (follow-p
 211            (handler-case
 212                (isys:%sys-lstat namestring)
 213              ((or isys:enoent isys:eloop) ())
 214              (:no-error (stat)
 215                (declare (ignore stat))
 216                (values :symbolic-link :broken))))
 217           ;; lstat() returned ENOENT: FILE does not exist
 218           (t nil))))))
 219
 220 (defun file-kind (pathspec &key follow-symlinks)
 221   "Returns a keyword indicating the kind of file designated by PATHSPEC,
 222 or NIL if the file does not exist.  Does not follow symbolic
 223 links by default.
 224
 225 Possible file-kinds in addition to NIL are: :REGULAR-FILE,
 226 :SYMBOLIC-LINK, :DIRECTORY, :PIPE, :SOCKET, :CHARACTER-DEVICE, and
 227 :BLOCK-DEVICE.
 228 If FOLLOW-SYMLINKS is non-NIL and PATHSPEC designates a broken symlink
 229 returns :BROKEN as second value."
 230   (get-file-kind (merge-file-paths pathspec) follow-symlinks))
 231
 232 (defun file-exists-p (pathspec &optional file-kind)
 233   "Checks whether the file named by the file-path designator
 234 PATHSPEC exists, if this is the case and FILE-KIND is specified
 235 it also checks the file kind. If the tests succeed, return two values:
 236 truename and file kind of PATHSPEC, NIL otherwise.
 237 Follows symbolic links."
 238   (let* ((path (file-path pathspec))
 239          (follow (unless (eq file-kind :symbolic-link) t))
 240          (actual-kind (file-kind path :follow-symlinks follow)))
 241     (when (and actual-kind
 242                (if file-kind (eql file-kind actual-kind) t))
 243       (values (resolve-file-path path)
 244               actual-kind))))
 245
 246 (defun regular-file-exists-p (pathspec)
 247   "Checks whether the file named by the file-path designator
 248 PATHSPEC exists and is a regular file. Returns its truename
 249 if this is the case, NIL otherwise. Follows symbolic links."
 250   (nth-value 0 (file-exists-p pathspec :regular-file)))
 251
 252 (defun directory-exists-p (pathspec)
 253   "Checks whether the file named by the file-path designator
 254 PATHSPEC exists and is a directory.  Returns its truename
 255 if this is the case, NIL otherwise.  Follows symbolic links."
 256   (nth-value 0 (file-exists-p pathspec :directory)))
 257
 258 (defun good-symlink-exists-p (pathspec)
 259   "Checks whether the file named by the file-path designator
 260 PATHSPEC exists and is a symlink pointing to an existent file."
 261   (eq :broken (nth-value 1 (file-kind pathspec :follow-symlinks t))))
 262 \f
 263
 264 ;;;; Temporary files
 265
 266 (defvar *temporary-directory*
 267   (let ((system-tmpdir (or (environment-variable "TMPDIR")
 268                            (environment-variable "TMP")
 269                            "/tmp")))
 270     (parse-file-path system-tmpdir :expand-user nil)))
 271 \f
 272
 273 ;;;; Symbolic and hard links
 274
 275 (defun read-symlink (pathspec)
 276   "Returns the file-path pointed to by the symbolic link
 277 designated by PATHSPEC.  If the link is relative, then the
 278 returned file-path is relative to the link, not
 279 *DEFAULT-FILE-PATH-DEFAULTS*.
 280
 281 Signals an error if PATHSPEC is not a symbolic link."
 282   ;; Note: the previous version tried much harder to provide a buffer
 283   ;; big enough to fit the link's name.  OTOH, %SYS-READLINK stack
 284   ;; allocates on most lisps.
 285   (file-path (isys:%sys-readlink
 286               (file-path-namestring
 287                (absolute-file-path pathspec *default-file-path-defaults*)))))
 288
 289 (defun make-symlink (link target)
 290   "Creates symbolic LINK that points to TARGET.
 291 Returns the file-path of the link.
 292
 293 Relative targets are resolved against the link.  Relative links
 294 are resolved against *DEFAULT-FILE-PATH-DEFAULTS*.
 295
 296 Signals an error if TARGET does not exist, or LINK exists already."
 297   (let ((link (file-path link))
 298         (target (file-path target)))
 299     (with-current-directory
 300         (absolute-file-path *default-file-path-defaults* nil)
 301       (isys:%sys-symlink (file-path-namestring target)
 302                          (file-path-namestring link))
 303       link)))
 304
 305 (defun make-hardlink (link target)
 306   "Creates hard LINK that points to TARGET.
 307 Returns the file-path of the link.
 308
 309 Relative targets are resolved against the link.  Relative links
 310 are resolved against *DEFAULT-FILE-PATH-DEFAULTS*.
 311
 312 Signals an error if TARGET does not exist, or LINK exists already."
 313   (let ((link (file-path link))
 314         (target (file-path target)))
 315     (with-current-directory
 316         (absolute-file-path *default-file-path-defaults* nil)
 317       (isys:%sys-link (file-path-namestring
 318                        (merge-file-paths target link))
 319                       link)
 320       link)))
 321 \f
 322
 323 ;;;; File permissions
 324
 325 (defconstant (+permissions+ :test #'equal)
 326   `((:user-read    . ,isys:s-irusr)
 327     (:user-write   . ,isys:s-iwusr)
 328     (:user-exec    . ,isys:s-ixusr)
 329     (:group-read   . ,isys:s-irgrp)
 330     (:group-write  . ,isys:s-iwgrp)
 331     (:group-exec   . ,isys:s-ixgrp)
 332     (:other-read   . ,isys:s-iroth)
 333     (:other-write  . ,isys:s-iwoth)
 334     (:other-exec   . ,isys:s-ixoth)
 335     (:set-user-id  . ,isys:s-isuid)
 336     (:set-group-id . ,isys:s-isgid)
 337     (:sticky       . ,isys:s-isvtx)))
 338
 339 (defun file-permissions (pathspec)
 340   "FILE-PERMISSIONS returns a list of keywords identifying the
 341 permissions of PATHSPEC.
 342
 343 SETF FILE-PERMISSIONS sets the permissions of PATHSPEC as
 344 identified by the symbols in list.
 345
 346 If PATHSPEC designates a symbolic link, that link is implicitly
 347 resolved.
 348
 349 Permission symbols consist of :USER-READ, :USER-WRITE, :USER-EXEC,
 350 :GROUP-READ, :GROUP-WRITE, :GROUP-EXEC, :OTHER-READ, :OTHER-WRITE,
 351 :OTHER-EXEC, :SET-USER-ID, :SET-GROUP-ID, and :STICKY.
 352
 353 Both signal an error if PATHSPEC doesn't designate an existing file."
 354   (let ((mode (isys:stat-mode
 355                (isys:%sys-stat (file-path-namestring pathspec)))))
 356     (loop :for (name . value) :in +permissions+
 357           :when (plusp (logand mode value))
 358           :collect name)))
 359
 360 (defun (setf file-permissions) (perms pathspec)
 361   (isys:%sys-chmod (file-path-namestring pathspec)
 362                    (reduce (lambda (a b)
 363                              (logior a (cdr (assoc b +permissions+))))
 364                            perms :initial-value 0)))
 365 \f
 366
 367 ;;;; Directory access
 368
 369 (defmacro with-directory-iterator ((iterator pathspec) &body body)
 370   "PATHSPEC must be a valid directory designator:
 371 *DEFAULT-FILE-PATH-DEFAULTS* is bound, and (CURRENT-DIRECTORY) is set
 372 to the designated directory for the dynamic scope of the body.
 373
 374 Within the lexical scope of the body, ITERATOR is defined via
 375 macrolet such that successive invocations of (ITERATOR) return
 376 the directory entries, one by one.  Both files and directories
 377 are returned, except '.' and '..'.  The order of entries is not
 378 guaranteed.  The entries are returned as relative file-paths
 379 against the designated directory.  Entries that are symbolic
 380 links are not resolved, but links that point to directories are
 381 interpreted as directory designators.  Once all entries have been
 382 returned, further invocations of (ITERATOR) will all return NIL.
 383
 384 The value returned is the value of the last form evaluated in
 385 body.  Signals an error if PATHSPEC is not a directory."
 386   (with-unique-names (one-iter)
 387     `(call-with-directory-iterator
 388       ,pathspec
 389       (lambda (,one-iter)
 390         (declare (type function ,one-iter))
 391         (macrolet ((,iterator ()
 392                      `(funcall ,',one-iter)))
 393           ,@body)))))
 394
 395 (defun call-with-directory-iterator (pathspec fn)
 396   (let* ((dir (resolve-file-path pathspec :canonicalize nil))
 397          (dp (isys:%sys-opendir (file-path-namestring dir))))
 398     (labels ((one-iter ()
 399                (let ((name (isys:%sys-readdir dp)))
 400                  (unless (null name)
 401                    (cond
 402                      ((member name '("." "..") :test #'string=)
 403                       (one-iter))
 404                      (t
 405                       (parse-file-path name)))))))
 406       (with-current-directory dir
 407         (unwind-protect
 408              (let ((*default-file-path-defaults* dir))
 409                (funcall fn #'one-iter))
 410           (isys:%sys-closedir dp))))))
 411
 412 (defun mapdir (function pathspec)
 413   "Applies function to each entry in directory designated by
 414 PATHSPEC in turn and returns a list of the results.  Binds
 415 *DEFAULT-FILE-PATH-DEFAULTS* to the directory designated by
 416 pathspec round to function call.
 417
 418 If PATHSPEC designates a symbolic link, it is implicitly resolved.
 419
 420 Signals an error if PATHSPEC is not a directory."
 421   (with-directory-iterator (next pathspec)
 422     (loop :for entry := (next)
 423           :while entry
 424           :collect (funcall function entry))))
 425
 426 (defun list-directory (pathspec &key absolute-paths)
 427   "Returns a fresh list of file-paths corresponding to all files
 428 within the directory named by PATHSPEC.
 429 If ABSOLUTE-PATHS is not NIL the files' paths are merged with PATHSPEC."
 430   (with-directory-iterator (next pathspec)
 431     (loop :for entry := (next)
 432           :while entry :collect (if absolute-paths
 433                                     (merge-file-paths entry pathspec)
 434                                     entry))))
 435
 436 (defun walk-directory (directory fn &key (if-does-not-exist :error)
 437                        follow-symlinks (directories :before)
 438                        (mindepth 1) (maxdepth 65535)
 439                        (test (constantly t)) (key #'identity))
 440   "Recursively applies the function FN to all files within the
 441 directory named by the FILE-PATH designator DIRNAME and all of
 442 the files and directories contained within.  Returns T on success."
 443   (labels ((walk (name depth parent)
 444              (incf depth)
 445              (let* ((kind
 446                      (file-kind name :follow-symlinks follow-symlinks))
 447                     (path-components
 448                      (revappend parent (file-path-components name)))
 449                     (path (make-file-path :components path-components))
 450                     (name-key (funcall key path)))
 451                (case kind
 452                  (:directory
 453                   (when (and (funcall test name-key kind)
 454                              (< depth maxdepth))
 455                     (ecase directories
 456                       (:before
 457                        (when (<= mindepth depth)
 458                          (callfn name-key kind))
 459                        (walkdir name depth parent))
 460                       (:after
 461                        (walkdir name depth parent)
 462                        (when (<= mindepth depth)
 463                          (callfn name-key kind))))))
 464                  (t (when (and (funcall test name-key kind)
 465                                (<= mindepth depth))
 466                       (callfn name-key kind)))))
 467              (decf depth))
 468            (walkdir (name depth parent)
 469              (mapdir (lambda (dir)
 470                        (walk dir (1+ depth)
 471                              (if (plusp depth)
 472                                  (cons (file-path-file name) parent)
 473                                  parent)))
 474                      name))
 475            (callfn (key kind)
 476              (restart-case
 477                  (funcall fn key kind)
 478                (ignore-file-system-error ()
 479                  :report "Ignore file system error and continue"))))
 480     (handler-case
 481         (let* ((directory (file-path directory))
 482                (ns (file-path-namestring directory))
 483                (kind
 484                 (file-kind directory :follow-symlinks t)))
 485           (unless (eql :directory kind)
 486             (isys:syscall-error "~S is not a directory" directory))
 487           (walk ns -1 ()) t)
 488       ;; FIXME: Handle all possible syscall errors
 489       (isys:enoent ()
 490         (ecase if-does-not-exist
 491           (:error (isys:syscall-error "Directory ~S does not exist"
 492                                       directory))
 493           ((nil)  nil)))
 494       (isys:eacces ()
 495         (isys:syscall-error "Search permission is denied for ~S"
 496                             directory)))))
 497
 498 (defun delete-files (pathspec &key recursive)
 499   (labels ((%delete-file (file)
 500              (isys:%sys-unlink (file-path-namestring file)))
 501            (%delete-directory (directory)
 502              (isys:%sys-rmdir (file-path-namestring directory))))
 503     (let* ((pathspec (file-path pathspec))
 504            (kind (file-kind pathspec :follow-symlinks t)))
 505       (case kind
 506         (:directory
 507          (if recursive
 508              (walk-directory pathspec
 509                              (lambda (name kind)
 510                                (case kind
 511                                  (:directory (%delete-directory name))
 512                                  (t          (%delete-file name))))
 513                              :directories :after)
 514              (%delete-directory pathspec)))
 515         (t (%delete-file pathspec))))))
 516 \f
 517
 518 ;;;; User information
 519
 520 (defun user-info (id)
 521   "USER-INFO returns the password entry for the given name or
 522 numerical user ID, as an assoc-list."
 523   (multiple-value-bind (name password uid gid gecos home shell)
 524       (etypecase id
 525         (string  (isys:%sys-getpwnam id))
 526         (integer (isys:%sys-getpwuid id)))
 527     (declare (ignore password))
 528     (unless (null name)
 529       (list (cons :name name)
 530             (cons :user-id uid)
 531             (cons :group-id gid)
 532             (cons :gecos gecos)
 533             (cons :home home)
 534             (cons :shell shell)))))