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
  54                                     &key (overwrite t))
  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))
  59         (name (string name)))
  60     (etypecase env
  61       (null
  62        (isys:setenv name value overwrite))
  63       (environment
  64        (%obj-setenv env name value overwrite)))
  65     value))
  66
  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
  71 failure."
  72   (let ((name (string name)))
  73     (etypecase env
  74       (null
  75        (isys:unsetenv name))
  76       (environment
  77        (%obj-unsetenv env name)))
  78     name))
  79
  80 (defun clear-environment (&optional env)
  81   "Removes all variables from an environment."
  82   (etypecase env
  83     (null
  84      (isys:clearenv))
  85     (environment
  86      (%obj-clearenv env)
  87      env)))
  88
  89 (defun environment ()
  90   "Return the current global environment."
  91   (let ((env (make-instance 'environment))
  92         (envptr (isys:os-environ)))
  93     (if (null-pointer-p envptr)
  94         ()
  95         (loop :for i :from 0 :by 1
  96               :for string := (mem-aref envptr :string i)
  97               :for split := (position #\= string)
  98               :while string :do
  99               (let ((name (subseq string 0 split))
 100                     (value (subseq string (1+ split))))
 101                 (%obj-setenv env name value t))))
 102     env))
 103
 104 (defun (setf environment) (newenv)
 105   "SETF ENVIRONMENT replaces the contents of the global environment
 106 with that of its argument.
 107
 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)
 112   (isys:clearenv)
 113   (maphash (lambda (name value)
 114              (isys:setenv name value t))
 115            (environment-variables newenv))
 116   newenv)
 117
 118 (defun allocate-env (argv variables)
 119   (let ((offset -1))
 120     ;; copy variables
 121     (maphash (lambda (k v)
 122                (setf (mem-aref argv :pointer (incf offset))
 123                      (foreign-string-alloc (concatenate 'string k "=" v))))
 124              variables)))
 125
 126 (defun delocate-null-ended-list (argv)
 127   (loop :for i :from 0
 128         :for ptr := (mem-aref argv :pointer i)
 129         :if (null-pointer-p ptr) :do (loop-finish)
 130         :else :do (foreign-free ptr)))
 131
 132 (defmacro with-c-environment ((var environment) &body body)
 133   (with-gensyms (body-fn ptr count)
 134     `(flet ((,body-fn (,ptr)
 135               (let ((,var ,ptr))
 136                 ,@body)))
 137        (etypecase ,environment
 138          (null
 139           (,body-fn (null-pointer)))
 140          ((eql t)
 141           (,body-fn (isys:os-environ)))
 142          (environment
 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)))
 147               (unwind-protect
 148                    (progn
 149                      (allocate-env ,ptr (environment-variables ,environment))
 150                      (,body-fn ,ptr))
 151                 (delocate-null-ended-list ,ptr)))))))))
 152 \f
 153
 154 ;;;; Current directory
 155
 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)))
 161     (if cwd
 162         (parse-file-path cwd :expand-user nil)
 163         (isys:syscall-error "Could not get current directory."))))
 164
 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
 168 is not a directory."
 169   (let ((path (file-path pathspec)))
 170     (isys:chdir (file-path-namestring path))))
 171
 172 (defmacro with-current-directory (pathspec &body body)
 173   (with-gensyms (old)
 174     `(let ((,old (current-directory)))
 175        (unwind-protect
 176             (progn
 177               (setf (current-directory) (file-path ,pathspec))
 178               ,@body)
 179          (setf (current-directory) ,old)))))
 180 \f
 181
 182 ;;;; File-path manipulations
 183
 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)
 188         path
 189         (let ((tmp (merge-file-paths path defaults)))
 190           (if (absolute-file-path-p tmp)
 191               tmp
 192               (merge-file-paths tmp (current-directory)))))))
 193
 194 (defun strip-dots (path)
 195   (multiple-value-bind (root nodes)
 196       (split-root/nodes (file-path-components path))
 197     (let (new-components)
 198       (dolist (n nodes)
 199         (cond
 200           ((string= n "."))
 201           ((string= n "..")
 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))
 207                       :defaults path))))
 208
 209 (defun resolve-symlinks (path)
 210   (let* ((namestring (file-path-namestring path))
 211          (realpath (isys:realpath namestring)))
 212     (parse-file-path realpath)))
 213
 214 (defun resolve-file-path (pathspec &key
 215                           (defaults *default-file-path-defaults*)
 216                           (canonicalize t))
 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)))
 222     (case canonicalize
 223       ((nil)       absolute-file-path)
 224       (:strip-dots (strip-dots absolute-file-path))
 225       (t           (resolve-symlinks absolute-file-path)))))
 226 \f
 227
 228 ;;;; File kind
 229
 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)))
 236     (handler-case
 237         (let ((mode (isys:stat-mode
 238                      (if follow-p
 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)
 248             (isys:s-ififo  :pipe)
 249             (t (bug "Unknown file mode: ~A." mode))))
 250       ((or isys:enoent isys:eloop) ()
 251         (cond
 252           ;; stat() returned ENOENT: either FILE does not exist
 253           ;; or it is a broken symlink
 254           (follow-p
 255            (handler-case
 256                (isys:lstat namestring)
 257              ((or isys:enoent isys:eloop) ())
 258              (:no-error (stat)
 259                (declare (ignore stat))
 260                (values :symbolic-link :broken))))
 261           ;; lstat() returned ENOENT: FILE does not exist
 262           (t nil))))))
 263
 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
 267 links by default.
 268
 269 Possible file-kinds in addition to NIL are: :REGULAR-FILE,
 270 :SYMBOLIC-LINK, :DIRECTORY, :PIPE, :SOCKET, :CHARACTER-DEVICE, and
 271 :BLOCK-DEVICE.
 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))
 275
 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)
 288               actual-kind))))
 289
 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)))
 295
 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)))
 301
 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))))
 306 \f
 307
 308 ;;;; Temporary files
 309
 310 (defvar *temporary-directory*
 311   (let ((system-tmpdir (or (environment-variable "TMPDIR")
 312                            (environment-variable "TMP")
 313                            "/tmp")))
 314     (parse-file-path system-tmpdir :expand-user nil)))
 315 \f
 316
 317 ;;;; Symbolic and hard links
 318
 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*.
 324
 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*)))))
 332
 333 (defun make-symlink (link target)
 334   "Creates symbolic LINK that points to TARGET.
 335 Returns the file-path of the link.
 336
 337 Relative targets are resolved against the link. Relative links
 338 are resolved against *DEFAULT-FILE-PATH-DEFAULTS*.
 339
 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))
 347       link)))
 348
 349 (defun make-hardlink (link target)
 350   "Creates hard LINK that points to TARGET.
 351 Returns the file-path of the link.
 352
 353 Relative targets are resolved against the link. Relative links
 354 are resolved against *DEFAULT-FILE-PATH-DEFAULTS*.
 355
 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))
 363                       link)
 364       link)))
 365 \f
 366
 367 ;;;; File permissions
 368
 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)))
 382
 383 (defun file-permissions (pathspec)
 384   "FILE-PERMISSIONS returns a list of keywords identifying the
 385 permissions of PATHSPEC.
 386
 387 SETF FILE-PERMISSIONS sets the permissions of PATHSPEC as
 388 identified by the symbols in list.
 389
 390 If PATHSPEC designates a symbolic link, that link is implicitly
 391 resolved.
 392
 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.
 396
 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))
 402           :collect name)))
 403
 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)))
 409 \f
 410
 411 ;;;; Directory access
 412
 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.
 417
 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.
 427
 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
 432       ,pathspec
 433       (lambda (,one-iter)
 434         (declare (type function ,one-iter))
 435         (macrolet ((,iterator ()
 436                      `(funcall ,',one-iter)))
 437           ,@body)))))
 438
 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)))
 444                  (unless (null name)
 445                    (cond
 446                      ((member name '("." "..") :test #'string=)
 447                       (one-iter))
 448                      (t
 449                       (parse-file-path name)))))))
 450       (unwind-protect
 451            (let ((*default-file-path-defaults* dir))
 452              (funcall fn #'one-iter))
 453         (isys:closedir dp)))))
 454
 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.
 460
 461 If PATHSPEC designates a symbolic link, it is implicitly resolved.
 462
 463 Signals an error if PATHSPEC is not a directory."
 464   (with-directory-iterator (next pathspec)
 465     (loop :for entry := (next)
 466           :while entry
 467           :collect (funcall function entry))))
 468
 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)))
 475
 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)
 485              (let* ((kind
 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)))
 492                       (maybe-walkdir ()
 493                         (when (or (< depth mindepth)
 494                                   (and (< depth maxdepth)
 495                                        (funcall test name-key kind)))
 496                           (walkdir name depth parent))))
 497                  (case kind
 498                    (:directory
 499                     (when (eql :before directories) (maybe-callfn))
 500                     (maybe-walkdir)
 501                     (when (eql :after directories) (maybe-callfn)))
 502                    (t (maybe-callfn))))))
 503            (walkdir (name depth parent)
 504              (mapdir (lambda (dir)
 505                        (walk dir (1+ depth)
 506                              (cond
 507                                ((zerop depth) (list "."))
 508                                ((plusp depth)
 509                                 (cons (file-path-file name) parent))
 510                                (t parent))))
 511                      name))
 512            (callfn (key kind parent depth)
 513              (restart-case
 514                  (let ((parent
 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))
 520            (kind
 521             (handler-case
 522                 (file-kind directory :follow-symlinks t)
 523               (isys:enoent ()
 524                 (ecase if-does-not-exist
 525                   (:error (isys:syscall-error "Directory ~S does not exist"
 526                                               directory))
 527                   ((nil)  (return* nil))))
 528               (isys:eacces ()
 529                 (isys:syscall-error "Search permission is denied for ~S"
 530                                     directory)))))
 531       (unless (eql :directory kind)
 532         (isys:syscall-error "~S is not a directory" directory))
 533       (walk directory 0 nil)
 534       t)))
 535
 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)))
 545       (case kind
 546         (:directory
 547          (if recursive
 548              (walk-directory pathspec
 549                              (lambda (name kind parent depth)
 550                                (declare (ignore parent depth))
 551                                (case kind
 552                                  (:directory (%delete-directory name))
 553                                  (t          (%delete-file name))))
 554                              :directories :after
 555                              :mindepth 0)
 556              (%delete-directory pathspec)))
 557         (t (%delete-file pathspec))))))
 558 \f
 559
 560 ;;;; User information
 561
 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)
 566       (etypecase id
 567         (string  (isys:getpwnam id))
 568         (integer (isys:getpwuid id)))
 569     (declare (ignore password))
 570     (if name
 571         (list (cons :name name)
 572               (cons :user-id uid)
 573               (cons :group-id gid)
 574               (cons :gecos gecos)
 575               (cons :home home)
 576               (cons :shell shell))
 577         nil)))