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