src/pathnames/file-path-unix.lisp

   1 ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*-
   2 ;;;
   3 ;;; --- New pathnames.
   4 ;;;
   5
   6 (in-package :iolib.pathnames)
   7
   8 ;;;-------------------------------------------------------------------------
   9 ;;; Classes and Types
  10 ;;;-------------------------------------------------------------------------
  11
  12 (defclass unix-path (file-path)
  13   ()
  14   (:default-initargs :host :unspecific
  15                      :device :unspecific))
  16 \f
  17
  18 ;;;-------------------------------------------------------------------------
  19 ;;; Constructors
  20 ;;;-------------------------------------------------------------------------
  21
  22 (defmethod initialize-instance :after ((path unix-path) &key)
  23   (with-slots (host device)
  24       path
  25     (unless device (setf device :unspecific))
  26     (check-type host (eql :unspecific))
  27     (check-type device (eql :unspecific))))
  28 \f
  29
  30 ;;;-------------------------------------------------------------------------
  31 ;;; Predicates
  32 ;;;-------------------------------------------------------------------------
  33
  34 (defun unix-path-p (thing)
  35   (typep thing 'unix-path))
  36 \f
  37
  38 ;;;-------------------------------------------------------------------------
  39 ;;; Operations
  40 ;;;-------------------------------------------------------------------------
  41
  42 (defun make-file-path (&key host device (components nil componentsp)
  43                        (defaults nil defaultsp))
  44   (declare (ignore host device))
  45   (let ((defaults (and defaultsp (file-path defaults))))
  46     (make-instance 'unix-path
  47                    :components (cond (componentsp components)
  48                                      (defaultsp
  49                                       (file-path-components defaults))))))
  50
  51 (defun merge-file-paths (pathspec &optional
  52                          (defaults *default-file-path-defaults*))
  53   (let ((path (file-path pathspec))
  54         (defaults (file-path defaults)))
  55     (if (absolute-file-path-p path)
  56         path
  57         (make-instance 'unix-path
  58                        :components (append (file-path-components defaults)
  59                                            (file-path-components path))))))
  60
  61 (defun enough-file-path (pathspec &optional
  62                          (defaults *default-file-path-defaults*))
  63   (let ((path (file-path pathspec))
  64         (defaults (file-path defaults)))
  65     (cond
  66       ((or (relative-file-path-p path)
  67            (relative-file-path-p defaults))
  68        path)
  69       (t
  70        (let* ((dir (cdr (slot-value path 'components)))
  71               (mismatch
  72                (mismatch dir (cdr (slot-value defaults 'components))
  73                          :test #'string=)))
  74          (if mismatch
  75              (make-instance 'unix-path :components (subseq dir mismatch))
  76              (make-instance 'unix-path :components (list :root))))))))
  77
  78 (defun %file-path-host-namestring (path)
  79   (declare (ignore path))
  80   "")
  81
  82 (defun %file-path-device-namestring (path)
  83   (declare (ignore path))
  84   "")
  85
  86 (defun %components-namestring (components)
  87   (multiple-value-bind (root dirs)
  88       (split-root/nodes components)
  89     (let ((delimstr (string +directory-delimiter+))
  90           (nullstr ""))
  91       (concatenate 'string
  92                    (if (eql :root root)
  93                        delimstr
  94                        (if (null dirs)
  95                            "."
  96                            nullstr))
  97                    (apply #'join +directory-delimiter+ dirs)))))
  98
  99 (defun %file-path-components-namestring (path)
 100   (%components-namestring (slot-value path 'components)))
 101
 102 (defun %file-path-directory-namestring (path)
 103   (%components-namestring (%file-path-directory path)))
 104
 105 (defmethod file-path-namestring ((path unix-path))
 106   (%components-namestring (slot-value path 'components)))
 107
 108 (defmethod file-path-namestring (pathspec)
 109   (file-path-namestring (file-path pathspec)))
 110
 111 (defun split-directory-namestring (namestring)
 112   (split-sequence-if (lambda (c) (char= c +directory-delimiter+))
 113                      namestring
 114                      :remove-empty-subseqs t))
 115
 116 (defun absolute-namestring-p (namestring)
 117   (char= +directory-delimiter+ (aref namestring 0)))
 118
 119 (defun parse-file-path (pathspec &key (start 0) end (expand-user t))
 120   (check-type pathspec string)
 121   (when (zerop (length pathspec))
 122     (error 'invalid-file-path
 123            :path pathspec
 124            :reason "Null paths are not valid"))
 125   (let* ((actual-namestring (subseq pathspec start end))
 126          (expansion (or (when expand-user
 127                           (ignore-some-conditions (isys:syscall-error)
 128                             (%expand-user-directory actual-namestring)))
 129                         actual-namestring))
 130          (components (split-directory-namestring expansion)))
 131     (make-instance 'unix-path
 132                    :components (if (absolute-namestring-p expansion)
 133                                    (cons :root components)
 134                                    components))))
 135
 136 (defun %expand-user-directory (pathspec)
 137   (flet ((user-homedir (user)
 138            (nth-value 5 (isys:getpwnam user)))
 139          (uid-homedir (uid)
 140            (nth-value 5 (isys:getpwuid uid))))
 141     (unless (char= #\~ (aref pathspec 0))
 142       (return* pathspec))
 143     (destructuring-bind (first &rest rest)
 144         (split-directory-namestring pathspec)
 145       (let ((homedir
 146              (cond
 147                ((string= "~" first)
 148                 (or (isys:getenv "HOME")
 149                     (let ((username
 150                            (or (isys:getenv "USER")
 151                                (isys:getenv "LOGIN"))))
 152                       (if username
 153                           (user-homedir username)
 154                           (uid-homedir (isys:getuid))))))
 155                ((char= #\~ (aref first 0))
 156                 (user-homedir (subseq first 1)))
 157                (t
 158                 (bug "The pathspec is suppose to start with a ~S" #\~)))))
 159         (if homedir
 160             (apply #'join +directory-delimiter+ homedir rest)
 161             pathspec)))))
 162 \f
 163
 164 ;;;-------------------------------------------------------------------------
 165 ;;; Specials
 166 ;;;-------------------------------------------------------------------------
 167
 168 (defparameter *default-file-path-defaults*
 169   (or (ignore-some-conditions (isys:syscall-error)
 170         (parse-file-path (isys:getcwd)))
 171       (ignore-some-conditions (isys:syscall-error)
 172         (parse-file-path "~"))
 173       (parse-file-path "/")))
 174
 175 (defparameter *default-execution-path*
 176   (mapcar #'parse-file-path
 177           (split-sequence +execution-path-delimiter+
 178                           (isys:getenv "PATH")
 179                           :remove-empty-subseqs t)))