Coverage report: /home/ellis/comp/core/lib/dat/tar.lisp

Kind	Covered	All	%
expression	2	1512	0.1
branch	0	112	0.0

Key

Not instrumented

Conditionalized out

Executed

Not executed

Both branches taken

One branch taken

Neither branch taken

1

;;; tar.lisp --- Tarballs

2

3

;; Unix Tape Archive Formats.

4

5

;;; Commentary:

6

7

;; wiki: https://en.wikipedia.org/wiki/Tar_(computing)

8

;; gnu-tar: https://www.gnu.org/software/tar/manual/html_node/Standard.html

9

10

;; ustar: https://wiki.osdev.org/USTAR

11

12

;; USTAR is the widely-available POSIX standard.

13

14

;; impl: https://github.com/froydnj/archive

15

;; impl: https://gitlab.common-lisp.net/cl-tar

16

17

;; rust impl: https://github.com/alexcrichton/tar-rs

18

19

;;; Code:

20

(in-package :dat/tar)

21

22

;;; Vars

23

(defvar *tar-block-bytes* 512)

24

25

(defvar *tar-record-blocks* 20)

26

27

(defvar *tar-record-bytes* (* *tar-block-bytes* *tar-record-blocks*))

28

29

;;; values for tar's `typeflag' field

30

(defconstant +tar-regular-file+ #x30)

31

;;; backwards compatibility

32

(defconstant +tar-regular-alternate-file+ #x00)

33

(defconstant +tar-hard-link+ #x31)

34

(defconstant +tar-symbolic-link+ #x32)

35

(defconstant +tar-character-device+ #x33)

36

(defconstant +tar-block-device+ #x34)

37

(defconstant +tar-directory-file+ #x35)

38

(defconstant +tar-fifo-device+ #x36)

39

(defconstant +tar-implementation-specific-file+ #x37)

40

41

(defconstant +posix-extended-header+ #x78)

42

(defconstant +posix-global-header+ #x67)

43

44

;;; non-standard typeflags

45

(defconstant +gnutar-long-link-name+ #x4b)

46

(defconstant +gnutar-long-name+ #x4c)

47

(defconstant +gnutar-sparse+ #x53)

48

(defconstant +gnutar-directory-dump+ #x44)

49

(defconstant +gnutar-volume-header-name+ #x56)

50

51

(defconstant +ascii-space+ #x20)

52

(defconstant +ascii-zero+ #x30)

53

(defconstant +ascii-nine+ #x39)

54

(defconstant +ascii-a+ #x61)

55

(defconstant +ascii-z+ #x7a)

56

(defconstant +ascii-/+ #x29)

57

(defconstant +ascii-newline+ #xa)

58

59

;;; Conditions

60

(define-condition tar-error () ())

61

(deferror simple-tar-error (tar-error simple-error) () (:auto t))

62

(deferror invalid-checksum-error (tar-error)

63

((provided :initarg :provided :reader error-provided)

64

(computed :initarg :computed :reader error-computed))

65

(:report (lambda (condition stream)

66

(format stream "Invalid tar header checksum ~D (wanted ~D)"

67

(error-provided condition) (error-computed condition))))

68

(:documentation "Signaled when the checksum in a tar header is invalid."))

69

70

(define-condition malformed-pax-attribute-entry (tar-error) ())

71

72

;;; Macros

73

(eval-always

74

(defun round-up-to-tar-block (num)

75

(* (ceiling num *tar-block-bytes*) *tar-block-bytes*))

76

77

(defun tar-checksum-guts (header-type block start transform-fun)

78

(declare (type (simple-array (unsigned-byte 8) (*)) block))

79

(let* ((end (+ start *tar-block-bytes*))

80

(checksum-offset (field-offset header-type 'checksum))

81

(checksum-start (+ start checksum-offset))

82

(checksum-end (+ start checksum-offset

83

(field-length header-type 'checksum))))

84

(loop for i from start below end

85

sum (if (or (< i checksum-start) (<= checksum-end i))

86

(funcall transform-fun (aref block i))

87

+ascii-space+))))

88

89

(defun compute-checksum-for-tar-header (header-type block start)

90

(tar-checksum-guts header-type block start #'identity))

91

92

(defun compute-old-checksum-for-tar-header (header-type block start)

93

(tar-checksum-guts header-type block start #'(lambda (b) (if (< b 128) b (- b 256)))))

94

95

(defun tar-block-checksum-matches-p (header-type block checksum start)

96

(let ((sum (compute-checksum-for-tar-header header-type block start)))

97

(if (= sum checksum)

98

t

99

;; try the older, signed arithmetic way

100

(let ((signed-sum (compute-old-checksum-for-tar-header header-type block start)))

101

(values (= signed-sum checksum) sum)))))

102

103

(defun null-block-p (block start)

104

(declare (type (simple-array (unsigned-byte 8) (*)) block))

105

(null (position-if-not #'zerop block

106

:start start :end (+ start *tar-block-bytes*))))

107

108

(defun extractor-function-name (entry-name field-name)

109

(intern (with-standard-io-syntax (format nil "~A-READ-~A-FROM-BUFFER" entry-name field-name))))

110

111

(defun injector-function-name (entry-name field-name)

112

(intern (with-standard-io-syntax (format nil "~A-WRITE-~A-TO-BUFFER" entry-name field-name)))))

113

114

(defgeneric field-offset (header field-name))

115

116

(defgeneric field-length (header field-name))

117

118

(defmacro define-octet-header (class-name &rest field-defs)

119

(let ((offset 0)) ; could be integrated in the LOOP?

120

(flet ((keywordify-name (name)

121

(intern (symbol-name name) (find-package "KEYWORD"))))

122

(loop for (name length kind constant) in field-defs

123

collect `(defmethod field-offset ((header ,class-name) (field-name (eql ',name)))

124

,offset) into offset-defs

125

             collect `(defmethod field-offset ((header (eql ',class-name)) (field-name (eql ',name)))

126

,offset) into offset-defs

127

collect `(defmethod field-length ((header ,class-name) (field-name (eql ',name)))

128

,length) into length-defs

129

             collect `(defmethod field-length ((header (eql ',class-name)) (field-name (eql ',name)))

130

,length) into length-defs

131

             collect `(defun ,(extractor-function-name class-name name) (buffer entry-start encoding)

132

(declare (type (simple-array (unsigned-byte 8) (*)) buffer))

133

(declare (ignorable encoding))

134

,(ecase kind

135

(:string

136

`(octets-to-string

137

                              (read-octets-from-buffer buffer :start (+ entry-start ,offset)

138

                                                               :end (+ entry-start ,offset ,length) :nullp nil)

139

:external-format encoding))

140

(:string-null

141

`(octets-to-string

142

                              (read-octets-from-buffer buffer :start (+ entry-start ,offset)

143

                                                              :end (+ entry-start ,offset ,length) :nullp t)

144

:external-format encoding))

145

(:byte

146

(unless (= length 1)

147

(error ":BYTE fields cannot be longer than 1"))

148

`(aref buffer (+ entry-start ,offset)))

149

(:bytes

150

                            `(subseq buffer (+ entry-start ,offset) (+ entry-start ,offset ,length)))

151

                           (:octnum `(read-number-from-buffer buffer :start (+ entry-start ,offset)

152

                                                                     :end (+ entry-start ,offset ,length) :radix 8))

153

                           (:hexnum `(read-number-from-buffer buffer :start (+ entry-start ,offset)

154

                                                                     :end (+ entry-start ,offset ,length) :radix 16)))) into reader-defs

155

             collect `(defun ,(injector-function-name class-name name) (buffer entry-start thing encoding)

156

(declare (type (simple-array (unsigned-byte 8) (*)) buffer))

157

(declare (ignorable encoding))

158

,(ecase kind

159

((:string :string-null)

160

                            `(let ((thing (string-to-octets thing :external-format encoding)))

161

(dotimes (i (length thing) (values))

162

                                 (setf (aref buffer (+ entry-start ,offset i)) (aref thing i)))))

163

(:byte

164

`(setf (aref buffer (+ entry-start ,offset)) thing))

165

(:bytes

166

                            `(setf (subseq buffer (+ entry-start ,offset) (+ entry-start ,offset ,length))

167

thing))

168

(:octnum

169

`(let ((start (+ entry-start ,offset))

170

(end (+ entry-start ,offset ,length)))

171

                               (write-number-to-buffer thing buffer :start start :end end :radix 8 :nullp t)))

172

(:hexnum

173

`(let ((start (+ entry-start ,offset))

174

(end (+ entry-start ,offset ,length)))

175

                               (write-number-to-buffer thing buffer :start start :end end :radix 16 :nullp nil))))

176

(values)) into writer-defs

177

collect `(,name :initarg ,(keywordify-name name)

178

:accessor ,name) into slot-definitions

179

append `(,(keywordify-name name)

180

,(if constant

181

constant

182

(case kind

183

((:string :string-null) "")

184

(t 0)))) into default-initargs

185

do (incf offset length)

186

finally (return

187

`(progn

188

(defclass ,class-name ()

189

,slot-definitions

190

(:default-initargs ,@default-initargs))

191

,@length-defs

192

,@offset-defs

193

,@reader-defs

194

,@writer-defs

195

(defmethod header-length ((header ,class-name))

196

,offset)

197

(defmethod header-length ((header (eql ',class-name)))

198

,offset)

199

                          (defmethod write-header-to-buffer ((header ,class-name) buffer encoding &optional (start 0))

200

                            (declare (type (simple-array (unsigned-byte 8) (*)) buffer))

201

202

;; Ensure we can write the entire header to this

203

;; buffer.

204

(assert (<= (+ start *tar-block-bytes*) (length buffer)))

205

;; Ensure a clean slate

206

                            (fill buffer 0 :start start :end (+ start *tar-block-bytes*))

207

208

,@(loop

209

:for (name length kind) :in field-defs

210

:unless (eql name 'checksum)

211

                                  :collect `(,(injector-function-name class-name name) buffer start (,name header)

212

encoding))

213

214

;; Write the checksum

215

                            (let* ((checksum (compute-checksum-for-tar-header header buffer start))

216

                                   (checksum-offset (+ start (field-offset header 'checksum))))

217

(write-number-to-buffer checksum buffer

218

                                                      :start checksum-offset

219

                                                      :end (+ checksum-offset

220

                                                              (field-length header 'checksum)

221

-2)

222

:radix 8)

223

;; terminated with a NULL and then a space (!?)

224

(setf (aref buffer (+ checksum-offset 6)) 0

225

                                    (aref buffer (+ checksum-offset 7)) +ascii-space+)))

226

                          (defmethod read-header-from-buffer ((header (eql ',class-name)) buffer encoding &key (start 0))

227

                            (let ((checksum (,(extractor-function-name class-name 'checksum) buffer start encoding)))

228

(multiple-value-bind (validp computed)

229

                                  (tar-block-checksum-matches-p header buffer checksum start)

230

(unless validp

231

(error 'invalid-checksum-error

232

                                         :provided checksum :computed computed))

233

(make-instance header

234

,@(loop

235

                                                   :for (name length kind) :in field-defs

236

                                                   :unless (eql name '%%padding)

237

                                                     :appending `(,(keywordify-name name)

238

                                                                  (,(extractor-function-name class-name name)

239

                                                                   buffer start encoding)))))))))))))

240

241

;;; Protocol

242

(defgeneric close-tar-file (tar-file)

243

(:documentation

244

"Closes the stream associated with TAR-FILE and the tar-file itself.

245

Further operations on the tar-file are undefined.

246

247

Does NOT close the underlying STREAM that backed the TAR-FILE."))

248

249

(defgeneric mode (entry)

250

(:documentation "Return the mode of the ENTRY (an integer)."))

251

252

(defgeneric uid (entry)

253

(:documentation "Return the uid of the ENTRY (an integer)."))

254

255

(defgeneric gid (entry)

256

(:documentation "Return the gid of the ENTRY (an integer)."))

257

258

(defgeneric size (entry)

259

(:documentation "Return the size of the ENTRY (an integer)."))

260

261

(defgeneric mtime (entry)

262

(:documentation "Return the mtime of the ENTRY (an integer)."))

263

264

(defgeneric linkname (entry)

265

(:documentation "Return the linkname of the ENTRY (a string)."))

266

267

(defgeneric uname (entry)

268

(:documentation "Return the uname of the ENTRY (a string)."))

269

270

(defgeneric gname (entry)

271

(:documentation "Return the gname of the ENTRY (a string)."))

272

273

(defgeneric devmajor (entry)

274

(:documentation "Return the major device of the ENTRY (an integer)."))

275

276

(defgeneric devminor (entry)

277

(:documentation "Return the minor device of the ENTRY (an integer)."))

278

279

(defgeneric prefix (entry)

280

(:documentation "Return the prefix of the ENTRY (a string)."))

281

282

(defgeneric atime (entry)

283

(:documentation "Return the atime of the ENTRY (an integer)."))

284

285

(defgeneric ctime (entry)

286

(:documentation "Return the ctime of the ENTRY (an integer)."))

287

288

(defgeneric offset (entry)

289

(:documentation "Return the offset of the ENTRY (an integer)."))

290

291

(defgeneric offset-sparse-0 (entry)

292

(:documentation "Return the offset of the first sparse block of the ENTRY (an integer)."))

293

294

(defgeneric numbytes-sparse-0 (entry)

295

(:documentation "Return the numbytes of the first sparse block of the ENTRY (an integer)."))

296

297

(defgeneric offset-sparse-1 (entry)

298

(:documentation "Return the offset of the second sparse block of the ENTRY (an integer)."))

299

300

(defgeneric numbytes-sparse-1 (entry)

301

(:documentation "Return the numbytes of the second sparse block of the ENTRY (an integer)."))

302

303

(defgeneric offset-sparse-2 (entry)

304

(:documentation "Return the offset of the third sparse block of the ENTRY (an integer)."))

305

306

(defgeneric numbytes-sparse-2 (entry)

307

(:documentation "Return the numbytes of the third sparse block of the ENTRY (an integer)."))

308

309

(defgeneric offset-sparse-3 (entry)

310

(:documentation "Return the offset of the fourth sparse block of the ENTRY (an integer)."))

311

312

(defgeneric numbytes-sparse-3 (entry)

313

(:documentation "Return the numbytes of the fourth sparse block of the ENTRY (an integer)."))

314

315

(defgeneric isextended (entry)

316

(:documentation "Return the isextended field of the ENTRY (an integer)."))

317

318

(defgeneric realsize (entry)

319

(:documentation "Return the realsize of the ENTRY (an integer)."))

320

321

(defgeneric entry-file-p (entry)

322

(:documentation "Returns non-NIL if ENTRY denotes a regular file.")

323

(:method (entry)

324

nil))

325

326

(defgeneric entry-directory-p (entry)

327

(:documentation "Returns non-NIL if ENTRY denotes a directory.")

328

(:method (entry)

329

nil))

330

331

(defgeneric entry-symbolic-link-p (entry)

332

(:documentation "Returns non-NIL if ENTRY denotes a symbolic link.")

333

(:method (entry)

334

nil))

335

336

(defgeneric entry-character-device-p (entry)

337

(:documentation "Returns non-NIL if ENTRY denotes a character device.")

338

(:method (entry)

339

nil))

340

341

(defgeneric entry-block-device-p (entry)

342

(:documentation "Returns non-NIL if ENTRY denotes a block device.")

343

(:method (entry)

344

nil))

345

346

(defgeneric entry-fifo-p (entry)

347

(:documentation "Returns non-NIL if ENTRY denotes a fifo.")

348

(:method (entry)

349

nil))

350

351

(defgeneric entry-pax-extended-attributes-p (entry)

352

(:documentation "Returns non-NIL if ENTRY contains PAX extended attributes.")

353

(:method (entry)

354

nil))

355

356

(defgeneric entry-pax-global-attributes-p (entry)

357

(:documentation "Returns non-NIL if ENTRY contains PAX global attributes.")

358

(:method (entry)

359

nil))

360

361

(defgeneric entry-gnu-long-link-name-p (entry)

362

(:documentation "Returns non-NIL if ENTRY contains a GNU long link name.")

363

(:method (entry)

364

nil))

365

366

(defgeneric entry-gnu-long-name-p (entry)

367

(:documentation "Returns non-NIL if ENTRY contains a GNU long name.")

368

(:method (entry)

369

nil))

370

371

(defgeneric entry-gnu-directory-dump-p (entry)

372

(:documentation "Returns non-NIL if ENTRY contains a GNU directory dump.")

373

(:method (entry)

374

nil))

375

376

(defgeneric entry-gnu-sparse-file-p (entry)

377

(:documentation "Returns non-NIL if ENTRY contains a GNU sparse file.")

378

(:method (entry)

379

nil))

380

381

(defgeneric entry-gnu-volume-header-name-p (entry)

382

(:documentation "Returns non-NIL if ENTRY contains a GNU volume header name.")

383

(:method (entry)

384

nil))

385

386

(defgeneric entry-unknown-p (entry)

387

(:documentation "Returns non-NIL if ENTRY is unknown.")

388

(:method (entry)

389

nil))

390

391

;; reading

392

(defgeneric read-entry (tar-file)

393

(:documentation "Return the next entry in TAR-FILE or NIL if there is no

394

next entry"))

395

396

;; writing

397

(defgeneric write-entry (tar-file entry

398

&key stream)

399

(:documentation "Write ENTRY to TAR-FILE. Data associated with ENTRY is

400

written to TAR-FILE according to the :STREAM argument. If :STREAM is T, the

401

expression (NAME ENTRY) is expected to refer to an existing file from which

402

data may be read. If :STREAM is a stream, then data is read from that stream

403

and written to TAR-FILE. If :STREAM is NIL, then no entry data is written."))

404

405

(defgeneric write-header-to-buffer (header buffer encoding &optional start)

406

(:documentation "Write the information associated with HEADER into BUFFER,

407

beginning at position START."))

408

409

(defgeneric write-entry-data (tar-file entry stream)

410

(:documentation "Write any data associated with ENTRY, possibly found

411

in STREAM to TAR-FILE; called after WRITE-HEADER-TO-BUFFER. STREAM is

412

interpreted as in WRITE-ENTRY."))

413

414

(defgeneric finalize-tar-file (tar-file)

415

(:documentation "Perform any necessary processing for finalizing TAR-FILE.

416

This function must be called prior to calling CLOSE-TAR-FILE."))

417

418

(defgeneric write-file-entry (tar-file name &rest args &key uname gname mode mtime uid gid size data

419

                                                          prefix)

420

(:documentation

421

"Write a FILE-ENTRY to TAR-FILE.

422

423

DATA can be either NIL (no data is written), an octet vector (written as is), a

424

string (encoded using UTF-8 and written), or a PATHNAME (opened, read, and

425

written to the archive)."))

426

427

 (defgeneric write-hard-link-entry (tar-file name &rest args &key uname gname mode mtime uid gid linkname prefix)

428

(:documentation

429

"Write a HARD-LINK-ENTRY to TAR-FILE."))

430

431

 (defgeneric write-symbolic-link-entry (tar-file name &rest args &key uname gname mode mtime uid gid linkname prefix)

432

(:documentation

433

"Write a SYMBOLIC-LINK-ENTRY to TAR-FILE."))

434

435

(defgeneric write-character-device-entry (tar-file name &rest args &key uname gname mode mtime uid gid

436

                                                                      devmajor devminor

437

                                                                      prefix)

438

(:documentation

439

"Write a CHARACTER-DEVICE-ENTRY to TAR-FILE."))

440

441

(defgeneric write-block-device-entry (tar-file name &rest args &key uname gname mode mtime uid gid

442

                                                                  devmajor devminor

443

                                                                  prefix)

444

(:documentation

445

"Write a BLOCK-DEVICE-ENTRY to TAR-FILE."))

446

447

(defgeneric write-directory-entry (tar-file name &rest args &key uname gname mode mtime uid gid size

448

                                                               prefix)

449

(:documentation

450

"Write a DIRECTORY-ENTRY to TAR-FILE."))

451

452

(defgeneric write-fifo-entry (tar-file name &rest args &key uname gname mode mtime uid gid prefix)

453

(:documentation

454

"Write a FIFO-ENTRY to TAR-FILE."))

455

456

(defgeneric write-pax-extended-attributes-entry (tar-file name &rest args &key attributes)

457

(:documentation

458

"Write a PAX-EXTENDED-ATTRIBUTES-ENTRY to TAR-FILE.

459

460

ATTRIBUTES must be either a hash table mapping strings to strings or an alist

461

mapping strings to strings. If it is an alist, ordering is preserved."))

462

463

(defgeneric write-pax-global-attributes-entry (tar-file name &rest args &key attributes)

464

(:documentation

465

"Write a PAX-GLOBAL-ATTRIBUTES-ENTRY to TAR-FILE.

466

467

ATTRIBUTES must be either a hash table mapping strings to strings or an alist

468

mapping strings to strings. If it is an alist, ordering is preserved."))

469

470

(defgeneric write-gnu-long-link-name-entry (tar-file name &rest args &key data)

471

(:documentation

472

"Write a GNU-LONG-LINK-NAME-ENTRY to TAR-FILE.

473

474

DATA must be either a string (which is then UTF-8 encoded) or a byte vector."))

475

476

(defgeneric write-gnu-long-name-entry (tar-file name &rest args &key data)

477

(:documentation

478

"Write a GNU-LONG-NAME-ENTRY to TAR-FILE.

479

480

DATA must be either a string (which is then UTF-8 encoded) or a byte vector."))

481

482

;;; Tar File

483

(defvar *type-detectors* nil

484

"A list of functions, that when called with a header buffer must return a

485

symbol naming the type of tar-file that the header belongs to, or NIL.")

486

487

(defparameter *default-type* 'v7-tar-file

488

"The default tar-file type if no detectors register a hit.")

489

490

(defun register-type-detector (f)

491

(pushnew f *type-detectors*))

492

493

(defun detect-type (buffer)

494

(or (some (lambda (f) (funcall f buffer)) *type-detectors*)

495

*default-type*))

496

497

(defclass tar-file ()

498

((direction

499

:initarg :direction

500

:reader %tar-file-direction

501

:type (member :input :output))

502

(open-tar-file-p

503

:initform t

504

:accessor open-tar-file-p)

505

(stream

506

:initarg :stream

507

:reader tar-file-stream

508

:type stream)

509

(other-streams-to-close

510

:initarg :other-streams-to-close

511

:reader tar-file-other-streams-to-close

512

:type list)

513

(next-entry-start

514

:accessor next-entry-start

515

:type integer

516

:initform 0)

517

(header-encoding

518

:initform :utf-8

519

:initarg :header-encoding

520

:accessor header-encoding))

521

(:documentation

522

"Base class of a tar file."))

523

524

(defgeneric entry-type (tar-file header)

525

(:documentation

526

"Return a symbol naming the class to use to represent the entry for HEADER in TAR-FILE."))

527

528

(defun make-compression-stream (stream direction compression)

529

(ecase compression

530

(:zstd

531

(ecase direction

532

(:input (io/flate:make-decompressing-stream :zstd stream))

533

(:output (io/flate:make-compressing-stream :zstd stream))))

534

(:auto

535

(let ((file-name (ignore-errors (pathname stream))))

536

(ecase direction

537

(:output

538

(if (null file-name)

539

stream

540

(let ((type (pathname-type file-name)))

541

(if (or (null type) (not (uiop:string-suffix-p type "zst")))

542

stream

543

(make-compression-stream stream direction :zstd)))))

544

(:input

545

(if (null file-name)

546

stream

547

(let ((type (pathname-type file-name)))

548

(if (or (null type) (not (uiop:string-suffix-p type "zst")))

549

stream

550

(make-compression-stream stream direction :zstd))))))))

551

((nil) stream)))

552

553

(defun open-tar-file (stream &key (direction :input)

554

(type :auto)

555

(blocking-factor 20)

556

(header-encoding :utf-8)

557

(compression :auto))

558

"Create a TAR-FILE object backed by STREAM. The STREAM should not be read

559

from or written to any more.

560

561

DIRECTION is either :INPUT or :OUTPUT.

562

563

BLOCKING-FACTOR is an integer that specifies how many 512-byte blocks should be

564

read from or written to STREAM at any one time.

565

566

TYPE is either AUTO or a class designator for a subclass of TAR-FILE. If :AUTO,

567

the appropriate class will be determined by looking at the first tar header.

568

569

HEADER-ENCODING is an encoding specifier recognized by Babel.

570

571

COMPRESSION determines what compression scheme is used, if any. It can be

572

either :AUTO (the default), NIL (no compression), or :ZSTD. If :AUTO, the

573

compression type is determined using the PATHNAME of the stream (for :OUTPUT)

574

or by peeking at the stream for magic numbers (for :INPUT)."

575

(declare (type (member :input :output) direction))

576

(check-type compression (member :gzip :zstd :auto nil))

577

(multiple-value-bind

578

(compression-stream other-streams-to-close)

579

(make-compression-stream stream direction compression)

580

(let ((blocked-stream (make-instance (case direction

581

(:input 'blocked-input-stream)

582

                                            (:output 'blocked-output-stream))

583

:stream compression-stream

584

                                          :block-size (* *tar-block-bytes* blocking-factor))))

585

(flet ((read-buffer ()

586

(let ((buffer (make-array *tar-block-bytes* :initial-element 0

587

                                                              :element-type '(unsigned-byte 8))))

588

(assert (= *tar-block-bytes* (read-sequence buffer blocked-stream)))

589

buffer)))

590

(make-instance (if (and (eql type :auto) (eql direction :input))

591

(detect-type

592

(read-buffer))

593

*default-type*)

594

:stream blocked-stream

595

:other-streams-to-close (append (unless (eql compression-stream stream)

596

(list compression-stream))

597

other-streams-to-close)

598

:direction direction

599

:header-encoding header-encoding)))))

600

601

(defmethod close-tar-file (tar-file)

602

(when (open-tar-file-p tar-file)

603

(close (tar-file-stream tar-file))

604

(mapc #'close (tar-file-other-streams-to-close tar-file))

605

(setf (open-tar-file-p tar-file) nil))

606

t)

607

608

(defmethod read-entry :before ((tar-file tar-file))

609

(unless (eq (%tar-file-direction tar-file) :input)

610

(error "Attempting to read from a non-input tar-file"))

611

(unless (open-tar-file-p tar-file)

612

(error "Attempting to read from a closed tar-file")))

613

614

(defmethod write-entry :before ((tar-file tar-file) entry

615

&key stream)

616

(declare (ignore stream))

617

(unless (eq (%tar-file-direction tar-file) :output)

618

(error "Attempting to write to a non-output tar-file"))

619

(unless (open-tar-file-p tar-file)

620

(error "Attempting to write to a closed tar-file")))

621

622

(defmethod write-entry-data ((tar-file tar-file) entry stream)

623

(cond

624

((typep stream 'stream)

625

(if (and (subtypep (stream-element-type stream) '(unsigned-byte 8))

626

(subtypep '(unsigned-byte 8) (stream-element-type stream)))

627

(transfer-stream-to-tar-file tar-file stream)

628

(error "Stream has invalid STREAM-ELEMENT-TYPE ~A"

629

(stream-element-type stream))))

630

((typep stream 'pathname)

631

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

632

(transfer-stream-to-tar-file tar-file stream)))

633

((typep stream 'string)

634

(transfer-octets-to-tar-file tar-file (string-to-octets stream :external-format :utf-8)))

635

((typep stream 'vector)

636

(transfer-octets-to-tar-file tar-file stream))

637

((eq nil stream)

638

;; do nothing

639

)

640

(t

641

(error "Invalid argument for :STREAM: ~A" stream))))

642

643

(defmethod write-entry ((tar-file tar-file) entry

644

&key stream)

645

(with-slots ((tar-file-stream stream)) tar-file

646

(let ((buffer (make-array *tar-block-bytes* :element-type '(unsigned-byte 8))))

647

(declare (dynamic-extent buffer))

648

;; write the entry

649

(write-header-to-buffer entry buffer (header-encoding tar-file) 0)

650

(write-sequence buffer tar-file-stream))

651

;; write any associated data

652

(write-entry-data tar-file entry stream)

653

(values)))

654

655

;;; providing streamy access for an entry

656

(defun make-stream-for-entry (tar-file entry)

657

(make-bound-stream (tar-file-stream tar-file) (size entry)))

658

659

(defmethod read-entry :before ((tar-file tar-file))

660

(unless (file-position (tar-file-stream tar-file) (next-entry-start tar-file))

661

(simple-tar-error "Unable to set FILE-POSITION.")))

662

663

(defmethod read-entry ((tar-file tar-file))

664

(let ((start-position (file-position (tar-file-stream tar-file)))

665

(buffer (make-array *tar-block-bytes* :element-type '(unsigned-byte 8))))

666

(declare (dynamic-extent buffer))

667

(with-slots (stream) tar-file

668

(let ((nbytes (read-sequence buffer stream)))

669

(unless (= nbytes *tar-block-bytes*)

670

(error "Corrupt tar-file"))))

671

(if (null-block-p buffer 0)

672

nil

673

(let ((header (read-header-from-buffer (header-type tar-file) buffer

674

                                                (header-encoding tar-file)

675

:start 0)))

676

(make-instance (entry-type tar-file header)

677

:tar-file tar-file

678

:header header

679

:start start-position)))))

680

681

(defmethod read-entry :around ((tar-file tar-file))

682

(let ((entry (call-next-method)))

683

(unless (null entry)

684

(setf (next-entry-start tar-file)

685

(+ (start entry)

686

*tar-block-bytes*

687

(if (entry-has-data-p entry)

688

(round-up-to-tar-block (size entry))

689

0))))

690

entry))

691

692

(defun transfer-stream-to-tar-file (tar-file stream)

693

(let* ((bytes-copied (copy-stream stream (tar-file-stream tar-file)))

694

(rounded-bytes (round-up-to-tar-block bytes-copied))

695

(bytes-remaining (- rounded-bytes bytes-copied)))

696

(write-sequence (make-array bytes-remaining :element-type '(unsigned-byte 8)

697

:initial-element 0)

698

(tar-file-stream tar-file))))

699

700

(defun transfer-octets-to-tar-file (tar-file octets)

701

(let* ((rounded-bytes (round-up-to-tar-block (length octets)))

702

(bytes-remaining (- rounded-bytes (length octets))))

703

(write-sequence octets (tar-file-stream tar-file))

704

(write-sequence (make-array bytes-remaining :element-type '(unsigned-byte 8)

705

:initial-element 0)

706

(tar-file-stream tar-file))))

707

708

(defmethod finalize-tar-file ((tar-file tar-file))

709

(let ((null-block (make-array *tar-block-bytes*

710

:element-type '(unsigned-byte 8)

711

:initial-element 0)))

712

(declare (dynamic-extent null-block))

713

(dotimes (i 2)

714

(write-sequence null-block (tar-file-stream tar-file)))

715

(values)))

716

717

(define-octet-header v7-header

718

(name 100 :string-null)

719

(mode 8 :octnum)

720

(uid 8 :octnum)

721

(gid 8 :octnum)

722

(size 12 :octnum)

723

(mtime 12 :octnum)

724

(checksum 8 :octnum)

725

(typeflag 1 :byte)

726

(linkname 100 :string-null)

727

;; not part of the tar format, but it makes defined constants come out right

728

(%%padding 255 :string))

729

730

(defclass v7-tar-file (tar-file) ()

731

(:documentation

732

"A v7 tar file."))

733

734

(defmethod header-type ((tar-file v7-tar-file))

735

'v7-header)

736

737

(defmethod entry-type ((tar-file v7-tar-file) header)

738

(if (ends-with-subseq "/" (name header))

739

'tar-directory-entry

740

(switch ((typeflag header))

741

(+tar-regular-file+

742

'tar-file-entry)

743

(+tar-regular-alternate-file+

744

'tar-file-entry)

745

(+tar-hard-link+

746

'tar-hard-link-entry)

747

(+tar-symbolic-link+

748

'tar-symbolic-link-entry)

749

(+tar-directory-file+

750

'tar-directory-entry)

751

(t

752

'unknown-tar-entry))))

753

754

(defparameter *ustar-magic-vector*

755

(coerce `(,@(map 'list #'char-code "ustar") 0)

756

'(vector (unsigned-byte 8)))

757

"The contents of the magic field for ustar tar-files.")

758

759

(defparameter *ustar-version-vector*

760

(coerce (map 'list #'char-code "00") '(vector (unsigned-byte 8)))

761

"The contents of the version field for ustar tar-files.")

762

763

;;; definitions taken from the FreeBSD 5.1 manpage

764

(define-octet-header ustar-header

765

(name 100 :string-null)

766

(mode 8 :octnum)

767

(uid 8 :octnum)

768

(gid 8 :octnum)

769

(size 12 :octnum)

770

(mtime 12 :octnum)

771

(checksum 8 :octnum)

772

(typeflag 1 :byte)

773

(linkname 100 :string-null)

774

(magic 6 :bytes *ustar-magic-vector*)

775

(version 2 :bytes *ustar-version-vector*)

776

;; to be used in preference to uid and gid, of course

777

(uname 32 :string-null)

778

(gname 32 :string-null)

779

(devmajor 8 :octnum)

780

(devminor 8 :octnum)

781

(prefix 155 :string-null)

782

;; not part of the tar format, but it makes defined constants come out right

783

(%%padding 12 :string))

784

785

(defclass ustar-tar-file (tar-file) ()

786

(:documentation

787

"A ustar tar file."))

788

789

(defmethod header-type ((tar-file ustar-tar-file))

790

'ustar-header)

791

792

(defun detect-ustar-tar-file (buffer)

793

(let ((offset (field-offset 'ustar-header 'magic))

794

(length (field-length 'ustar-header 'magic)))

795

(when (equalp *ustar-magic-vector*

796

(subseq buffer offset (+ offset length)))

797

'ustar-tar-file)))

798

799

(register-type-detector 'detect-ustar-tar-file)

800

801

(defmethod entry-type ((tar-file ustar-tar-file) header)

802

(switch ((typeflag header))

803

(+tar-regular-file+

804

'tar-file-entry)

805

(+tar-regular-alternate-file+

806

'tar-file-entry)

807

(+tar-hard-link+

808

'tar-hard-link-entry)

809

(+tar-symbolic-link+

810

'tar-symbolic-link-entry)

811

(+tar-character-device+

812

'tar-character-device-entry)

813

(+tar-block-device+

814

'tar-block-device-entry)

815

(+tar-directory-file+

816

'tar-directory-entry)

817

(+tar-fifo-device+

818

'tar-fifo-entry)

819

(+posix-extended-header+

820

'pax-extended-attributes-entry)

821

(+posix-global-header+

822

'pax-global-attributes-entry)

823

(t

824

'unknown-tar-entry)))

825

826

(defparameter *gnu-magic-vector*

827

(coerce `(,@(map 'list #'char-code "ustar "))

828

'(vector (unsigned-byte 8)))

829

"The contents of the magic field for gnu tar-files.")

830

831

(defparameter *gnu-version-vector*

832

(coerce `(,@(map 'list #'char-code " ") 0) '(vector (unsigned-byte 8)))

833

"The contents of the version field for gnu tar-files.")

834

835

(define-octet-header gnu-header

836

(name 100 :string-null)

837

(mode 8 :octnum)

838

(uid 8 :octnum)

839

(gid 8 :octnum)

840

(size 12 :octnum)

841

(mtime 12 :octnum)

842

(checksum 8 :octnum)

843

(typeflag 1 :byte)

844

(linkname 100 :string-null)

845

(magic 6 :string *gnu-magic-vector*)

846

(version 2 :string *gnu-version-vector*)

847

(uname 32 :string-null)

848

(gname 32 :string-null)

849

(devmajor 8 :octnum)

850

(devminor 8 :octnum)

851

(atime 12 :octnum)

852

(ctime 12 :octnum)

853

(offset 12 :octnum)

854

(longnames 4 :string)

855

(unused 1 :byte)

856

(offset-sparse-0 12 :octnum)

857

(numbytes-sparse-0 12 :octnum)

858

(offset-sparse-1 12 :octnum)

859

(numbytes-sparse-1 12 :octnum)

860

(offset-sparse-2 12 :octnum)

861

(numbytes-sparse-2 12 :octnum)

862

(offset-sparse-3 12 :octnum)

863

(numbytes-sparse-3 12 :octnum)

864

(isextended 1 :byte)

865

(realsize 12 :octnum)

866

(%%padding 17 :string))

867

868

(defclass gnu-tar-file (tar-file) ()

869

(:documentation "A gnu tar file."))

870

871

(defmethod header-type ((tar-file gnu-tar-file))

872

'gnu-header)

873

874

(defun detect-gnu-tar-file (buffer)

875

(let ((offset (field-offset 'gnu-header 'magic))

876

(length (field-length 'gnu-header 'magic)))

877

(when (equalp *gnu-magic-vector*

878

(subseq buffer offset (+ offset length)))

879

'gnu-tar-file)))

880

881

(register-type-detector 'detect-gnu-tar-file)

882

883

(defmethod entry-type ((tar-file gnu-tar-file) header)

884

(switch ((typeflag header))

885

(+tar-regular-file+

886

'tar-file-entry)

887

(+tar-regular-alternate-file+

888

'tar-file-entry)

889

(+tar-hard-link+

890

'tar-hard-link-entry)

891

(+tar-symbolic-link+

892

'tar-symbolic-link-entry)

893

(+tar-character-device+

894

'tar-character-device-entry)

895

(+tar-block-device+

896

'tar-block-device-entry)

897

(+tar-directory-file+

898

'tar-directory-entry)

899

(+tar-fifo-device+

900

'tar-fifo-entry)

901

(+gnutar-long-name+

902

'gnu-long-name-entry)

903

(+gnutar-long-link-name+

904

'gnu-long-link-name-entry)

905

(+gnutar-sparse+

906

'gnu-sparse-file-entry)

907

(+gnutar-directory-dump+

908

'gnu-directory-dump-entry)

909

(+gnutar-volume-header-name+

910

'gnu-volume-header-name-entry)

911

(t

912

'unknown-tar-entry)))

913

914

;;; Entries

915

(defclass archive () ())

916

(defclass tar-archive (archive) ())

917

(defclass tar-entry ()

918

((tar-file

919

:initarg :tar-file

920

:reader tar-file)

921

(start

922

:initarg :start

923

:reader start

924

:documentation

925

"The FILE-POSITION of the start of the entry.")

926

(header

927

:initarg :header

928

:reader header))

929

(:documentation

930

"Base class for all entries in a tar file."))

931

932

(defclass tar-entry-data () ())

933

(defclass tar-file-entry (tar-entry tar-entry-data) ()

934

(:documentation

935

"A regular file."))

936

937

(defun read-number-from-buffer (buffer &key (start 0) end (radix 10))

938

(declare (type (simple-array (unsigned-byte 8) (*)) buffer))

939

(declare (type (integer 2 36) radix))

940

(let ((end (or (position-if #'(lambda (b)

941

;; For BSD tar, a number can end with

942

;; a space or a null byte.

943

(or (= b +ascii-space+) (zerop b)))

944

buffer :start start :end end)

945

end

946

(length buffer))))

947

;; GNU tar permits storing numbers as binary; a binary number is

948

;; indicated by starting the field with #x80.

949

(if (= (aref buffer start) #x80)

950

(loop for i from (1- end) downto (1+ start)

951

for base = 1 then (* base 256)

952

sum (* (aref buffer i) base))

953

(loop for i from (1- end) downto start

954

for base = 1 then (* base radix)

955

sum (let ((byte (aref buffer i)))

956

(cond

957

((<= +ascii-zero+ byte +ascii-nine+)

958

(* base (- byte +ascii-zero+)))

959

((<= +ascii-a+ byte +ascii-z+)

960

(* base (+ 10 (- byte +ascii-a+))))

961

(t (simple-tar-error "Invalid byte: ~A in ~A"

962

                                            byte (subseq buffer start end)))))))))

963

964

(defun write-number-to-buffer (number buffer

965

&key (start 0) end (radix 10) nullp)

966

(declare (type (simple-array (unsigned-byte 8) (*)) buffer))

967

(declare (type (integer 2 36) radix))

968

(let ((end (let ((dend (or end (length buffer))))

969

(if nullp

970

(1- dend)

971

dend))))

972

(loop for i from (1- end) downto start

973

do (multiple-value-bind (quo rem) (truncate number radix)

974

(setf number quo)

975

(setf (aref buffer i)

976

(cond

977

((<= 0 rem 9) (+ rem +ascii-zero+))

978

((<= 10 rem 36) (+ (- rem 10) +ascii-a+))

979

(t (simple-tar-error "Don't know how to encode ~A" rem))))))

980

(values)))

981

982

(defun read-octets-from-buffer (buffer &key (start 0) end nullp)

983

(let ((end (if nullp

984

(or (position 0 buffer :start start :end end) end)

985

end)))

986

(subseq buffer start end)))

987

988

(defmethod write-file-entry (tar-file name &rest args &key uname gname mode mtime uid gid size data

989

                                                         prefix)

990

(declare (ignore uname gname mode mtime uid gid prefix))

991

;; Compute the size when necessary.

992

(let ((computed-size

993

(etypecase data

994

(string

995

(setf data (string-to-octets data :external-format :utf-8))

996

(push data args)

997

(push :data args)

998

(length data))

999

(vector

1000

(length data))

1001

(pathname

1002

(with-open-file (s data :element-type '(unsigned-byte 8))

1003

(file-length s)))

1004

(null

1005

0)

1006

(stream

1007

(file-length data)))))

1008

(when (not (null computed-size))

1009

(cond

1010

((null size)

1011

(setf size computed-size))

1012

((/= size computed-size)

1013

(error 'simple-tar-file-error

1014

:format-control "Computed (~A) and specified (~A) sizes mismatch"

1015

:format-args (list computed-size size))))))

1016

(when (null size)

1017

(error 'simple-tar-file-error

1018

:format-control "Size not provided and unable to compute it."))

1019

(push size args)

1020

(push :size args)

1021

1022

(let ((header (apply #'make-instance (header-type tar-file)

1023

:name name

1024

:typeflag (if (typep tar-file 'v7-tar-file)

1025

+tar-regular-alternate-file+

1026

+tar-regular-file+)

1027

(uiop:remove-plist-key :data args)))

1028

(start-position (file-position (tar-file-stream tar-file))))

1029

(write-entry tar-file header :stream data)

1030

(make-instance 'tar-file-entry :header header :tar-file tar-file :start start-position)))

1031

1032

(defclass tar-hard-link-entry (tar-entry)

1033

()

1034

(:documentation

1035

"A hard link."))

1036

1037

 (defmethod write-hard-link-entry (tar-file name &rest args &key uname gname mode mtime uid gid linkname prefix)

1038

(declare (ignore uname gname mode mtime uid gid linkname prefix))

1039

(let ((header (apply #'make-instance (header-type tar-file)

1040

:name name

1041

:typeflag +tar-hard-link+

1042

args))

1043

(start-position (file-position (tar-file-stream tar-file))))

1044

(write-entry tar-file header)

1045

(make-instance 'tar-hard-link-entry :header header :tar-file tar-file :start start-position)))

1046

1047

(defclass tar-symbolic-link-entry (tar-entry)

1048

()

1049

(:documentation

1050

"A symbolic link."))

1051

1052

 (defmethod write-symbolic-link-entry (tar-file name &rest args &key uname gname mode mtime uid gid linkname prefix)

1053

(declare (ignore uname gname mode mtime uid gid linkname prefix))

1054

(let ((header (apply #'make-instance (header-type tar-file)

1055

:name name

1056

:typeflag +tar-symbolic-link+

1057

args))

1058

(start-position (file-position (tar-file-stream tar-file))))

1059

(write-entry tar-file header)

1060

(make-instance 'tar-symbolic-link-entry :header header :tar-file tar-file :start start-position)))

1061

1062

(defclass tar-character-device-entry (tar-entry)

1063

()

1064

(:documentation

1065

"A character device."))

1066

1067

(defmethod write-character-device-entry (tar-file name &rest args &key uname gname mode mtime uid gid

1068

                                                                     devmajor devminor

1069

                                                                     prefix)

1070

(declare (ignore uname gname mode mtime uid gid devmajor devminor prefix))

1071

(let ((header (apply #'make-instance (header-type tar-file)

1072

:name name

1073

:typeflag +tar-character-device+

1074

args))

1075

(start-position (file-position (tar-file-stream tar-file))))

1076

(write-entry tar-file header)

1077

(make-instance 'tar-character-device-entry :header header :tar-file tar-file :start start-position)))

1078

1079

(defclass tar-block-device-entry (tar-entry)

1080

()

1081

(:documentation

1082

"A block device."))

1083

1084

(defmethod write-block-device-entry (tar-file name &rest args &key uname gname mode mtime uid gid

1085

                                                                 devmajor devminor

1086

                                                                 prefix)

1087

(declare (ignore uname gname mode mtime uid gid devmajor devminor prefix))

1088

(let ((header (apply #'make-instance (header-type tar-file)

1089

:name name

1090

:typeflag +tar-block-device+

1091

args))

1092

(start-position (file-position (tar-file-stream tar-file))))

1093

(write-entry tar-file header)

1094

(make-instance 'tar-block-device-entry :header header :tar-file tar-file :start start-position)))

1095

1096

(defclass tar-directory-entry (tar-entry)

1097

()

1098

(:documentation

1099

"A directory."))

1100

1101

(defmethod write-directory-entry (tar-file name &rest args &key uname gname mode mtime uid gid size

1102

                                                              prefix)

1103

(declare (ignore uname gname mode mtime uid gid size prefix))

1104

(let ((header (apply #'make-instance (header-type tar-file)

1105

:name name

1106

:typeflag +tar-directory-file+

1107

args))

1108

(start-position (file-position (tar-file-stream tar-file))))

1109

(write-entry tar-file header)

1110

(make-instance 'tar-directory-entry :header header :tar-file tar-file :start start-position)))

1111

1112

(defclass tar-fifo-entry (tar-entry)

1113

()

1114

(:documentation

1115

"A FIFO."))

1116

1117

(defmethod write-fifo-entry (tar-file name &rest args &key uname gname mode mtime uid gid prefix)

1118

(declare (ignore uname gname mode mtime uid gid prefix))

1119

(let ((header (apply #'make-instance (header-type tar-file)

1120

:name name

1121

:typeflag +tar-fifo-device+

1122

args))

1123

(start-position (file-position (tar-file-stream tar-file))))

1124

(write-entry tar-file header)

1125

(make-instance 'tar-fifo-entry :header header :tar-file tar-file :start start-position)))

1126

1127

(defclass pax-attributes-entry (tar-entry tar-entry-data)

1128

((attributes

1129

:accessor attributes

1130

:documentation

1131

"A hash table mapping attribute names (strings) to values (strings).")))

1132

1133

(defgeneric attribute (entry name &optional default)

1134

(:documentation

1135

"Get the NAME attribute from ENTRY."))

1136

1137

(defmethod attribute ((entry pax-attributes-entry) name &optional default)

1138

(gethash name (attributes entry) default))

1139

1140

(defgeneric attribute-names (entry)

1141

(:documentation

1142

"Return a list of attribute names contained within ENTRY."))

1143

1144

(defmethod attribute-names ((entry pax-attributes-entry))

1145

(hash-table-values (attributes entry)))

1146

1147

(defmacro do-attributes ((name value entry &optional result) &body body)

1148

"Given a PAX ENTRY with attributes, execute BODY for every attribute, with

1149

NAME bound to the attribute name and VALUE bound to the attribute value."

1150

`(block nil

1151

(maphash

1152

(lambda (,name ,value)

1153

,@body)

1154

(attributes ,entry))

1155

,result))

1156

1157

(defun read-attribute-length (stream)

1158

"Pop bytes out of the buffer until a space is read, then try turning that

1159

into a number."

1160

(let* ((bytes-read 0)

1161

(bytes (loop

1162

:for byte := (read-byte stream nil :eof)

1163

:when (eql byte :eof)

1164

:do (return :eof)

1165

:end

1166

:do (incf bytes-read)

1167

:until (eql byte +ascii-space+)

1168

:collect byte)))

1169

(if (eql bytes :eof)

1170

:eof

1171

(values (parse-integer (octets-to-string (coerce bytes '(vector (unsigned-byte 8)))

1172

                                                  :external-format :utf-8))

1173

bytes-read))))

1174

1175

(defun read-attribute (stream)

1176

(multiple-value-bind (num-bytes bytes-read)

1177

(read-attribute-length stream)

1178

(let (buffer

1179

num-read

1180

kv-string

1181

=-position)

1182

(unless (eql num-bytes :eof)

1183

         (setf buffer (make-array (- num-bytes bytes-read) :element-type '(unsigned-byte 8) :initial-element 0))

1184

(setf num-read (read-sequence buffer stream))

1185

(unless (= num-read (- num-bytes bytes-read))

1186

(error 'malformed-pax-attribute-entry))

1187

(setf kv-string (octets-to-string buffer :external-format :utf-8))

1188

(unless (= (aref buffer (1- num-read)) +ascii-newline+)

1189

(error 'malformed-pax-attribute-entry))

1190

(setf =-position (position #\= kv-string))

1191

(when (null =-position)

1192

(error 'malformed-pax-attribute-entry))

1193

(values (subseq kv-string 0 =-position)

1194

(subseq kv-string (1+ =-position) (1- num-read))

1195

t)))))

1196

1197

(defun populate-pax-attributes (entry)

1198

(let ((stream (make-entry-stream entry))

1199

(ht (make-hash-table :test 'equal)))

1200

(loop

1201

(multiple-value-bind (key value exists-p)

1202

(read-attribute stream)

1203

(unless exists-p (return))

1204

(setf (gethash key ht) value)))

1205

(setf (attributes entry) ht)))

1206

1207

(defmethod slot-unbound (class (entry pax-attributes-entry) (slot-name (eql 'attributes)))

1208

(populate-pax-attributes entry))

1209

1210

(defclass pax-extended-attributes-entry (pax-attributes-entry)

1211

()

1212

(:documentation

1213

"Extended attributes for the subsequent record."))

1214

1215

(defmethod user-attributes-to-alist ((attributes hash-table))

1216

(hash-table-alist attributes))

1217

1218

(defmethod user-attributes-to-alist ((attributes list))

1219

attributes)

1220

1221

(defun attribute-pair-to-octets (pair)

1222

(let* ((pair-string (concatenate 'string " "

1223

(car pair)

1224

"="

1225

(cdr pair)

1226

(list #\Linefeed)))

1227

(pair-vector (string-to-octets pair-string :external-format :utf-8))

1228

(base-length (length pair-vector)))

1229

(loop

1230

:for offset :upfrom 0 :below 2

1231

:for estimated-length := (+ offset (ceiling (log base-length 10)) base-length)

1232

:for length-vector := (string-to-octets (prin1-to-string estimated-length)

1233

                                                :external-format :utf-8)

1234

:when (= estimated-length (+ (length length-vector) base-length))

1235

:return (concatenate '(vector (unsigned-byte 8)) length-vector pair-vector))))

1236

1237

(defun attribute-alist-to-octets (alist)

1238

(apply #'concatenate '(vector (unsigned-byte 8)) (mapcar #'attribute-pair-to-octets alist)))

1239

1240

(defmethod write-pax-extended-attributes-entry (tar-file name &rest args &key attributes)

1241

(let* ((alist (user-attributes-to-alist attributes))

1242

(data (attribute-alist-to-octets alist))

1243

(size (length data)))

1244

(let ((header (apply #'make-instance (header-type tar-file)

1245

:name name

1246

:typeflag +posix-extended-header+

1247

:size size

1248

(remf args :attributes)))

1249

(start-position (file-position (tar-file-stream tar-file))))

1250

(write-entry tar-file header :stream data)

1251

(make-instance 'tar-directory-entry :header header :tar-file tar-file :start start-position))))

1252

1253

(defmethod entry-pax-extended-attributes-p ((entry pax-extended-attributes-entry))

1254

t)

1255

1256

(defclass pax-global-attributes-entry (pax-attributes-entry)

1257

()

1258

(:documentation

1259

"Extended attributes for all subsequent records."))

1260

1261

(defmethod write-pax-global-attributes-entry (tar-file name &rest args &key attributes)

1262

(let* ((alist (user-attributes-to-alist attributes))

1263

(data (attribute-alist-to-octets alist))

1264

(size (length data)))

1265

(let ((header (apply #'make-instance (header-type tar-file)

1266

:name name

1267

:typeflag +posix-global-header+

1268

:size size

1269

(remf args :attributes)))

1270

(start-position (file-position (tar-file-stream tar-file))))

1271

(write-entry tar-file header :stream data)

1272

(make-instance 'tar-directory-entry :header header :tar-file tar-file :start start-position))))

1273

1274

(defmethod entry-pax-global-attributes-p ((entry pax-global-attributes-entry))

1275

t)

1276

1277

(defclass gnu-directory-dump-entry (tar-entry tar-entry-data)

1278

())

1279

1280

(defmethod entry-gnu-directory-dump-p ((entry gnu-directory-dump-entry))

1281

t)

1282

1283

(defclass gnu-long-link-name-entry (tar-entry tar-entry-data)

1284

((long-link-name

1285

:accessor long-link-name)))

1286

1287

(defmethod slot-unbound (class (entry gnu-long-link-name-entry) (slot-name (eql 'long-link-name)))

1288

(let ((buffer (make-array (size entry) :element-type '(unsigned-byte 8)

1289

:initial-element 0))

1290

(stream (make-entry-stream entry)))

1291

(read-sequence buffer stream)

1292

(setf (long-link-name entry) (octets-to-string buffer :external-format :utf-8))))

1293

1294

(defmethod write-gnu-long-link-name-entry (tar-file name &rest args &key data)

1295

(let* ((data (etypecase data

1296

(string

1297

(string-to-octets data :external-format :utf-8))

1298

((vector (unsigned-byte 8))

1299

data)))

1300

(size (length data))

1301

(header (apply #'make-instance (header-type tar-file)

1302

:name name

1303

:typeflag +gnutar-long-link-name+

1304

:size size

1305

(remf args :data)))

1306

(start-position (file-position (tar-file-stream tar-file))))

1307

(write-entry tar-file header :stream data)

1308

(make-instance 'gnu-long-link-name-entry

1309

:header header

1310

:tar-file tar-file

1311

:start start-position)))

1312

1313

(defmethod entry-gnu-long-link-name-p ((entry gnu-long-link-name-entry))

1314

t)

1315

1316

(defclass gnu-long-name-entry (tar-entry tar-entry-data)

1317

((long-name

1318

:accessor long-name)))

1319

1320

(defmethod slot-unbound (class (entry gnu-long-name-entry) (slot-name (eql 'long-name)))

1321

(let ((buffer (make-array (size entry) :element-type '(unsigned-byte 8)

1322

:initial-element 0))

1323

(stream (make-entry-stream entry)))

1324

(read-sequence buffer stream)

1325

(setf (long-name entry) (octets-to-string buffer :external-format :utf-8))))

1326

1327

(defmethod write-gnu-long-name-entry (tar-file name &rest args &key data)

1328

(let* ((data (etypecase data

1329

(string

1330

(string-to-octets data :external-format :utf-8))

1331

((vector (unsigned-byte 8))

1332

data)))

1333

(size (length data))

1334

(header (apply #'make-instance (header-type tar-file)

1335

:name name

1336

:typeflag +gnutar-long-link-name+

1337

:size size

1338

(remf args :data)))

1339

(start-position (file-position (tar-file-stream tar-file))))

1340

(write-entry tar-file header :stream data)

1341

(make-instance 'gnu-long-name-entry

1342

:header header

1343

:tar-file tar-file

1344

:start start-position)))

1345

1346

(defmethod entry-gnu-long-name-p ((entry gnu-long-name-entry))

1347

t)

1348

1349

(defclass gnu-sparse-file-entry (tar-entry tar-entry-data)

1350

())

1351

1352

(defmethod entry-gnu-sparse-file-p ((entry gnu-sparse-file-entry))

1353

t)

1354

1355

(defclass gnu-volume-header-name-entry (tar-entry)

1356

())

1357

1358

(defmethod entry-gnu-volume-header-name-p ((entry gnu-volume-header-name-entry))

1359

t)

1360

1361

(defclass unknown-tar-entry (tar-entry tar-entry-data)

1362

()

1363

(:documentation

1364

"An unknown entry."))

1365

1366

(defmethod entry-unknown-p ((tar-entry unknown-tar-entry))

1367

t)

1368

1369

(defgeneric entry-has-data-p (entry)

1370

(:documentation

1371

"Returns non-NIL if ENTRY has associated data that can be read using MAKE-ENTRY-STREAM.")

1372

(:method (entry) nil)

1373

(:method ((entry tar-entry-data)) t))

1374

1375

(defgeneric make-entry-stream (entry)

1376

(:documentation

1377

"Returns a new binary stream that contains ENTRY's data."))

1378

1379

(defmethod make-entry-stream ((entry tar-entry-data))

1380

(make-bound-stream (tar-file-stream (tar-file entry)) (size entry)

1381

(+ (start entry) *tar-block-bytes*)))

1382

1383

(defmacro make-header-forwarder (name)

1384

`(progn

1385

(defmethod ,name ((entry tar-entry))

1386

(,name (header entry)))))

1387

1388

(make-header-forwarder name)

1389

(make-header-forwarder mode)

1390

(make-header-forwarder uid)

1391

(make-header-forwarder gid)

1392

(make-header-forwarder size)

1393

(make-header-forwarder mtime)

1394

(make-header-forwarder checksum)

1395

(make-header-forwarder typeflag)

1396

(make-header-forwarder linkname)

1397

(make-header-forwarder magic)

1398

(make-header-forwarder version)

1399

(make-header-forwarder uname)

1400

(make-header-forwarder gname)

1401

(make-header-forwarder devmajor)

1402

(make-header-forwarder devminor)

1403

(make-header-forwarder prefix)

1404

(make-header-forwarder atime)

1405

(make-header-forwarder ctime)

1406

(make-header-forwarder offset)

1407

(make-header-forwarder offset-sparse-0)

1408

(make-header-forwarder numbytes-sparse-0)

1409

(make-header-forwarder offset-sparse-1)

1410

(make-header-forwarder numbytes-sparse-1)

1411

(make-header-forwarder offset-sparse-2)

1412

(make-header-forwarder numbytes-sparse-2)

1413

(make-header-forwarder offset-sparse-3)

1414

(make-header-forwarder numbytes-sparse-3)

1415

(make-header-forwarder isextended)

1416

(make-header-forwarder realsize)

1417

1418

(defmethod print-object ((entry tar-entry) stream)

1419

(print-unreadable-object (entry stream)

1420

(format stream "Entry ~A" (name entry))))

1421

1422

(defmethod entry-file-p ((entry tar-file-entry))

1423

t)

1424

1425

(defmethod entry-directory-p ((entry tar-directory-entry))

1426

t)

1427

1428

(defmethod entry-hard-link-p ((entry tar-hard-link-entry))

1429

t)

1430

1431

(defmethod entry-symbolic-link-p ((entry tar-symbolic-link-entry))

1432

t)

1433

1434

(defmethod entry-character-device-p ((entry tar-character-device-entry))

1435

t)

1436

1437

(defmethod entry-block-device-p ((entry tar-block-device-entry))

1438

t)

1439

1440

(defmethod entry-fifo-p ((entry tar-fifo-entry))

1441

t)

1442

1443

;;; External Macros

1444

(defun call-with-open-tar-file (thunk pathname-or-stream

1445

&key (direction :input)

1446

(if-exists nil)

1447

(if-does-not-exist :create)

1448

(type :auto)

1449

(blocking-factor 20)

1450

(compression :auto)

1451

(header-encoding :utf-8))

1452

(declare ((member :input :output) direction))

1453

(let (tar-file

1454

stream

1455

(should-close t)

1456

(abort t))

1457

(unwind-protect

1458

(progn

1459

(when (streamp pathname-or-stream) (setf should-close nil))

1460

(setf stream (if should-close

1461

(apply #'open

1462

pathname-or-stream

1463

:direction direction

1464

:element-type '(unsigned-byte 8)

1465

(append

1466

(when if-exists

1467

(list :if-exists if-exists))

1468

(when if-does-not-exist

1469

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

1470

pathname-or-stream))

1471

(setf tar-file (open-tar-file stream :direction direction

1472

:type type

1473

                                                 :blocking-factor blocking-factor

1474

                                                 :header-encoding header-encoding

1475

                                                 :compression compression))

1476

(multiple-value-prog1

1477

(funcall thunk tar-file)

1478

(setf abort nil)))

1479

(when tar-file

1480

(when (eql direction :output)

1481

(finalize-tar-file tar-file))

1482

(close-tar-file tar-file)

1483

(setf tar-file nil))

1484

(when should-close

1485

(close stream :abort abort)))))

1486

1487

(defmacro with-open-tar-file ((tar-file-var pathname-or-stream

1488

&key (direction :input)

1489

(if-exists nil)

1490

(if-does-not-exist nil)

1491

(type :auto)

1492

(compression :auto)

1493

(blocking-factor 20)

1494

(header-encoding :utf-8))

1495

&body body)

1496

"Bind TAR-FILE-VAR to a newly opened TAR-FILE, backed by

1497

PATHNAME-OR-STREAM. If PATHNAME-OR-STREAM evaluates to a stream, that stream

1498

is used directly, otherwise, it is opened via OPEN. If PATHNAME-OR-STREAM is a

1499

stream, that stream is not closed upon exiting the body of the macro.

1500

1501

DIRECTION must be either :INPUT or :OUTPUT.

1502

1503

IF-EXISTS and IF-DOES-NOT-EXIST are passed to OPEN if PATHNAME-OR-STREAM is

1504

not a stream.

1505

1506

See OPEN-TAR-FILE for a description of TYPE, BLOCKING-FACTOR, HEADER-ENCODING,

1507

and COMPRESSION."

1508

(declare ((member :input :output) direction))

1509

`(call-with-open-tar-file

1510

(lambda (,tar-file-var) ,@body)

1511

,pathname-or-stream

1512

:direction ,direction

1513

:if-exists ,if-exists

1514

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

1515

:type ,type

1516

:blocking-factor ,blocking-factor

1517

:header-encoding ,header-encoding

1518

:compression ,compression))

1519

1520

(defmacro do-entries ((entry tar-file &optional result)

1521

&body body)

1522

"Iterate over the entries in TAR-FILE. For each entry, ENTRY is bound to an

1523

ENTRY representing the entry. RESULT is used as in DOTIMES."

1524

(let ((tar-file-var (gensym)))

1525

`(let ((,tar-file-var ,tar-file))

1526

(do ((,entry (read-entry ,tar-file-var)

1527

(read-entry ,tar-file-var)))

1528

((null ,entry) ,result)

1529

,@body))))