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