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

Kind	Covered	All	%
expression	9	461	2.0
branch	0	22	0.0

Key

Not instrumented

Conditionalized out

Executed

Not executed

Both branches taken

One branch taken

Neither branch taken

1

;;; std/os.lisp --- OS interop

2

3

;; OS-specific bits.

4

5

;;; Commentary:

6

7

;; Unix only.

8

9

;;; Code:

10

(in-package :std/os)

11

(require 'sb-posix)

12

13

(defparameter *user* (sb-posix:getenv "USER")

14

"The name of the currently logged-in user.")

15

16

(defun sudo-p ()

17

"Return T if effective user is root."

18

   (zerop (parse-integer (with-output-to-string (str) (sb-ext:process-output (sb-ext:run-program "id" (list "-u") :search t :output str)) 0))))

19

20

(defun user-info (&optional (id (sb-posix:getuid)))

21

"USER-INFO returns the password entry for the given name or

22

numerical user ID, as an assoc-list."

23

(multiple-value-bind (name password uid gid gecos home shell)

24

(etypecase id

25

(string (sb-posix:getpwnam id))

26

(integer (sb-posix:getpwuid id)))

27

(declare (ignore password))

28

(unless (null name)

29

(list (cons :name name)

30

(cons :user-id uid)

31

(cons :group-id gid)

32

(cons :gecos gecos)

33

(cons :home home)

34

(cons :shell shell)))))

35

36

(defun list-all-users ()

37

"List all users via passwd. (uid gid name home shell comment)"

38

(let ((r nil))

39

(sb-posix:do-passwds (u r)

40

(push (list (sb-posix:passwd-uid u)

41

(sb-posix:passwd-gid u)

42

(sb-posix:passwd-name u)

43

(sb-posix:passwd-dir u)

44

(sb-posix:passwd-shell u)

45

(sb-posix:passwd-gecos u))

46

r))

47

r))

48

49

(defun list-all-groups ()

50

"List all groups. (gid name mem)"

51

(let ((r nil))

52

(sb-posix:do-groups (g r) (push (list (sb-posix:group-gid g)

53

(sb-posix:group-name g)

54

(sb-posix:group-mem g))

55

r))))

56

57

;; cat /sys/kernel/cpu_byteorder?

58

59

(defmacro with-umask (mask &body body)

60

"Temporarily set the system-wide umask for the extent of BODY."

61

(with-gensyms (umask)

62

`(let ((,umask (sb-posix:umask ,mask)))

63

(unwind-protect (progn ,@body)

64

(sb-posix:umask ,umask)))))

65

66

;; (with-umask #o22 nil)

67

68

(defmacro with-fd ((fvar fname &key (flags #.sb-posix:o-rdonly) (close t)) &body body)

69

"Bind FVAR to an open file descriptor resulting from calling SB-POSIX:OPEN on

70

FNAME with FLAGS for the duration of BODY. When CLOSE is non-nil (the default)

71

arrange for FVAR to be closed after BODY."

72

`(let* ((,fvar (sb-posix:open ,fname ,flags)))

73

(unwind-protect (progn ,@body)

74

,@(when close `(sb-posix:close ,fvar)))))

75

76

;;; Linux

77

;; https://man7.org/linux/man-pages/man3/statvfs.3.html

78

(defar statvfs int

79

(path c-string)

80

(buf (* t)))

81

82

;; https://man7.org/linux/man-pages/man3/getmntent.3.html

83

(define-alien-type mntent

84

(struct mntent

85

(fsname c-string)

86

(dir c-string)

87

(type c-string)

88

(opts c-string)

89

(freq int)

90

(passno int)))

91

92

(defar setmntent (* t) (filename c-string) (type c-string))

93

94

(defar getmntent (* t) (stream (* t)))

95

96

(defar endmntent int (stream (* t)))

97

98

(defar hasmntopt c-string (mnt (* mntent)) (opt c-string))

99

100

(defar isatty int (fd int))

101

102

(defar ("tcgetattr" tcgetattr*) int (fd int) (term (* sb-posix::alien-termios)))

103

(defar ("tcsetattr" tcsetattr*) int (fd int) (actions int) (term (* sb-posix::alien-termios)))

104

(defar cfmakeraw void (term (* sb-posix::alien-termios)))

105

106

(define-alien-type winsize (struct winsize

107

(row unsigned-short)

108

(col unsigned-short)

109

(xpixel unsigned-short)

110

(ypixel unsigned-short)))

111

112

;; #define TIOCGWINSZ 0x5413

113

;; #define TIOCSWINSZ 0x5414

114

;; #define TIOCNOTTY 0x5422

115

(defconstant +tiocgwinsz+ #x5413)

116

(defconstant +tiocswinsz+ #x5414)

117

(defconstant +tiocnotty+ #x5422)

118

(defconstant +tcsanow+ 0)

119

(defconstant +tcsadrain+ 1)

120

(defconstant +tcsaflush+ 2)

121

(defconstant +opost+ #x01)

122

123

;;; XDG

124

125

;; ref: https://freedesktop.org/wiki/Software/xdg-user-dirs/

126

(defvar *xdg-user-dirs*

127

(let ((tbl (make-hash-table)))

128

(mapc (lambda (x) (setf (gethash (car x) tbl) (cdr x)))

129

'((:desktop . "Desktop")

130

(:download . "Downloads")

131

(:templates . "Templates")

132

(:publicshare . "Public")

133

(:documents . "Documents")

134

(:music . "Music")

135

(:pictures . "Pictures")

136

(:videos . "Videos")))

137

tbl))

138

139

(defun xdg-user-dir (key)

140

(gethash key *xdg-user-dirs*))

141

142

(defun (setf xdg-user-dir) (v k)

143

(let ((new (if (typep v 'std/path:absolute-pathname)

144

v

145

(merge-pathnames v "~/"))))

146

(setf (gethash k *xdg-user-dirs*) new)))

147

148

(defun init-xdg-user-dirs ()

149

"Init *XDG-USER-DIRS* from environment."

150

(mapc

151

(lambda (k)

152

      (std/macs:when-let ((e (sb-posix:getenv (concatenate 'string "XDG_" (substitute #\_ #\- (string k)) "DIR"))))

153

(setf (xdg-user-dir k) (pathname e))))

154

(std/hash-table:hash-table-keys *xdg-user-dirs*))

155

*xdg-user-dirs*)

156

157

;; ref: https://specifications.freedesktop.org/basedir-spec/latest/

158

(defvar *xdg-base-dirs*

159

(let ((tbl (make-hash-table)))

160

(mapc (lambda (x) (setf (gethash (car x) tbl) (cdr x)))

161

`((:data-home . ".data")

162

(:config-home ".config")

163

(:state-home . ".local/state")

164

(:data-dirs . (#p"/usr/local/share/" #p"/usr/share/"))

165

(:config-dirs . (#P"/etc/xdg"))

166

(:cache-home . (".cache"))

167

(:runtime-dir)))

168

tbl))

169

170

(defun xdg-base-dir (key) (gethash key *xdg-base-dirs*))

171

172

(defun (setf xdg-base-dir) (v k)

173

(let ((new (if (typep v 'std/path:absolute-pathname)

174

v

175

(merge-pathnames v "~/"))))

176

(setf (gethash k *xdg-base-dirs*) new)))

177

178

(defun init-xdg-base-dirs ()

179

"Init *XDG-BASE-DIRS* from environment."

180

(mapc

181

(lambda (k)

182

      (std/macs:when-let ((e (sb-posix:getenv (concatenate 'string "XDG_" (substitute #\_ #\- (string k))))))

183

(setf (xdg-base-dir k) (pathname e))))

184

(std/hash-table:hash-table-keys *xdg-base-dirs*)))

185

186

;;; user-add

187

(defun user-add (name &key shell home comment base gid uid system groups (defaults t) (output t))

188

(let ((useradd (probe-file "/bin/useradd")))

189

(if useradd

190

(sb-ext:run-program

191

useradd `(,name

192

,@(when shell `("-s" ,shell))

193

,@(when home `("-d" ,home))

194

,@(when comment `("-c" ,comment))

195

,@(when base `("-b" ,base))

196

,@(when gid `("-g" ,gid))

197

,@(when uid `("-u" ,uid))

198

,@(when system '("-r"))

199

,@(when groups (cons "-g" groups))

200

,@(when defaults '("-D")))

201

:output output)

202

(error "unable to find USERADD program (/bin/useradd)"))))

203

204

;;; group-add

205

(defun group-add (name &key force id users (output t))

206

(let ((groupadd (probe-file "/bin/groupadd")))

207

(if groupadd

208

(sb-ext:run-program

209

groupadd `(,name

210

,@(when force '("-f"))

211

,@(when id `("-i" ,id))

212

,@(when users (cons "-i" users)))

213

:output output)

214

(error "unable to find GROUPADD program (/bin/groupadd)"))))

215

216

;;; with-directory-iterator

217

(defun %get-file-kind (namestring follow-p)

218

(handler-case

219

(let ((mode (sb-posix:stat-mode

220

(if follow-p

221

(sb-posix:stat namestring)

222

(sb-posix:lstat namestring)))))

223

(case (logand sb-posix:s-ifmt mode)

224

(#.sb-posix:s-ifdir :directory)

225

(#.sb-posix:s-ifchr :character-device)

226

(#.sb-posix:s-ifblk :block-device)

227

(#.sb-posix:s-ifreg :regular-file)

228

(#.sb-posix:s-iflnk :symbolic-link)

229

(#.sb-posix:s-ifsock :socket)

230

(#.sb-posix:s-ififo :pipe)

231

(otherwise

232

(error "Unknown file mode: ~A." mode))))

233

;; TODO 2025-03-24: test

234

(sb-posix:syscall-error ()

235

(cond

236

;; stat() returned ENOENT: either FILE does not exist

237

;; or the end of the symlink chain is a broken symlink

238

(follow-p

239

(handler-case

240

(sb-posix:lstat namestring)

241

(:no-error (stat)

242

(declare (ignorable stat))

243

(values :symbolic-link :broken))))

244

;; lstat() returned ENOENT: FILE does not exist

245

(t nil)))))

246

247

(defun get-file-kind (file follow-p)

248

(%get-file-kind (sb-ext:native-namestring file) follow-p))

249

250

;;;; Hopefully portable pathname manipulations

251

(defun absolute-pathname-p (pathspec)

252

"Returns T if the PATHSPEC designates an absolute pathname, NIL otherwise."

253

(eq :absolute (car (pathname-directory pathspec))))

254

255

(defun relative-pathname-p (pathspec)

256

"Returns T if the PATHSPEC designates a relative pathname, NIL otherwise."

257

(not (absolute-pathname-p pathspec)))

258

259

(defun absolute-pathname (pathspec

260

&optional (default *default-pathname-defaults*))

261

"Returns an absolute pathname corresponding to PATHSPEC by

262

merging it with DEFAULT, and (CURRENT-DIRECTORY) if necessary."

263

(if (relative-pathname-p pathspec)

264

(let ((tmp (merge-pathnames

265

pathspec

266

(make-pathname :name nil :type nil :version nil

267

:defaults default))))

268

(if (relative-pathname-p tmp)

269

(merge-pathnames tmp (current-directory))

270

tmp))

271

pathspec))

272

273

(defun unmerge-pathnames (pathspec

274

&optional (default *default-pathname-defaults*))

275

"Removes those leading directory components from PATHSPEC that

276

are shared with DEFAULT."

277

(let* ((dir (pathname-directory pathspec))

278

(mismatch (mismatch dir (pathname-directory default) :test #'equal)))

279

(make-pathname :directory (when mismatch

280

`(:relative ,@(subseq dir mismatch)))

281

:defaults pathspec)))

282

283

(defun current-directory ()

284

"CURRENT-DIRECTORY returns the operating system's current

285

directory, which may or may not correspond to

286

*DEFAULT-PATHNAME-DEFAULTS*.

287

288

SETF CURRENT-DIRECTORY changes the operating system's current

289

directory to the PATHSPEC. An error is signalled if the PATHSPEC

290

is wild or does not designate a directory."

291

(let ((cwd (sb-posix:getcwd)))

292

(if cwd

293

(pathname (concatenate 'string cwd "/"))

294

(error "Could not get current directory."))))

295

296

(defun (setf current-directory) (pathspec)

297

"Implicitly set current-directory to PATHSPEC using SB-POSIX:CHDIR."

298

(sb-posix:chdir pathspec))

299

300

(defun call-with-directory-iterator (pathspec fun)

301

(let ((dir (absolute-pathname (pathname pathspec)))

302

(old-dir (current-directory)))

303

(let ((dp (sb-posix:opendir dir)))

304

(labels ((one-iter ()

305

(let ((dir (sb-posix:readdir dp)))

306

(unless (or (null dir) (null-alien dir))

307

(let ((name (sb-posix:dirent-name dir)))

308

(cond

309

((member name '("." "..") :test #'string=)

310

(one-iter))

311

((eq :directory (%get-file-kind name t))

312

(make-pathname :directory `(:relative ,name)))

313

(t

314

(let ((dotpos (position #\. name :from-end t)))

315

(if (and dotpos (plusp dotpos))

316

(make-pathname :name (subseq name 0 dotpos)

317

                                                :type (subseq name (1+ dotpos)))

318

(make-pathname :name name))))))))))

319

(unwind-protect

320

(let ((*default-pathname-defaults* dir))

321

(setf (current-directory) dir)

322

(funcall fun #'one-iter))

323

(sb-posix:closedir dp)

324

(setf (current-directory) old-dir))))))

325

326

(defmacro with-directory-iterator ((iterator pathspec) &body body)

327

"PATHSPEC must be a valid directory designator:

328

*DEFAULT-PATHNAME-DEFAULTS* is bound, and (CURRENT-DIRECTORY) is set

329

to the designated directory for the dynamic scope of the body.

330

331

Within the lexical scope of the body, ITERATOR is defined via

332

macrolet such that successive invocations of (ITERATOR) return

333

the directory entries, one by one. Both files and directories

334

are returned, except '.' and '..'. The order of entries is not

335

guaranteed. The entries are returned as relative pathnames

336

against the designated directory. Entries that are symbolic

337

links are not resolved, but links that point to directories are

338

interpreted as directory designators. Once all entries have been

339

returned, further invocations of (ITERATOR) will all return NIL.

340

341

The value returned is the value of the last form evaluated in

342

body. Signals an error if PATHSPEC is wild or does not designate

343

a directory."

344

(with-gensyms (one-iter)

345

`(call-with-directory-iterator

346

,pathspec

347

(lambda (,one-iter)

348

(declare (type function ,one-iter))

349

(macrolet ((,iterator ()

350

`(funcall ,',one-iter)))

351

,@body)))))

352

353

(defun file-kind (pathspec &key follow-symlinks)

354

"Returns a keyword indicating the kind of file designated by PATHSPEC,

355

or NIL if the file does not exist. Does not follow symbolic

356

links by default.

357

358

Possible file-kinds in addition to NIL are: :REGULAR-FILE,

359

:SYMBOLIC-LINK, :DIRECTORY, :PIPE, :SOCKET, :CHARACTER-DEVICE, and

360

:BLOCK-DEVICE.

361

If FOLLOW-SYMLINKS is non-NIL and PATHSPEC designates a broken symlink

362

returns :BROKEN as second value.

363

364

Signals an error if PATHSPEC is wild."

365

(get-file-kind (merge-pathnames pathspec) follow-symlinks))

366

367

(defun merge-env-pathnames (path &optional default)

368

(if-let ((%default (sb-posix:getenv default)))

369

(merge-pathnames path (namestring (directory-path %default)))

370

path))

371

372

;;; StumpWM exec utils

373

;; from stumpwm/wrappers.lisp

374

(defun execv (program &rest arguments)

375

"Call the system execv() function, replacing the current process image with a

376

new one."

377

(declare (ignorable program arguments))

378

(sb-alien:with-alien ((prg sb-alien:c-string program)

379

(argv (array sb-alien:c-string 256)))

380

(loop

381

for i in arguments

382

for j below 255

383

do (setf (sb-alien:deref argv j) i))

384

(setf (sb-alien:deref argv (length arguments)) nil)

385

     (sb-alien:alien-funcall (sb-alien:extern-alien "execv" (function sb-alien:int sb-alien:c-string (* sb-alien:c-string)))

386

prg (sb-alien:cast argv (* sb-alien:c-string)))))

387

388

(defun open-pipe (&key (element-type '(unsigned-byte 8)))

389

"Create a pipe and return two fd-streams. The first value is the input

390

stream, and the second value is the output stream."

391

(multiple-value-bind (in-fd out-fd)

392

(sb-posix:pipe)

393

(let ((in-stream (sb-sys:make-fd-stream in-fd :input t :element-type element-type))

394

(out-stream (sb-sys:make-fd-stream out-fd :output t :element-type element-type)))

395

(values in-stream out-stream))))

396

397

(defun pathname-executable-p (pathname)

398

"Return T if the pathname describes an executable file."

399

(let ((filename (coerce (sb-ext:native-namestring pathname) 'string)))

400

(and (or (pathname-name pathname)

401

(pathname-type pathname))

402

(sb-unix:unix-access filename sb-unix:x_ok))))

403

404

;; based on cffi version of set-signal-handler from Andrew Lyon at https://stackoverflow.com/a/10442062

405

;; rewritten to use SBCL's Foreign Function Interface directly by Max-Gerd Retzlaff

406

(defmacro set-signal-handler (signo &body body)

407

`(sb-alien:alien-funcall

408

(sb-alien:extern-alien "signal" (function sb-alien:void

409

                                               sb-alien:int sb-alien:system-area-pointer))

410

,signo

411

;; callback function

412

(sb-alien:alien-sap

413

(sb-alien::alien-lambda sb-alien:void ((signum sb-alien:int))

414

,@body))))