-
Notifications
You must be signed in to change notification settings - Fork 5
/
pathname-helpers.lisp
190 lines (173 loc) · 7.81 KB
/
pathname-helpers.lisp
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
;;;; SPDX-FileCopyrightText: Atlas Engineer LLC
;;;; SPDX-License-Identifier: BSD-3-Clause
(uiop:define-package nfiles/pathname
(:use #:common-lisp)
(:import-from #:nclasses
#:define-class)
(:import-from #:serapeum
#:export-always
#:->)
(:import-from #:trivial-types
#:pathname-designator)
(:documentation "Some `cl:pathname' helpers."))
(in-package :nfiles/pathname)
(serapeum:eval-always
(trivial-package-local-nicknames:add-package-local-nickname :alex :alexandria)
(trivial-package-local-nicknames:add-package-local-nickname :sera :serapeum))
;; TODO: Make methods that take both pathnames and nfiles?
;; TODO: Define own `path-designator' type?
(export-always 'nil-pathname-p)
(-> nil-pathname-p ((or null pathname-designator)) boolean)
(defun nil-pathname-p (pathname)
"Return non-nil if PATHNAME is `uiop:*nil-pathname*' or nil."
(the (values boolean &optional)
(or (null pathname)
(uiop:pathname-equal pathname uiop:*nil-pathname*))))
(export-always 'pathname-type*)
(defun pathname-type* (pathname)
"Like `pathname-type' but return NIL instead of \"\" or :UNSPECIFIC."
(let ((type (pathname-type pathname)))
(if (member type '(nil "" :unspecific) :test 'equal)
nil
type)))
(export-always 'directory-pathname-p)
(defun directory-pathname-p (pathname)
"Like `uiop:directory-pathname-p' but also return T if `pathname-name' is \".\"
and check for existence."
(or (uiop:directory-pathname-p pathname)
(string= "." (pathname-name pathname))
(uiop:directory-exists-p pathname)))
(export-always 'parent)
(-> parent (pathname-designator) (or pathname-designator null))
(defun parent (path)
"Return the parent directory of PATH."
(let ((path (uiop:ensure-pathname path)))
(the (values (or pathname null) &optional)
(if (uiop:directory-pathname-p path)
(uiop:pathname-parent-directory-pathname path)
(uiop:pathname-directory-pathname path)))))
(export-always 'basename)
(-> basename (pathname-designator) (or pathname-designator null))
(defun basename (pathname)
"Return the basename, that is:
- if it's a directory, the name of the directory,
- if it's a file, the name of the file including its type (extension),
- nil if it's a nil-pathname (#p\"\")."
(if (nil-pathname-p pathname)
nil ; TODO: Shouldn't we return #p"" instead?
(first (last (pathname-directory
;; Ensure directory _after_ truenamizing, otherwise if
;; non-directory file exists it may not yield a directory.
(uiop:ensure-directory-pathname
(uiop:ensure-pathname pathname :truenamize t)))))))
(defun special-pathname-namestring-p (pathname-namestring)
"Return non-nil if pathname is special like \".\" or \"..\".
Note that this returns nil on #p\".\" and #p\"..\"."
(and (stringp pathname-namestring)
(member (namestring pathname-namestring) '("." "..") :test 'string=)))
(export-always 'join)
(-> join (&rest pathname-designator) (or pathname-designator null))
(defun join (&rest paths)
"Concatenate PATHS."
(if (< (length paths) 2)
(the (values pathname &optional)
(uiop:ensure-pathname (first paths)))
(apply #'join
(let ((path1 (first paths))
(path2 (second paths)))
(if (or (null (pathname-name path1))
(pathname-directory path2))
(uiop:merge-pathnames* (uiop:relativize-pathname-directory (uiop:ensure-pathname path2))
(uiop:ensure-pathname path1
:ensure-directory t))
(let ((new-base (uiop:strcat (basename path1)
(if (special-pathname-namestring-p path2)
path2
(basename path2)))))
(make-pathname :defaults path1 :type (pathname-type new-base)
:name (pathname-name new-base)))))
(cddr paths))))
(export-always 'ensure-type)
(-> ensure-type (pathname-designator string) pathname-designator)
(defun ensure-type (path type)
"Return PATH with type set to TYPE, if it's not already the case.
Case is ignored."
(if (string-equal type (pathname-type path))
path
(the (values pathname &optional) (join path (uiop:strcat "." type)))))
(alex:define-constant +permissions+
'((:user-read . 256) (:user-write . 128) (:user-exec . 64) (:group-read . 32)
(:group-write . 16) (:group-exec . 8) (:other-read . 4) (:other-write . 2)
(:other-exec . 1) (:set-user-id . 2048) (:set-group-id . 1024) (:sticky . 512))
:test #'equal)
(export-always 'permissions)
(defun permissions (path)
"Return a list of permissions as per `+permissions+'."
#+(and sbcl (not android))
(let ((mode (sb-posix:stat-mode
(sb-posix:lstat path))))
(loop :for (name . value) :in +permissions+
:when (plusp (logand mode value))
:collect name))
#-(and sbcl (not android))
(iolib/os:file-permissions (uiop:native-namestring path)))
(defun (setf permissions) (permissions path)
"Set the PERMISSIONS or PATH as per `+permissions+'."
#+(and sbcl (not android))
(sb-posix:chmod path
(reduce (lambda (a b)
(logior a (rest (assoc b +permissions+))))
permissions :initial-value 0))
#-(and sbcl (not android))
(setf (iolib/os:file-permissions (uiop:native-namestring path)) permissions))
(export-always 'file-user)
(defun file-user (path)
"Return PATH owner name."
;; `file-author' seems broken on many implementations.
#+(or ccl (and sbcl (not android)))
(file-author path)
#-(or ccl (and sbcl (not android)))
(iolib/syscalls:getpwuid (iolib/syscalls:stat-uid
(iolib/syscalls:lstat
(uiop:native-namestring path)))))
(defun (setf file-user) (new-user path)
"Set PATH owner to NEW-USER (a string)."
#+(and sbcl (not android))
(sb-posix:chown path
(sb-posix:passwd-uid (sb-posix:getpwnam new-user))
(sb-posix:stat-gid (sb-posix:lstat path)))
#-(and sbcl (not android))
(let ((native-path (uiop:native-namestring path))
(uid (nth-value 2 (iolib/syscalls:getpwnam new-user))))
(if uid
(iolib/syscalls:chown native-path
uid
(iolib/syscalls:stat-gid (iolib/syscalls:lstat
native-path)))
(error "User ~a does not exist" new-user))))
(export-always 'file-group)
(defun file-group (path)
"Return PATH group name."
#+(and sbcl (not android))
(sb-posix:group-name
(sb-posix:getgrgid (sb-posix:stat-gid
(sb-posix:lstat path))))
#-(and sbcl (not android))
(iolib/syscalls:getgrgid (iolib/syscalls:stat-gid
(iolib/syscalls:lstat
(uiop:native-namestring path)))))
(defun (setf file-group) (new-group path)
"Set PATH group to NEW-GROUP (a string)."
#+(and sbcl (not android))
(sb-posix:chown path
(sb-posix:stat-uid (sb-posix:lstat path))
(sb-posix:group-gid (sb-posix:getgrnam new-group)))
#-(and sbcl (not android))
(let ((native-path (uiop:native-namestring path))
(gid (nth-value 2 (iolib/syscalls:getgrnam new-group))))
(if gid
(iolib/syscalls:chown native-path
(iolib/syscalls:stat-uid (iolib/syscalls:lstat
native-path))
gid)
(error "Group ~s does not exist" new-group))))