src/pathnames/file-path.lisp

   1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-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 (file)
 117   (let* ((dotpos (position #\. file :start 1 :from-end t)))
 118     (cond
 119       ((null dotpos)
 120        (values file nil))
 121       ((= (1+ dotpos) (length file))
 122        (values (subseq file 0 dotpos) nil))
 123       (t (values (subseq file 0 dotpos)
 124                  (subseq file (1+ dotpos)))))))
 125
 126 (defun file-path-file-name (pathspec)
 127   (let* ((file (file-path-file pathspec)))
 128     (switch (file :test #'string=)
 129       ("." ".." file)
 130       (t (nth-value 0 (split-name/type file))))))
 131
 132 (defun file-path-file-type (pathspec)
 133   (let* ((file (file-path-file pathspec)))
 134     (switch (file :test #'string=)
 135       ("." ".." nil)
 136       (t (nth-value 1 (split-name/type file))))))
 137 \f
 138
 139 ;;;-------------------------------------------------------------------------
 140 ;;; Constructors
 141 ;;;-------------------------------------------------------------------------
 142
 143 (defun valid-component-types-p (components)
 144   (multiple-value-bind (root nodes)
 145       (split-root/nodes components)
 146     (and (member root '(nil :root))
 147          (every #'stringp nodes))))
 148
 149 (defmethod initialize-instance :after ((path file-path) &key components)
 150   (check-type components (and (not null) (satisfies valid-component-types-p)))
 151   (setf (slot-value path 'components) components)
 152   (dolist (node (cdr (slot-value path 'components)))
 153     (when (zerop (length node))
 154       (error 'invalid-file-path :path ""
 155              :reason "Null filenames are not valid"))
 156     (when (find-if (lambda (c) (member c +directory-delimiters+)) node)
 157       (error 'invalid-file-path :path node
 158              :reason "Path components cannot contain directory delimiters(#\\ and #\/)"))))
 159 \f
 160
 161 ;;;-------------------------------------------------------------------------
 162 ;;; Predicates
 163 ;;;-------------------------------------------------------------------------
 164
 165 (defun file-path-p (thing)
 166   (typep thing 'file-path))
 167
 168 (defun absolute-p (dir)
 169   (eql :root (car dir)))
 170
 171 (defun absolute-file-path-p (path)
 172   (check-type path file-path)
 173   (absolute-p (slot-value path 'components)))
 174
 175 (defun relative-file-path-p (path)
 176   (check-type path file-path)
 177   (not (absolute-p (slot-value path 'components))))
 178 \f
 179
 180 ;;;-------------------------------------------------------------------------
 181 ;;; Operations
 182 ;;;-------------------------------------------------------------------------
 183
 184 (defmethod file-path ((path file-path))
 185   path)
 186
 187 (defmethod file-path (pathspec)
 188   (parse-file-path pathspec))
 189
 190 (defmethod file-path ((pathspec pathname))
 191   (parse-file-path (namestring pathspec)))
 192 \f
 193
 194 ;;;-------------------------------------------------------------------------
 195 ;;; PRINT-OBJECT
 196 ;;;-------------------------------------------------------------------------
 197
 198 (defmethod print-object ((path file-path) stream)
 199   (let ((ns (file-path-namestring path)))
 200     (if *print-escape*
 201         (format stream "#/p/~S" ns)
 202         (write-string ns stream))))
 203
 204 (define-literal-reader p (stream)
 205   (let ((token (read stream)))
 206     (check-type token string)
 207     (file-path token)))