pathnames/file-path-unix.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 unix-path (file-path)
  13   ((directory-delimiter
  14     :initform #\/)
  15    (alternative-delimiter
  16     :initform nil)
  17    (execution-path-delimiter
  18     :initform #\:))
  19   (:default-initargs :host :unspecific
  20                      :device :unspecific))
  21 \f
  22
  23 ;;;-------------------------------------------------------------------------
  24 ;;; Predicates
  25 ;;;-------------------------------------------------------------------------
  26
  27 (defun unix-path-p (thing)
  28   (typep thing 'unix-path))
  29
  30 (defun absolute-namestring-p (namestring)
  31   (not (null (ppcre:scan +absolute-directory-regex+ namestring))))
  32 \f
  33
  34 ;;;-------------------------------------------------------------------------
  35 ;;; Operations
  36 ;;;-------------------------------------------------------------------------
  37
  38 (defmethod enough-file-path ((path unix-path) &optional
  39                              (defaults *default-file-path-defaults*))
  40   (cond
  41     ((or (file-path-relative-p path)
  42          (file-path-relative-p defaults))
  43      path)
  44     (t
  45      (multiple-value-bind (dirtype enough-directory)
  46          (if (equal (cadr (file-path-directory path))
  47                     (cadr (file-path-directory defaults)))
  48              (values :relative
  49                      (loop :for rest1 :on (cddr (file-path-directory path))
  50                            :for rest2 :on (cddr (file-path-directory defaults))
  51                            :if (not (equal (car rest1) (car rest2))) :do (loop-finish)
  52                            :finally (return rest1)))
  53              (values :absolute (cdr (file-path-directory path))))
  54        (make-instance 'unix-path :directory (list* dirtype enough-directory)
  55                       :name (file-path-name path))))))
  56
  57 (defmethod file-path-namestring ((path unix-path))
  58   (with-slots (directory name)
  59       path
  60     (with-output-to-string (stream)
  61       (princ (%file-path-directory-namestring path :trailing-delimiter t)
  62              stream)
  63       (when (stringp name)
  64         (princ name stream)))))
  65
  66 (defmethod %file-path-directory-namestring ((path unix-path) &key trailing-delimiter)
  67   (with-slots (directory)
  68       path
  69     (with-output-to-string (stream)
  70       (when (consp directory)
  71         (destructuring-bind (directory-type &rest dirs)
  72             directory
  73           (ecase directory-type
  74             (nil t)   ; no directory
  75             (:absolute
  76              (princ (file-path-directory-delimiter path) stream))
  77             (:relative t))
  78           (princ (apply #'join (file-path-directory-delimiter path)
  79                         (if trailing-delimiter (append dirs (list "")) dirs))
  80                  stream))))))
  81
  82 (defun split-directory-namestring (namestring &optional limit)
  83   (remove "" (ppcre:split +split-directories-regex+ namestring
  84                           :limit limit)
  85           :test #'string=))
  86
  87 (defmethod parse-file-path-type ((namestring string)
  88                                  (type (eql 'unix-path))
  89                                  &key (start 0) end
  90                                  as-directory expand-user)
  91   (let* ((actual-namestring (subseq namestring start end))
  92          (expansion (or (when expand-user
  93                           (ignore-some-conditions (isys:syscall-error)
  94                             (%expand-user-directory actual-namestring)))
  95                         actual-namestring))
  96          (components (remove "." (split-directory-namestring expansion)
  97                              :test #'string=))
  98          (dirname (if as-directory components (butlast components)))
  99          (basename (if as-directory nil (lastcar components)))
 100          (directory-type (if (absolute-namestring-p expansion)
 101                              :absolute
 102                              :relative)))
 103     (make-instance type :directory (cons directory-type dirname)
 104                    :name (if (string= "" basename) nil basename))))
 105
 106 (defmethod %expand-user-directory ((pathspec string))
 107   (flet ((user-homedir (user)
 108            (nth-value 5 (isys:%sys-getpwnam user)))
 109          (uid-homedir (uid)
 110            (nth-value 5 (isys:%sys-getpwuid uid)))
 111          (concat-homedir (dir rest)
 112            (join +directory-delimiter+ dir rest)))
 113     (destructuring-bind (first &optional rest)
 114         (split-directory-namestring pathspec 2)
 115       (cond
 116         ((string= "~" first)
 117          (let ((homedir
 118                 (or (isys:%sys-getenv "HOME")
 119                     (let ((username
 120                            (or (isys:%sys-getenv "USER")
 121                                (isys:%sys-getenv "LOGIN"))))
 122                       (and username
 123                            (user-homedir username)
 124                            (uid-homedir (isys:%sys-getuid)))))))
 125            (return* (concat-homedir homedir rest))))
 126         ((char= #\~ (char first 0))
 127          (let ((homedir
 128                 (and (user-homedir (subseq first 1))
 129                      first)))
 130            (return* (concat-homedir homedir rest))))
 131         (t
 132          pathspec)))))
 133
 134 (defmethod expand-user-directory ((path unix-path))
 135   (with-slots (directory)
 136       path
 137     (assert (and (consp directory)
 138                  (eql :relative (first directory))
 139                  (stringp (second directory))))
 140     (let ((dirs (split-directory-namestring
 141                  (handler-case
 142                      (%expand-user-directory (second directory))
 143                    (isys:syscall-error () (return* path))))))
 144       (setf directory
 145             (append (list :absolute) dirs (cddr directory)))))
 146   (values path))
 147 \f
 148
 149 ;;;-------------------------------------------------------------------------
 150 ;;; Specials
 151 ;;;-------------------------------------------------------------------------
 152
 153 (defparameter *default-file-path-defaults*
 154   (or (ignore-some-conditions (isys:syscall-error)
 155         (parse-file-path (isys:%sys-getcwd) :as-directory t))
 156       (ignore-some-conditions (isys:syscall-error)
 157         (parse-file-path (%expand-user-directory "~") :as-directory t))
 158       (parse-file-path "/")))
 159
 160 (defparameter *default-execution-path*
 161   (mapcar (lambda (p)
 162             (parse-file-path p :as-directory t))
 163           (split-sequence +execution-path-delimiter+ (isys:%sys-getenv "PATH")
 164                           :remove-empty-subseqs t)))