src/os/os-unix.lisp

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