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

Kind	Covered	All	%
expression	31	551	5.6
branch	0	60	0.0

Key

Not instrumented

Conditionalized out

Executed

Not executed

Both branches taken

One branch taken

Neither branch taken

1

;;; std/file.lisp --- Standard File Library

2

3

;;

4

5

;;; Code:

6

(in-package :std/file)

7

8

(define-condition unknown-file-type (file-error) ()

9

(:report (lambda (c s) (format s "unknown file type: ~A" (file-error-pathname c))))

10

(:documentation "Error signaled when the type of a file is unknown."))

11

12

(defun unknown-file-type (file)

13

"Signal an error of type UNKNOWN-FILE-TYPE."

14

(error 'unknown-file-type :pathname file))

15

16

(defgeneric file (self)

17

(:documentation "Return the file associated with SELF."))

18

(defgeneric (setf file) (new self)

19

(:documentation "Set the value of the file associated with SELF to NEW."))

20

(defgeneric dir (self)

21

(:documentation "Return the directory associated with SELF."))

22

(defgeneric (setf dir) (new self)

23

(:documentation "Set the value of the directory associated with SELF to NEW."))

24

25

(declaim (ftype (function (t) string) read-file))

26

(defun read-file (path)

27

(declare (optimize (speed 3)))

28

(with-output-to-string (s)

29

(write-file-into-stream path s)))

30

31

(defun tmpfile (size)

32

"Create an anonymous temporary file of the given size. Returns a file descriptor."

33

(let (done fd pathname)

34

(unwind-protect

35

(progn

36

(setf (values fd pathname) (sb-posix:mkstemp "/dev/shm/tmp.XXXXXXXX"))

37

(sb-posix:unlink pathname)

38

(sb-posix:ftruncate fd size)

39

(setf done t))

40

(when (and fd (not done)) (sb-posix:close fd)))

41

fd))

42

43

(declaim (inline octet-vector=/unsafe))

44

(defun octet-vector=/unsafe (v1 v2 start1 end1 start2 end2)

45

(declare (optimize (speed 3)

46

(safety 0)

47

(debug 0)

48

(compilation-speed 0))

49

(type octet-vector v1 v2)

50

(type array-index start1 start2)

51

(type array-length end1 end2))

52

(and (= (- end1 start1)

53

(- end2 start2))

54

(loop for i from start1 below end1

55

for j from start2 below end2

56

always (eql (aref v1 i) (aref v2 j)))))

57

58

(defun octet-vector= (v1 v2 &key (start1 0) end1

59

(start2 0) end2)

60

"Like `string=' for octet vectors."

61

(declare (octet-vector v1 v2)

62

(array-index start1 start2)

63

((or array-length null) end1 end2)

64

(optimize speed))

65

(let* ((len1 (length v1))

66

(len2 (length v2))

67

(end1 (or end1 len1))

68

(end2 (or end2 len2)))

69

(assert (<= start1 end1 len1))

70

(assert (<= start2 end2 len2))

71

(octet-vector=/unsafe v1 v2 start1 end1 start2 end2)))

72

73

(defun file-size-in-octets (file)

74

"Return the file-size of FILE in octets."

75

(multiple-value-bind (path namestring)

76

(etypecase file

77

(string (values (pathname file)

78

file))

79

(pathname (values file

80

(sb-ext:native-namestring file))))

81

(declare (ignorable path namestring))

82

(sb-posix:stat-size (sb-posix:stat path))))

83

84

(define-constant si-prefixes

85

'((-30 "quecto" "q")

86

(-27 "ronto" "r")

87

(-24 "yocto" "y")

88

(-21 "zepto" "z")

89

(-18 "atto" "a")

90

(-15 "femto" "f")

91

(-12 "pico" "p")

92

( -9 "nano" "n")

93

( -6 "micro" "μ")

94

( -3 "milli" "m")

95

( -2 "centi" "c")

96

( -1 "deci" "d")

97

( 0 "" "" )

98

( 1 "deca" "da")

99

( 2 "hecto" "h")

100

( 3 "kilo" "k")

101

( 6 "mega" "M")

102

( 9 "giga" "G")

103

( 12 "tera" "T")

104

( 15 "peta" "P")

105

( 18 "exa" "E")

106

( 21 "zetta" "Z")

107

( 24 "yotta" "Y")

108

( 27 "ronna" "R")

109

( 30 "quetta" "Q"))

110

:test #'equalp

111

:documentation "List as SI prefixes: power of ten, long form, short form.")

112

113

(define-constant si-prefixes-base-1000

114

(loop for (pow long short) in si-prefixes

115

unless (and (not (zerop pow))

116

(< (abs pow) 3))

117

collect (list (truncate pow 3) long short))

118

:test #'equalp

119

:documentation "The SI prefixes as powers of 1000, with centi, deci, deca and hecto omitted.")

120

121

(define-constant iec-prefixes

122

'(( 0 "" "")

123

(10 "kibi" "Ki")

124

(20 "mebi" "Mi")

125

(30 "gibi" "Gi")

126

(40 "tebi" "Ti")

127

(50 "pebi" "Pi")

128

(60 "exbi" "Ei"))

129

:test #'equalp

130

:documentation "The IEC binary prefixes, as powers of 2.")

131

132

(eval-always

133

(defun single (seq)

134

"Is SEQ a sequence of one element?"

135

(= (length seq) 1)))

136

137

(defmacro si-prefix-rec (n base prefixes)

138

(cond ((null prefixes) (error "No prefixes!"))

139

((single prefixes)

140

(destructuring-bind ((power long short)) prefixes

141

`(values ,long ,short ,(expt base power))))

142

(t

143

;; good enough

144

(let* ((halfway (ceiling (length prefixes) 2))

145

(lo (subseq prefixes 0 halfway))

146

(hi (subseq prefixes halfway))

147

(split (* (expt base (caar hi)))))

148

`(if (< ,n ,split)

149

(si-prefix-rec ,n ,base ,lo)

150

(si-prefix-rec ,n ,base ,hi))))))

151

152

(defun si-prefix (n &key (base 1000))

153

"Given a number, return the prefix of the nearest SI unit.

154

155

Three values are returned: the long form, the short form, and the

156

multiplying factor.

157

158

(si-prefix 1001) => \"kilo\", \"k\", 1000d0

159

160

BASE can be 1000, 10, 1024, or 2. 1000 is the default, and prefixes

161

start at kilo and milli. Base 10 is mostly the same, except the

162

prefixes centi, deci, deca and hecto are also used. Base 1024 uses the

163

same prefixes as 1000, but with 1024 as the base, as in vulgar file

164

sizes. Base 2 uses the IEC binary prefixes."

165

(if (zerop n) (values "" "" 1d0)

166

(let ((n (abs (coerce n 'double-float))))

167

(ecase base

168

(2 (si-prefix-rec n 2d0 #.iec-prefixes))

169

(10 (si-prefix-rec n 10d0 #.si-prefixes))

170

(1000 (si-prefix-rec n 1000d0 #.si-prefixes-base-1000))

171

(1024 (si-prefix-rec n 1024d0 #.si-prefixes-base-1000))))))

172

173

(defun human-size-formatter (size &key (flavor :si)

174

(space (eql flavor :si)))

175

"Auxiliary function for formatting quantities human-readably.

176

Returns two values: a format control and a list of arguments.

177

178

This can be used to integrate the human-readable printing of

179

quantities into larger format control strings using the recursive

180

processing format directive (~?):

181

182

(multiple-value-bind (control args)

183

(human-size-formatter size)

184

(format t \"~?\" control args))"

185

(let ((size (coerce size 'double-float))

186

;; Avoid printing exponent markers.

187

(*read-default-float-format* 'double-float)

188

(base (ecase flavor

189

(:file 1024)

190

(:si 1000)

191

(:iec 2))))

192

(multiple-value-bind (long short factor)

193

(si-prefix size :base base)

194

(declare (ignore long))

195

(let* ((size (/ size factor))

196

(int (round size))

197

(size

198

(if (> (abs (- size int))

199

0.05d0)

200

size

201

int)))

202

(values (formatter "~:[~d~;~,1f~]~:[~; ~]~a")

203

(list (floatp size) size space short))))))

204

205

(defun format-human-size (stream size

206

&key (flavor :si)

207

(space (eql flavor :si)))

208

"Write SIZE to STREAM, in human-readable form.

209

210

STREAM is interpreted as by `format'.

211

212

If FLAVOR is `:si' (the default) the base is 1000 and SI prefixes are used.

213

214

If FLAVOR is `:file', the base is 1024 and SI prefixes are used.

215

216

If FLAVOR is `:iec', the base is 1024 bytes and IEC prefixes (Ki, Mi,

217

etc.) are used.

218

219

If SPACE is non-nil, include a space between the number and the

220

prefix. (Defaults to T if FLAVOR is `:si'.)"

221

(if (zerop size)

222

(format stream "0")

223

(multiple-value-bind (formatter args)

224

(human-size-formatter size :flavor flavor :space space)

225

(format stream "~?" formatter args))))

226

227

(defun format-file-size-human-readable (stream file-size

228

&key flavor

229

(space (eql flavor :si))

230

                                              (suffix (if (eql flavor :iec) "B" "")))

231

"Write FILE-SIZE, a file size in bytes, to STREAM, in human-readable form.

232

233

STREAM is interpreted as by `format'.

234

235

If FLAVOR is nil, kilobytes are 1024 bytes and SI prefixes are used.

236

237

If FLAVOR is `:si', kilobytes are 1000 bytes and SI prefixes are used.

238

239

If FLAVOR is `:iec', kilobytes are 1024 bytes and IEC prefixes (Ki,

240

Mi, etc.) are used.

241

242

If SPACE is non-nil, include a space between the number and the

243

prefix. (Defaults to T if FLAVOR is `:si'.)

244

245

SUFFIX is the suffix to use; defaults to B if FLAVOR is `:iec',

246

otherwise empty."

247

(check-type file-size (integer 0 *))

248

(if (zerop file-size)

249

(format stream "0")

250

(let ((flavor (if (null flavor) :file flavor)))

251

(multiple-value-bind (formatter args)

252

(human-size-formatter file-size :flavor flavor :space space)

253

(format stream "~?~a" formatter args suffix)))))

254

255

(defun file-size-human-readable (file &key flavor space suffix stream)

256

"Format the size of FILE (in octets) using `format-file-size-human-readable'.

257

The size of file is found by `trivial-file-size:file-size-in-octets'.

258

259

Inspired by the function of the same name in Emacs."

260

(let ((file-size (file-size-in-octets file)))

261

(format-file-size-human-readable

262

stream

263

file-size

264

:flavor flavor

265

:suffix suffix

266

:space space)))

267

268

(defmacro with-open-files ((&rest args) &body body)

269

"A simple macro to open one or more files providing the streams for the

270

BODY. The ARGS is a list of `(stream filespec options*)` as supplied to

271

WITH-OPEN-FILE."

272

(case (length args)

273

((0)

274

`(progn ,@body))

275

((1)

276

`(with-open-file ,(first args) ,@body))

277

(t `(with-open-file ,(first args)

278

(with-open-files

279

,(rest args) ,@body)))))

280

281

(defmacro with-open-file* ((stream filespec &key direction element-type

282

if-exists if-does-not-exist external-format)

283

&body body)

284

"Just like WITH-OPEN-FILE, but NIL values in the keyword arguments

285

mean to use the default value specified for OPEN."

286

(once-only (direction element-type if-exists if-does-not-exist external-format)

287

`(with-open-stream

288

(,stream (apply #'open ,filespec

289

(append

290

(when ,direction

291

(list :direction ,direction))

292

(list :element-type (or ,element-type

293

                                                   +default-element-type+))

294

(when ,if-exists

295

(list :if-exists ,if-exists))

296

(when ,if-does-not-exist

297

(list :if-does-not-exist ,if-does-not-exist))

298

(when ,external-format

299

(list :external-format ,external-format)))))

300

,@body)))

301

302

(defmacro with-input-from-file ((stream-name file-name &rest args

303

                                              &key (direction nil direction-p)

304

&allow-other-keys)

305

&body body)

306

"Evaluate BODY with STREAM-NAME to an input stream on the file

307

FILE-NAME. ARGS is sent as is to the call to OPEN except EXTERNAL-FORMAT,

308

which is only sent to WITH-OPEN-FILE when it's not NIL."

309

(declare (ignore direction))

310

(when direction-p

311

(error "Can't specify :DIRECTION for WITH-INPUT-FROM-FILE."))

312

`(with-open-file* (,stream-name ,file-name :direction :input ,@args)

313

,@body))

314

315

(defmacro with-output-to-file ((stream-name file-name &rest args

316

                                             &key (direction nil direction-p)

317

&allow-other-keys)

318

&body body)

319

"Evaluate BODY with STREAM-NAME to an output stream on the file

320

FILE-NAME. ARGS is sent as is to the call to OPEN except EXTERNAL-FORMAT,

321

which is only sent to WITH-OPEN-FILE when it's not NIL."

322

(declare (ignore direction))

323

(when direction-p

324

(error "Can't specify :DIRECTION for WITH-OUTPUT-TO-FILE."))

325

`(with-open-file* (,stream-name ,file-name :direction :output ,@args)

326

,@body))

327

328

(defun write-stream-into-file (stream pathname &key (if-exists :error) if-does-not-exist)

329

"Read STREAM and write the contents into PATHNAME.

330

331

STREAM will be closed afterwards, so wrap it with

332

`make-concatenated-stream' if you want it left open."

333

(check-type pathname pathname)

334

(with-output-to-file (out pathname

335

:element-type (stream-element-type stream)

336

:if-exists if-exists

337

:if-does-not-exist if-does-not-exist)

338

(copy-stream stream out))

339

pathname)

340

341

(defun write-file-into-stream (pathname output &key (if-does-not-exist :error)

342

                                                     (external-format :default))

343

"Write the contents of FILE into STREAM."

344

(check-type pathname pathname)

345

(with-input-from-file (input pathname

346

:element-type (stream-element-type output)

347

:if-does-not-exist if-does-not-exist

348

:external-format external-format)

349

(copy-stream input output :end (file-size-in-octets pathname))))

350

351

(defun file= (file1 file2 &key (buffer-size 4096))

352

"Compare FILE1 and FILE2 octet by octet, \(possibly) using buffers

353

of BUFFER-SIZE."

354

(declare (ignorable buffer-size))

355

(let ((file1 (truename file1))

356

(file2 (truename file2)))

357

(or (equal file1 file2)

358

(and (= (file-size-in-octets file1)

359

(file-size-in-octets file2))

360

#+ccl (file=/mmap file1 file2)

361

#-ccl (file=/loop file1 file2 :buffer-size buffer-size)))))

362

363

(defun file=/loop (file1 file2 &key (buffer-size 4096))

364

"Compare two files by looping over their contents using a buffer."

365

(declare

366

(type pathname file1 file2)

367

(type array-length buffer-size)

368

(optimize (safety 1) (debug 0) (compilation-speed 0)))

369

(flet ((make-buffer ()

370

(make-array buffer-size

371

:element-type 'octet

372

:initial-element 0)))

373

(declare (inline make-buffer))

374

(with-open-files ((file1 file1 :element-type 'octet :direction :input)

375

(file2 file2 :element-type 'octet :direction :input))

376

(and (= (file-length file1)

377

(file-length file2))

378

(locally (declare (optimize speed))

379

(loop with buffer1 = (make-buffer)

380

with buffer2 = (make-buffer)

381

for end1 = (read-sequence buffer1 file1)

382

for end2 = (read-sequence buffer2 file2)

383

until (or (zerop end1) (zerop end2))

384

always (and (= end1 end2)

385

(octet-vector= buffer1 buffer2

386

:end1 end1

387

:end2 end2))))))))

388

389

(defun file-size (file &key (element-type '(unsigned-byte 8)))

390

"The size of FILE, in units of ELEMENT-TYPE (defaults to bytes).

391

392

The size is computed by opening the file and getting the length of the

393

resulting stream.

394

395

If all you want is to read the file's size in octets from its metadata,

396

consider FILE-SIZE-IN-OCTETS instead."

397

(check-type file (or string pathname))

398

(with-input-from-file (in file :element-type element-type)

399

(file-length in)))

400

401

(defun file-timestamp ()

402

"Returns current timestamp as a string suitable as the name of a timestamped-file."

403

(multiple-value-bind (sec min hr day mon yr)

404

(get-decoded-time)

405

(format nil "~4d~2,'0d~2,'0d_~2,'0d~2,'0d~2,'0d" yr mon day hr min sec)))

406

407

(defun file-date ()

408

"Returns current date as a string suitable as the name of a timestamped-file."

409

(multiple-value-bind (sec min hr day mon yr)

410

(get-decoded-time)

411

(declare (ignore sec min hr))

412

(format nil "~4d~2,'0d~2,'0d" yr mon day)))

413

414

;; see https://www.n16f.net/blog/counting-lines-with-common-lisp/

415

416

(defvar *hidden-paths* (list ".hg" ".git"))

417

418

(defun hidden-path-p (path &optional strict)

419

"Return T if PATH is strictly a hidden file or directory or NIL else."

420

(declare (type pathname path))

421

(let ((name (if (directory-path-p path)

422

(car (last (pathname-directory path)))

423

(file-namestring path))))

424

(and (plusp (length name))

425

(if strict

426

(eq (char name 0) #\.)

427

(member name *hidden-paths* :test 'equal)))))

428

429

(defun find-files (path &optional (hide *hidden-paths*))

430

"Return a list of all files contained in the directory at PATH or any of its

431

subdirectories."

432

(declare (type (or pathname string) path))

433

(flet ((list-directory (path)

434

(directory

435

(make-pathname :defaults (directory-path path)

436

:type :wild :name :wild))))

437

(let ((paths nil)

438

(children (list-directory (directory-path path))))

439

(dolist (child children paths)

440

(unless (and hide (hidden-path-p child (eq t hide)))

441

(if (directory-path-p child)

442

(setf paths (append paths (find-files child)))

443

(push child paths)))))))

444

445

(defun count-file-lines (path)

446

"Count the number of non-empty lines in the file at PATH. A line is empty if

447

it only contains spaces or tab characters."

448

(declare (type pathname path))

449

(with-open-file (stream path :element-type '(unsigned-byte 8))

450

(do ((nb-lines 0)

451

(blank-line t))

452

(nil)

453

(let ((octet (read-byte stream nil)))

454

(cond

455

((or (null octet) (eq octet #.(char-code #\Newline)))

456

(unless blank-line

457

(incf nb-lines))

458

(when (null octet)

459

(return-from count-file-lines nb-lines))

460

(setf blank-line t))

461

((and (/= octet #.(char-code #\Space))

462

(/= octet #.(char-code #\Tab)))

463

(setf blank-line nil)))))))

464

465

(defun probe-merge-file (name path)

466

"Merge paths NAME on PATH and call PROBE-FILE on the result."

467

(probe-file (merge-pathnames name path)))

468

469

(defun probe-delete-file (file)

470

"Delete FILE if it exists, else return NIL."

471

(when (probe-file file)

472

(delete-file file)))

473

474

(defun probe-directory (directory)

475

"Probe DIRECTORY, ensuring it is a valid directory name and exists."

476

(when-let ((dir (probe-file directory)))

477

(when (directory-path-p dir)

478

dir)))

479

480

(defun probe-delete-directory (directory &key (recursive t))

481

"Delete DIRECTORY if it exists, when RECURSIVE is non-nil, delete recursively."

482

(when (probe-file directory)

483

(delete-directory directory :recursive recursive)))

484

485

(defun delete-directories (dirs &key (recursive t) (probe t))

486

"Delete directories in list DIRS."

487

(dolist (d dirs)

488

(if probe

489

(probe-delete-directory d :recursive recursive)

490

(sb-ext:delete-directory d :recursive recursive))))

491

492

(defun move-file (input output)

493

"Move file INPUT to OUTPUT."

494

(progn (uiop:copy-file input output)

495

(delete-file input)))

496

�