src/pathnames/file-path.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 (eval-when (:compile-toplevel :load-toplevel :execute)
  13   (defconstant +file-path-host-type+
  14     #+unix    'unix-path
  15     #+windows 'unc-path))
  16
  17 (defclass file-path ()
  18   ((host :initarg :host)
  19    (device :initarg :device)
  20    (components :initarg :components
  21                :initform nil)))
  22
  23 (deftype file-path-designator ()
  24   `(or ,+file-path-host-type+ string))
  25
  26 (define-condition invalid-file-path (isys:iolib-error type-error)
  27   ((path :initarg :path :reader invalid-file-path-path)
  28    (reason :initform nil :initarg :reason :reader invalid-file-path-reason))
  29   (:report (lambda (condition stream)
  30              (format stream "Invalid file path: ~S."
  31                      (invalid-file-path-path condition))
  32              (when-let (reason (invalid-file-path-reason condition))
  33                (format stream "~%~A." reason)))))
  34 \f
  35
  36 ;;;-------------------------------------------------------------------------
  37 ;;; Constants
  38 ;;;-------------------------------------------------------------------------
  39
  40 (defconstant +directory-delimiter+
  41   #+unix    #\/
  42   #+windows #\\)
  43
  44 (defconstant +alternative-delimiter+
  45   #+unix    nil
  46   #+windows #\/)
  47
  48 (defconstant (+directory-delimiters+ :test #'equal)
  49   (list* +directory-delimiter+ +alternative-delimiter+))
  50
  51 (defconstant +execution-path-delimiter+
  52   #+unix    #\:
  53   #+windows #\;)
  54
  55 (declaim (special *default-file-path-defaults*))
  56 \f
  57
  58 ;;;-------------------------------------------------------------------------
  59 ;;; Generic Functions
  60 ;;;-------------------------------------------------------------------------
  61
  62 (defgeneric file-path (pathspec))
  63
  64 (defgeneric file-path-namestring (path))
  65 \f
  66
  67 ;;;-------------------------------------------------------------------------
  68 ;;; Accessors
  69 ;;;-------------------------------------------------------------------------
  70
  71 (defun file-path-host (pathspec &key namestring)
  72   (let ((path (file-path pathspec)))
  73     (if namestring
  74         (%file-path-host-namestring path)
  75         (slot-value path 'host))))
  76
  77 (defun file-path-device (pathspec &key namestring)
  78   (let ((path (file-path pathspec)))
  79     (if namestring
  80         (%file-path-device-namestring path)
  81         (slot-value path 'device))))
  82
  83 (defun file-path-components (pathspec &key namestring)
  84   (let ((path (file-path pathspec)))
  85     (if namestring
  86        (%file-path-components-namestring path)
  87        (slot-value path 'components))))
  88
  89 (defun split-root/nodes (dir)
  90   (if (eql :root (car dir))
  91       (values :root (cdr dir))
  92       (values nil   dir)))
  93
  94 (defun %file-path-directory (path)
  95   (let ((components (slot-value path 'components)))
  96     (multiple-value-bind (root nodes)
  97         (split-root/nodes components)
  98       (if root
  99           (cons root (butlast nodes))
 100           (or (butlast nodes)
 101               (list "."))))))
 102
 103 (defun file-path-directory (pathspec &key namestring)
 104   (let ((path (file-path pathspec)))
 105     (if namestring
 106         (%file-path-directory-namestring path)
 107         (%file-path-directory path))))
 108
 109 (defun file-path-file (pathspec &key namestring)
 110   (declare (ignore namestring))
 111   (let* ((path (file-path pathspec))
 112          (components (slot-value path 'components)))
 113     (or (lastcar (nth-value 1 (split-root/nodes components)))
 114         ".")))
 115
 116 (defun split-name/type (path)
 117   (let ((dotpos (position #\. path :start 1 :from-end t)))
 118     (cond
 119       ((or (null dotpos) (member path '("." "..") :test #'string=))
 120        (values path nil))
 121       (t (values (subseq path 0 dotpos)
 122                  (full-string (subseq path (1+ dotpos))))))))
 123
 124 (defun file-path-file-name (pathspec)
 125   (let ((file (file-path-file pathspec)))
 126     (nth-value 0 (split-name/type file))))
 127
 128 (defun file-path-file-type (pathspec)
 129   (let ((file (file-path-file pathspec)))
 130     (nth-value 1 (split-name/type file))))
 131 \f
 132
 133 ;;;-------------------------------------------------------------------------
 134 ;;; Constructors
 135 ;;;-------------------------------------------------------------------------
 136
 137 (defun valid-component-types-p (components)
 138   (multiple-value-bind (root nodes)
 139       (split-root/nodes components)
 140     (and (member root '(nil :root))
 141          (every #'stringp nodes))))
 142
 143 (defmethod initialize-instance :after ((path file-path) &key components)
 144   (check-type components (and (not null) (satisfies valid-component-types-p)))
 145   (setf (slot-value path 'components) components)
 146   (dolist (node (cdr (slot-value path 'components)))
 147     (when (zerop (length node))
 148       (error 'invalid-file-path :path ""
 149              :reason "Null filenames are not valid"))
 150     (when (find-if (lambda (c) (member c +directory-delimiters+)) node)
 151       (error 'invalid-file-path :path node
 152              :reason (format nil
 153                              "Path components cannot contain delimiters(~A)"
 154                              (join* " and "
 155                                     (mapcar 'prin1-to-string
 156                                             +directory-delimiters+)))))))
 157 \f
 158
 159 ;;;-------------------------------------------------------------------------
 160 ;;; Predicates
 161 ;;;-------------------------------------------------------------------------
 162
 163 (defun file-path-p (thing)
 164   (typep thing 'file-path))
 165
 166 (defun absolute-p (dir)
 167   (eql :root (car dir)))
 168
 169 (defun absolute-file-path-p (path)
 170   (check-type path file-path)
 171   (absolute-p (slot-value path 'components)))
 172
 173 (defun relative-file-path-p (path)
 174   (check-type path file-path)
 175   (not (absolute-p (slot-value path 'components))))
 176 \f
 177
 178 ;;;-------------------------------------------------------------------------
 179 ;;; Operations
 180 ;;;-------------------------------------------------------------------------
 181
 182 (defmethod file-path ((path file-path))
 183   path)
 184
 185 (defmethod file-path (pathspec)
 186   (parse-file-path pathspec))
 187
 188 (defmethod file-path ((pathspec pathname))
 189   (parse-file-path (namestring pathspec)))
 190 \f
 191
 192 ;;;-------------------------------------------------------------------------
 193 ;;; PRINT-OBJECT
 194 ;;;-------------------------------------------------------------------------
 195
 196 (defmethod print-object ((path file-path) stream)
 197   (let ((ns (file-path-namestring path)))
 198     (if (or *print-readably* *print-escape*)
 199         (format stream "#/~S/~S" 'p ns)
 200         (write-string ns stream))))
 201
 202 (define-literal-reader p (stream)
 203   (let ((token (read stream)))
 204     (check-type token string)
 205     (file-path token)))