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 (defclass file-path ()
  13   ((host :initarg :host)
  14    (device :initarg :device)
  15    (directory :initarg :directory
  16               :initform nil)
  17    (name :initarg :name
  18          :initform nil)
  19    (directory-delimiter
  20     :reader file-path-directory-delimiter
  21     :allocation :class)
  22    (alternative-delimiter
  23     :reader file-path-alternative-delimiter
  24     :allocation :class)
  25    (execution-path-delimiter
  26     :reader file-path-execution-path-delimiter
  27     :allocation :class)))
  28 \f
  29
  30 ;;;-------------------------------------------------------------------------
  31 ;;; Constants
  32 ;;;-------------------------------------------------------------------------
  33
  34 (eval-when (:compile-toplevel :load-toplevel :execute)
  35   (defconstant +file-path-host-type+
  36     #+unix 'unix-path #+windows 'unc-path))
  37
  38 (defconstant +directory-delimiter+
  39   #+unix #\/ #+windows #\\)
  40
  41 (defconstant +alternative-delimiter+
  42   #+unix nil #+windows #\/)
  43
  44 (defconstant (+split-directories-regex+ :test 'equal)
  45   (if +alternative-delimiter+
  46       (format nil "(~C|~C)" +directory-delimiter+ +alternative-delimiter+)
  47       +directory-delimiter+))
  48
  49 (defconstant (+absolute-directory-regex+ :test 'equal)
  50   (format nil "^~C" +split-directories-regex+))
  51
  52 (defconstant +execution-path-delimiter+
  53   #+unix #\: #+windows #\;)
  54
  55 (declaim (special *default-file-path-defaults*))
  56 \f
  57
  58 ;;;-------------------------------------------------------------------------
  59 ;;; Generic Functions
  60 ;;;-------------------------------------------------------------------------
  61
  62 ;;; Accessors
  63
  64 (defgeneric file-path-host (path))
  65
  66 (defgeneric file-path-device (path))
  67
  68 (defgeneric file-path-directory (path &key namestring))
  69
  70 (defgeneric file-path-name (path))
  71
  72 (defgeneric file-path-namestring (path))
  73
  74 ;;; Operations
  75
  76 (defgeneric make-file-path (&key host device directory name defaults type))
  77
  78 (defgeneric merge-file-paths (path &optional defaults))
  79
  80 (defgeneric enough-file-path (path &optional defaults))
  81
  82 (defgeneric concatenate-paths (&rest paths))
  83
  84 (defgeneric parse-file-path-type (namestring type &key start end
  85                                   as-directory expand-user))
  86
  87 (defgeneric parse-file-path (namestring &key start end
  88                              as-directory expand-user))
  89
  90 (defgeneric file-path (pathspec))
  91
  92 (defgeneric expand-user-directory (path))
  93
  94 ;;; Internal functions
  95
  96 (defgeneric %file-path-directory-namestring (path &key trailing-delimiter))
  97
  98 (defgeneric %expand-user-directory (pathspec))
  99 \f
 100
 101 ;;;-------------------------------------------------------------------------
 102 ;;; Accessors
 103 ;;;-------------------------------------------------------------------------
 104
 105 (defmethod file-path-host ((path file-path))
 106   (slot-value path 'host))
 107
 108 (defmethod file-path-device ((path file-path))
 109   (slot-value path 'device))
 110
 111 (defmethod file-path-directory ((path file-path) &key namestring)
 112   (if namestring
 113       (%file-path-directory-namestring path)
 114       (slot-value path 'directory)))
 115
 116 (defmethod file-path-name ((path file-path))
 117   (slot-value path 'name))
 118 \f
 119
 120 ;;;-------------------------------------------------------------------------
 121 ;;; Constructors
 122 ;;;-------------------------------------------------------------------------
 123
 124 (defun directory-name-p (name)
 125   (and (stringp name) (not (ppcre:scan +split-directories-regex+ name))))
 126
 127 (defun file-path-directory-p (directory)
 128   (and (consp directory)
 129        (member (car directory) '(:absolute :relative))
 130        (every #'directory-name-p (cdr directory))))
 131
 132 (defmethod initialize-instance :after ((path file-path) &key directory name)
 133   (check-type directory (or null (eql :unspecific)
 134                             (satisfies file-path-directory-p)))
 135   (check-type name (or null (eql :unspecific) string)))
 136 \f
 137
 138 ;;;-------------------------------------------------------------------------
 139 ;;; Predicates
 140 ;;;-------------------------------------------------------------------------
 141
 142 (defun file-path-p (thing)
 143   (typep thing 'file-path))
 144
 145 (defun file-path-absolute-p (thing)
 146   (and (file-path-p thing)
 147        (eql :absolute (car (file-path-directory thing)))))
 148
 149 (defun file-path-relative-p (thing)
 150   (and (file-path-p thing)
 151        (eql :relative (car (file-path-directory thing)))))
 152 \f
 153
 154 ;;;-------------------------------------------------------------------------
 155 ;;; Operations
 156 ;;;-------------------------------------------------------------------------
 157
 158 (defmethod make-file-path (&key (type '#.+file-path-host-type+)
 159                            host device directory name defaults)
 160   (check-type defaults (or null file-path))
 161   (make-instance type
 162                  :host (or host
 163                            (if defaults
 164                                (file-path-host defaults)
 165                                (file-path-host *default-file-path-defaults*)))
 166                  :device (or device
 167                              (and defaults (file-path-device defaults)))
 168                  :directory (or directory
 169                                 (and defaults (file-path-directory defaults)))
 170                  :name (or name
 171                            (and defaults (file-path-name defaults)))))
 172
 173 (defmethod merge-file-paths ((path file-path) &optional
 174                              (defaults *default-file-path-defaults*))
 175   (check-type defaults file-path)
 176   (make-instance (class-of path)
 177                  :host (or (file-path-host path)
 178                            (file-path-host defaults))
 179                  :device (or (file-path-device path)
 180                              (file-path-device defaults))
 181                  :directory (or (let ((dir (file-path-directory path)))
 182                                   (when (and dir (eql :relative (car dir))
 183                                              (listp (file-path-directory defaults)))
 184                                     (append dir (file-path-directory defaults))))
 185                                 (file-path-directory defaults))
 186                  :name (or (file-path-name path)
 187                            (file-path-name defaults))))
 188
 189 (defmethod concatenate-paths (&rest paths)
 190   (assert (every #'file-path-p paths))
 191   (when (null paths) (return* nil))
 192   (let ((as-directory
 193          (not (stringp (file-path-name (lastcar paths)))))
 194         (big-namestring
 195          (apply #'join (file-path-directory-delimiter (car paths))
 196                 (mapcar #'file-path-namestring paths))))
 197     (parse-file-path-type big-namestring (type-of (car paths))
 198                           :as-directory as-directory)))
 199
 200 (defun split-directory-namestring (namestring &optional limit)
 201   (remove "" (ppcre:split +split-directories-regex+ namestring
 202                           :limit limit)
 203           :test #'string=))
 204
 205 (defmethod parse-file-path (namestring &key (start 0) end
 206                             as-directory expand-user)
 207   (parse-file-path-type namestring +file-path-host-type+
 208                         :start start :end end
 209                         :as-directory as-directory
 210                         :expand-user expand-user))
 211
 212 (defmethod file-path ((pathspec file-path))
 213   pathspec)
 214
 215 (defmethod file-path ((pathspec string))
 216   (parse-file-path pathspec))
 217 \f
 218
 219 ;;;-------------------------------------------------------------------------
 220 ;;; PRINT-OBJECT
 221 ;;;-------------------------------------------------------------------------
 222
 223 (defmethod print-object ((path file-path) stream)
 224   (print-unreadable-object (path stream :type t)
 225     (format stream "~S" (file-path-namestring path))))