tilde.lisp

   1 ;;;; tilde.lisp
   2 ;;;;
   3 ;;;; To use, add this to your ~/.sbclrc:
   4 ;;;;
   5 ;;;;  (load "/path/to/tilde.lisp")
   6 ;;;;  (tilde:install-tilde-expander)
   7 ;;;;
   8 ;;;; After that, (equal (probe-file "~/") (user-homedir-pathname)) =>
   9 ;;;; T, for example.
  10 ;;;;
  11
  12 (require 'sb-posix)
  13
  14 (defpackage #:tilde
  15   (:use #:cl)
  16   (:export #:expand-tilde-namestring
  17            #:install-tilde-expander
  18            #:uninstall-tilde-expander
  19            #:no-such-user))
  20
  21 (in-package #:tilde)
  22
  23 (defparameter *desktop-directory-namestring* "Desktop/")
  24
  25 (proclaim '(ftype (function (t) t) username))
  26
  27 (define-condition no-such-user (error)
  28   ((username
  29     :initarg :username
  30     :reader username))
  31   (:report (lambda (condition stream)
  32              (format stream "No such user ~S" (username condition)))))
  33
  34 (defun posix-passwd (username-designator)
  35   (declare (sb-ext:muffle-conditions sb-ext:compiler-note))
  36   (etypecase username-designator
  37     (null
  38      (sb-posix:getpwuid (sb-posix:getuid)))
  39     (string
  40      (sb-posix:getpwnam username-designator))))
  41
  42 (defun posix-home-directory (username)
  43   (let ((passwd (posix-passwd username)))
  44     (if passwd
  45         (concatenate 'string (sb-posix:passwd-dir passwd) "/")
  46         (error 'no-such-user :username username))))
  47
  48 (defun home-directory-namestring (username)
  49   (posix-home-directory username))
  50
  51 (defun desktop-directory-namestring (username)
  52   (concatenate 'string (home-directory-namestring username)
  53                *desktop-directory-namestring*))
  54
  55 (defun tilde-namestring-parts (string &key (start 0) (end (length string)))
  56   "Return multiple values: username, suffix, desktopp."
  57   (assert (char= (char string start) #\~))
  58   (let ((pos (1+ start))
  59         (suffix "")
  60         username-start
  61         suffix-start
  62         username
  63         desktopp
  64         state)
  65     (labels ((finish ()
  66                (values username suffix desktopp))
  67              (maybe-desktop (char)
  68                (case char
  69                  (#\~
  70                   (setf desktopp t)
  71                   #'maybe-username)
  72                  (:end
  73                   (finish))
  74                  (t
  75                   (maybe-username char))))
  76              (maybe-username (char)
  77                (case char
  78                  (#\/
  79                   (setf suffix-start pos)
  80                   #'more-suffix)
  81                  (:end
  82                   (finish))
  83                  (t
  84                   (setf username-start pos)
  85                   #'more-username)))
  86              (more-suffix (char)
  87                (case char
  88                  (:end
  89                   (setf suffix (subseq string (1+ suffix-start) pos))
  90                   (finish))
  91                  (t
  92                   #'more-suffix)))
  93              (more-username (char)
  94                (case char
  95                  (#\/
  96                   (setf suffix-start pos)
  97                   (setf username (subseq string username-start pos))
  98                   #'more-suffix)
  99                  (:end
 100                   (setf username (subseq string username-start pos))
 101                   (finish))
 102                  (t
 103                   #'more-username))))
 104       (setf state #'maybe-desktop)
 105       (loop
 106        (when (= pos end)
 107          (return (funcall state :end)))
 108        (setf state (funcall state (char string pos)))
 109        (incf pos)))))
 110
 111
 112 (defun expand-tilde-namestring (string &key (start 0) end)
 113   "If STRING starts with a tilde \(~), returns an expanded
 114   namestring. Namestrings are expanded like so:
 115
 116     ~              expands to the home directory for the current user
 117     ~<username>    expands to the home directory for <username>
 118     ~~             expands to the desktop directory for the current user
 119     ~~<username>   expands to the desktop directory for <username>
 120
 121   If a username is not found, an error of type NO-SUCH-USER is raised."
 122   (setf end (or end (length string)))
 123   (if (and (plusp (length string))
 124            (char= (char string start) #\~))
 125       (multiple-value-bind (username suffix desktopp)
 126           (tilde-namestring-parts string :start start :end end)
 127         (let ((base (if desktopp
 128                         (desktop-directory-namestring username)
 129                         (home-directory-namestring username))))
 130           (concatenate 'string base suffix)))
 131       string))
 132
 133 (defun error-not-installed (&rest rest)
 134   (declare (ignore rest))
 135   (error "Not installed"))
 136
 137 (defvar *old-parse-namestring* 'error-not-installed)
 138
 139 (locally
 140     (declare (sb-ext:muffle-conditions style-warning))
 141   (defun new-parse-namestring (thing
 142                                &optional
 143                                host
 144                                (defaults *default-pathname-defaults*)
 145                                &key (start 0) end junk-allowed)
 146     (when (stringp thing)
 147       (setf thing (expand-tilde-namestring thing)))
 148     (funcall *old-parse-namestring* thing host defaults
 149              :start start
 150              :end end
 151              :junk-allowed junk-allowed)))
 152
 153 (defun install-tilde-expander ()
 154   (when (eql *old-parse-namestring* 'error-not-installed)
 155     (setf *old-parse-namestring* #'sb-impl::parse-namestring)
 156     (sb-ext:without-package-locks
 157       (setf (fdefinition 'sb-impl::parse-namestring) #'new-parse-namestring))
 158     t))
 159
 160 (defun uninstall-tilde-expander ()
 161   (unless (eql *old-parse-namestring* 'error-not-installed)
 162     (sb-ext:without-package-locks
 163       (setf (fdefinition 'sb-impl::parse-namestring) *old-parse-namestring*))
 164     t))