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 parse-file-path-type (namestring type &key start end
  83                                   as-directory expand-user))
  84
  85 (defgeneric parse-file-path (namestring &key start end
  86                              as-directory expand-user))
  87
  88 (defgeneric file-path (pathspec))
  89
  90 ;;; Internal functions
  91
  92 (defgeneric %file-path-directory-namestring (path &key trailing-delimiter))
  93
  94 (defgeneric expand-userdir (dirname))
  95 \f
  96
  97 ;;;-------------------------------------------------------------------------
  98 ;;; Accessors
  99 ;;;-------------------------------------------------------------------------
 100
 101 (defmethod file-path-host ((path file-path))
 102   (slot-value path 'host))
 103
 104 (defmethod file-path-device ((path file-path))
 105   (slot-value path 'device))
 106
 107 (defmethod file-path-directory ((path file-path) &key namestring)
 108   (if namestring
 109       (%file-path-directory-namestring path)
 110       (slot-value path 'directory)))
 111
 112 (defmethod file-path-name ((path file-path))
 113   (slot-value path 'name))
 114 \f
 115
 116 ;;;-------------------------------------------------------------------------
 117 ;;; Constructors
 118 ;;;-------------------------------------------------------------------------
 119
 120 (defun directory-name-p (name)
 121   (and (stringp name) (not (ppcre:scan +split-directories-regex+ name))))
 122
 123 (defun file-path-directory-p (directory)
 124   (and (consp directory)
 125        (member (car directory) '(:absolute :relative))
 126        (every #'directory-name-p (cdr directory))))
 127
 128 (defmethod initialize-instance :after ((path file-path) &key directory name)
 129   (check-type directory (or null (eql :unspecific)
 130                             (satisfies file-path-directory-p)))
 131   (check-type name (or null (eql :unspecific) string)))
 132 \f
 133
 134 ;;;-------------------------------------------------------------------------
 135 ;;; Predicates
 136 ;;;-------------------------------------------------------------------------
 137
 138 (defun file-path-p (thing)
 139   (typep thing 'file-path))
 140
 141 (defun file-path-absolute-p (thing)
 142   (and (file-path-p thing)
 143        (eql :absolute (car (file-path-directory thing)))))
 144
 145 (defun file-path-relative-p (thing)
 146   (and (file-path-p thing)
 147        (eql :relative (car (file-path-directory thing)))))
 148 \f
 149
 150 ;;;-------------------------------------------------------------------------
 151 ;;; Operations
 152 ;;;-------------------------------------------------------------------------
 153
 154 (defmethod make-file-path (&key (type '#.+file-path-host-type+)
 155                            host device directory name defaults)
 156   (check-type defaults (or null file-path))
 157   (make-instance type
 158                  :host (or host
 159                            (if defaults
 160                                (file-path-host defaults)
 161                                (file-path-host *default-file-path-defaults*)))
 162                  :device (or device
 163                              (and defaults (file-path-device defaults)))
 164                  :directory (or directory
 165                                 (and defaults (file-path-directory defaults)))
 166                  :name (or name
 167                            (and defaults (file-path-name defaults)))))
 168
 169 (defmethod merge-file-paths ((path file-path) &optional
 170                              (defaults *default-file-path-defaults*))
 171   (check-type defaults file-path)
 172   (make-instance (class-of path)
 173                  :host (or (file-path-host path)
 174                            (file-path-host defaults))
 175                  :device (or (file-path-device path)
 176                              (file-path-device defaults))
 177                  :directory (or (let ((dir (file-path-directory path)))
 178                                   (when (and dir (eql :relative (car dir))
 179                                              (listp (file-path-directory defaults)))
 180                                     (append dir (file-path-directory defaults))))
 181                                 (file-path-directory defaults))
 182                  :name (or (file-path-name path)
 183                            (file-path-name defaults))))
 184
 185 (defun split-directory-namestring (namestring &optional limit)
 186   (remove "" (ppcre:split +split-directories-regex+ namestring
 187                           :limit limit)
 188           :test #'string=))
 189
 190 (defmethod parse-file-path (namestring &key (start 0) end
 191                             as-directory expand-user)
 192   (parse-file-path-type namestring +file-path-host-type+
 193                         :start start :end end
 194                         :as-directory as-directory
 195                         :expand-user expand-user))
 196
 197 (defmethod file-path ((pathspec file-path))
 198   pathspec)
 199
 200 (defmethod file-path ((pathspec string))
 201   (parse-file-path pathspec))
 202 \f
 203
 204 ;;;-------------------------------------------------------------------------
 205 ;;; PRINT-OBJECT
 206 ;;;-------------------------------------------------------------------------
 207
 208 (defmethod print-object ((path file-path) stream)
 209   (print-unreadable-object (path stream :type t)
 210     (format stream "~S" (file-path-namestring path))))