Coverage report: /home/ellis/comp/core/std/path.lisp

KindCoveredAll%
expression63152 41.4
branch718 38.9
Key
Not instrumented
Conditionalized out
Executed
Not executed
 
Both branches taken
One branch taken
Neither branch taken
1
 ;;; std/path.lisp --- Standard Path Library
2
 
3
 ;; Pathname support
4
 
5
 ;;; Commentary:
6
 
7
 
8
 ;;; Code:
9
 (in-package :std/path)
10
 
11
 (defgeneric path (self)
12
   (:method ((self string))
13
     (pathname self))
14
   (:documentation "Return the path associated with SELF."))
15
 
16
 (defun symlinkp (path)
17
   "Return T if PATH is a symlink."
18
   (sb-posix:s-islnk (sb-posix:stat-mode (sb-posix:lstat path))))
19
 
20
 (deftype wild-pathname ()
21
   "A pathname with wild components."
22
   '(and pathname (satisfies wild-pathname-p)))
23
 
24
 (deftype non-wild-pathname ()
25
   "A pathname without wild components."
26
   '(or directory-pathname
27
     (and pathname (not (satisfies wild-pathname-p)))))
28
 
29
 (deftype absolute-pathname ()
30
   "An absolute pathname."
31
   '(and pathname (satisfies uiop:absolute-pathname-p)))
32
 
33
 (deftype relative-pathname ()
34
   "A relative pathname."
35
   '(and pathname (satisfies uiop:relative-pathname-p)))
36
 
37
 (deftype directory-pathname ()
38
   "A directory pathname."
39
   '(and pathname (satisfies uiop:directory-pathname-p)))
40
 
41
 (deftype symlink-pathname ()
42
   "A symlink pathname."
43
   '(and pathname (satisfies symlinkp)))
44
 
45
 (deftype absolute-directory-pathname ()
46
   "An absolute directory pathname."
47
   '(and absolute-pathname directory-pathname))
48
 
49
 (deftype file-pathname ()
50
   "A file pathname."
51
   '(and pathname (satisfies uiop:file-pathname-p)))
52
 
53
 (defconstant +pathsep+
54
   #+windows #\; #+unix #\:
55
   "Path separator for this OS.")
56
 
57
 (defconstant +wildfile+ (make-pathname :name :wild :type :wild :version :wild)
58
   "Constant wild file pathname specifier.")
59
 
60
 (defun directory-path-p (path)
61
   "Return T if PATH is a directory else NIL."
62
   (declare (type (or pathname string) path))
63
   (and (not (pathname-name path))
64
        (not (pathname-type path))))
65
 
66
 (defun directory-path (path)
67
   "If PATH is a directory pathname, return it as it is. If it is a file
68
 pathname or a string, transform it into a directory pathname."
69
   (declare (type (or pathname string) path))
70
   (if (directory-path-p path)
71
       path
72
       (make-pathname :directory (append (or (pathname-directory path)
73
                                             (list :relative))
74
                                         (list (file-namestring path)))
75
                      :name nil :type nil :defaults path)))
76
 
77
 (defun merge-homedir-pathnames (pathname &optional (default-version :newest))
78
   "Merge PATHNAME on USER-HOMEDIR-PATHNAME."
79
   (merge-pathnames pathname (user-homedir-pathname) default-version))
80
 
81
 (defun ensure-directory-truename (path &key verbose (mode 511))
82
   "Ensure directory PATH exists and return its truename."
83
   (truename (ensure-directories-exist (directory-path path) :verbose verbose :mode mode)))
84
 
85
 ;; from UIOP
86
 (defun set-pathname-suffix (path suffix &rest keys)
87
   "Return a pathname like PATH with a custom SUFFIX."
88
   (apply 'make-pathname :name (concatenate 'string (pathname-name path) suffix)
89
                         :defaults path keys))
90
 
91
 (defvar *tmp-suffix* "-tmp" "Default suffix for TMPIZE-PATHNAME")
92
 (defvar *tmp* #P"/tmp/" "Default temporary directory pathname.")
93
 
94
 ;; from UIOP
95
 (defun tmpize-pathname (path)
96
   "Return a new pathname based on PATH and *TMP-SUFFIX* with a gensym'd integer
97
 appended."
98
   (set-pathname-suffix path (symbol-name
99
                              (gensym *tmp-suffix*))))
100
 
101
 (defun call-with-directory (dir thunk)
102
   "call the THUNK in a context where the current directory was changed to DIR, if not NIL.
103
 Note that this operation is usually NOT thread-safe."
104
   (if dir
105
       (let* ((dir (directory-path (probe-file dir)))
106
              (cwd (sb-posix:getcwd))
107
              (*default-pathname-defaults* dir))
108
         (sb-posix:chdir dir)
109
         (unwind-protect
110
              (funcall thunk)
111
           (sb-posix:chdir cwd)))
112
       (funcall thunk)))
113
 
114
 (defmacro with-directory (dir &body body)
115
   "Call BODY while the POSIX current working directory is set to DIR"
116
   `(call-with-directory ,dir #'(lambda () ,@body)))
117
 
118
 (defmacro with-tmp (&body body)
119
   "Bind *DEFAULT-PATHNAME-DEFAULTS* to *TMP* around BODY."
120
   `(with-directory *tmp*
121
      ,@body))
122
 
123
 ;;; Walkers
124
 ;; From UIOP:COLLECT-SUB*DIRECTORIES
125
 (defun walk-directory (directory collectp recursep collector)
126
   "Given a DIRECTORY, when COLLECTP returns true,
127
 call the COLLECTOR function designator with the directory and recurse each of
128
 its subdirectories on which RECURSEP returns true.
129
 
130
 COLLECTP, RECURSEP, and COLLECT all take a single pathname (the directory) as
131
 their only argument."
132
   (when (funcall collectp directory)
133
     (funcall collector directory)
134
     (dolist (subdir (subdirectories directory))
135
       (when (funcall recursep subdir)
136
         (walk-directory subdir collectp recursep collector)))))
137
 
138
 (defun directory-empty-p (&optional (dir *default-pathname-defaults*))
139
   "Return non-nil if DIR is a DIRECTORY-PATHNAME which does not contain any files
140
 or directories."
141
   (and (directory-path-p dir) (not (directory (merge-pathnames "*" dir)))))
142
 
143
 ;; from StumpWM 
144
 ;; ref: stumpwm/pathnames.lisp
145
 (defun directory-wildcard (dirname)
146
   "Returns a wild pathname designator that designates all files within
147
 the directory named by the non-wild pathname designator DIRNAME."
148
   (when (wild-pathname-p dirname)
149
     (error "Can only make wildcard directories from non-wildcard directories."))
150
   (make-pathname :name :wild
151
                  :type :wild
152
                  :defaults (directory-path dirname)))