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

Kind	Covered	All	%
expression	27	423	6.4
branch	0	44	0.0

Key

Not instrumented

Conditionalized out

Executed

Not executed

Both branches taken

One branch taken

Neither branch taken

1

;;; dat/base64.lisp --- Base64 Strings

2

3

;; RFC 4648

4

5

;; see http://git.kpe.io/?p=cl-base64.git;a=summary

6

7

8

9

;;; Code:

10

(in-package :dat/base64)

11

12

;;; encode

13

(eval-when (:compile-toplevel :load-toplevel :execute)

14

(defvar *encode-table*

15

"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/")

16

(declaim (type simple-string *encode-table*))

17

18

(defvar *uri-encode-table*

19

"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789-_")

20

(declaim (type simple-string *uri-encode-table*))

21

22

(defvar *pad-char* #\=)

23

(defvar *uri-pad-char* #\.)

24

(declaim (type character *pad-char* *uri-pad-char*))

25

26

(deftype decode-table () '(simple-array (signed-byte 8) (128)))

27

(defun make-decode-table (encode-table pad-char

28

&key (whitespace-chars

29

'(#\Linefeed #\Return #\Space #\Tab)))

30

(assert (< (length encode-table) 128)

31

(encode-table)

32

"Encode table too big: ~S" encode-table)

33

(let ((dt (make-array 128 :element-type '(signed-byte 8)

34

:initial-element -1)))

35

(declare (type decode-table dt))

36

(loop for char across encode-table

37

for index upfrom 0

38

do (setf (aref dt (char-code char)) index))

39

(setf (aref dt (char-code pad-char)) -2)

40

(loop for char in whitespace-chars

41

do (setf (aref dt (char-code char)) -3))

42

dt)))

43

44

(defconstant +decode-table+

45

(if (boundp '+decode-table+)

46

(symbol-value '+decode-table+)

47

(make-decode-table *encode-table* *pad-char*)))

48

(declaim (type decode-table +decode-table+))

49

50

(defconstant +uri-decode-table+

51

(if (boundp '+uri-decode-table+)

52

(symbol-value '+uri-decode-table+)

53

(make-decode-table *uri-encode-table* *uri-pad-char*)))

54

(declaim (type decode-table +uri-decode-table+))

55

56

(defun round-next-multiple (x n)

57

"Round x up to the next highest multiple of n."

58

(declare (fixnum n)

59

(optimize (speed 3) (safety 1) (space 0)))

60

(let ((remainder (mod x n)))

61

(declare (fixnum remainder))

62

(if (zerop remainder)

63

x

64

(the fixnum (+ x (the fixnum (- n remainder)))))))

65

66

(defmacro def-*-to-base64-* (input-type output-type)

67

`(defun ,(intern (concatenate 'string (symbol-name input-type)

68

(symbol-name :-to-base64-)

69

(symbol-name output-type)))

70

(input

71

,@(when (eq output-type :stream)

72

'(output))

73

&key (uri nil) (columns 0))

74

"Encode a string array to base64. If columns is > 0, designates

75

maximum number of columns in a line and the string will be terminated

76

with a #\Newline."

77

(declare ,@(case input-type

78

(:string

79

'((string input)))

80

(:octet-vector

81

'((type (array (unsigned-byte 8) (*)) input))))

82

(fixnum columns)

83

(optimize (speed 3) (safety 1) (space 0)))

84

(let ((pad (if uri *uri-pad-char* *pad-char*))

85

(encode-table (if uri *uri-encode-table* *encode-table*)))

86

(declare (simple-string encode-table)

87

(character pad))

88

(let* ((string-length (length input))

89

(complete-group-count (truncate string-length 3))

90

(remainder (nth-value 1 (truncate string-length 3)))

91

(padded-length (* 4 (truncate (+ string-length 2) 3)))

92

,@(when (eq output-type :string)

93

'((num-lines (if (plusp columns)

94

                                    (truncate (+ padded-length (1- columns)) columns)

95

0))

96

(num-breaks (if (plusp num-lines)

97

(1- num-lines)

98

0))

99

(strlen (+ padded-length num-breaks))

100

(result (make-string strlen))

101

(ioutput 0)))

102

(col (if (plusp columns)

103

0

104

(the fixnum (1+ padded-length)))))

105

(declare (fixnum string-length padded-length col

106

,@(when (eq output-type :string)

107

'(ioutput)))

108

,@(when (eq output-type :string)

109

'((simple-string result))))

110

(labels ((output-char (ch)

111

(if (= col columns)

112

(progn

113

,@(case output-type

114

(:stream

115

'((write-char #\Newline output)))

116

(:string

117

'((setf (schar result ioutput) #\Newline)

118

(incf ioutput))))

119

(setq col 1))

120

(incf col))

121

,@(case output-type

122

(:stream

123

'((write-char ch output)))

124

(:string

125

'((setf (schar result ioutput) ch)

126

(incf ioutput)))))

127

(output-group (svalue chars)

128

(declare (fixnum svalue chars))

129

(output-char

130

(schar encode-table

131

(the fixnum

132

(logand #x3f

133

                                          (the fixnum (ash svalue -18))))))

134

(output-char

135

(schar encode-table

136

(the fixnum

137

(logand #x3f

138

                                          (the fixnum (ash svalue -12))))))

139

(if (> chars 2)

140

(output-char

141

(schar encode-table

142

(the fixnum

143

(logand #x3f

144

                                              (the fixnum (ash svalue -6))))))

145

(output-char pad))

146

(if (> chars 3)

147

(output-char

148

(schar encode-table

149

(the fixnum

150

(logand #x3f svalue))))

151

(output-char pad))))

152

(do ((igroup 0 (the fixnum (1+ igroup)))

153

(isource 0 (the fixnum (+ isource 3))))

154

((= igroup complete-group-count)

155

(cond

156

((= remainder 2)

157

(output-group

158

(the fixnum

159

(+

160

(the fixnum

161

(ash

162

,(case input-type

163

(:string

164

                                     '(char-code (the character (char input isource))))

165

(:octet-vector

166

'(the fixnum (aref input isource))))

167

16))

168

(the fixnum

169

(ash

170

,(case input-type

171

(:string

172

'(char-code (the character (char input

173

                                                                 (the fixnum (1+ isource))))))

174

(:octet-vector

175

'(the fixnum (aref input (the fixnum

176

                                                               (1+ isource))))))

177

8))))

178

3))

179

((= remainder 1)

180

(output-group

181

(the fixnum

182

(ash

183

,(case input-type

184

(:string

185

'(char-code (the character (char input isource))))

186

(:octet-vector

187

'(the fixnum (aref input isource))))

188

16))

189

2)))

190

,(case output-type

191

(:string

192

'result)

193

(:stream

194

'output)))

195

(declare (fixnum igroup isource))

196

(output-group

197

(the fixnum

198

(+

199

(the fixnum

200

(ash

201

(the fixnum

202

,(case input-type

203

(:string

204

                                    '(char-code (the character (char input isource))))

205

(:octet-vector

206

'(aref input isource))))

207

16))

208

(the fixnum

209

(ash

210

(the fixnum

211

,(case input-type

212

(:string

213

'(char-code (the character (char input

214

                                                                (the fixnum (1+ isource))))))

215

(:octet-vector

216

'(aref input (1+ isource)))))

217

8))

218

(the fixnum

219

,(case input-type

220

(:string

221

'(char-code (the character (char input

222

                                                          (the fixnum (+ 2 isource))))))

223

(:octet-vector

224

'(aref input (+ 2 isource))))

225

)))

226

4)))))))

227

228

(def-*-to-base64-* :string :string)

229

(def-*-to-base64-* :string :stream)

230

(def-*-to-base64-* :octet-vector :string)

231

(def-*-to-base64-* :octet-vector :stream)

232

233

234

(defun integer-to-base64-string (input &key (uri nil) (columns 0))

235

"Encode an integer to base64 format."

236

(declare (integer input)

237

(fixnum columns)

238

(optimize (speed 3) (space 0) (safety 1)))

239

(let ((pad (if uri *uri-pad-char* *pad-char*))

240

(encode-table (if uri *uri-encode-table* *encode-table*)))

241

(declare (simple-string encode-table)

242

(character pad))

243

(let* ((input-bits (integer-length input))

244

(byte-bits (round-next-multiple input-bits 8))

245

(padded-bits (round-next-multiple byte-bits 6))

246

(remainder-padding (mod padded-bits 24))

247

(padding-bits (if (zerop remainder-padding)

248

0

249

(- 24 remainder-padding)))

250

(padding-chars (/ padding-bits 6))

251

(padded-length (/ (+ padded-bits padding-bits) 6))

252

(last-line-len (if (plusp columns)

253

(- padded-length (* columns

254

(truncate

255

                                                    padded-length columns)))

256

0))

257

(num-lines (if (plusp columns)

258

(truncate (+ padded-length (1- columns)) columns)

259

0))

260

(num-breaks (if (plusp num-lines)

261

(1- num-lines)

262

0))

263

(strlen (+ padded-length num-breaks))

264

(last-char (1- strlen))

265

(str (make-string strlen))

266

(col (if (zerop last-line-len)

267

columns

268

last-line-len)))

269

(declare (fixnum padded-length num-lines col last-char

270

padding-chars last-line-len))

271

(unless (plusp columns)

272

(setq col -1)) ;; set to flag to optimize in loop

273

274

(dotimes (i padding-chars)

275

(declare (fixnum i))

276

(setf (schar str (the fixnum (- last-char i))) pad))

277

278

(do* ((strpos (- last-char padding-chars) (1- strpos))

279

(int (ash input (/ padding-bits 3))))

280

((minusp strpos)

281

str)

282

(declare (fixnum strpos) (integer int))

283

(cond

284

((zerop col)

285

(setf (schar str strpos) #\Newline)

286

(setq col columns))

287

(t

288

(setf (schar str strpos)

289

(schar encode-table (the fixnum (logand int #x3f))))

290

(setq int (ash int -6))

291

(decf col)))))))

292

293

(defun integer-to-base64-stream (input stream &key (uri nil) (columns 0))

294

"Encode an integer to base64 format."

295

(declare (integer input)

296

(fixnum columns)

297

(optimize (speed 3) (space 0) (safety 1)))

298

(let ((pad (if uri *uri-pad-char* *pad-char*))

299

(encode-table (if uri *uri-encode-table* *encode-table*)))

300

(declare (simple-string encode-table)

301

(character pad))

302

(let* ((input-bits (integer-length input))

303

(byte-bits (round-next-multiple input-bits 8))

304

(padded-bits (round-next-multiple byte-bits 6))

305

(remainder-padding (mod padded-bits 24))

306

(padding-bits (if (zerop remainder-padding)

307

0

308

(- 24 remainder-padding)))

309

(padding-chars (/ padding-bits 6))

310

(padded-length (/ (+ padded-bits padding-bits) 6))

311

(strlen padded-length)

312

(nonpad-chars (- strlen padding-chars))

313

(last-nonpad-char (1- nonpad-chars))

314

(str (make-string strlen)))

315

(declare (fixnum padded-length last-nonpad-char))

316

(do* ((strpos 0 (the fixnum (1+ strpos)))

317

(int (ash input (/ padding-bits 3)) (ash int -6))

318

(6bit-value (the fixnum (logand int #x3f))

319

(the fixnum (logand int #x3f))))

320

((= strpos nonpad-chars)

321

(let ((col 0))

322

(declare (fixnum col))

323

(dotimes (i nonpad-chars)

324

(declare (fixnum i))

325

(write-char (schar str i) stream)

326

(when (plusp columns)

327

(incf col)

328

(when (= col columns)

329

(write-char #\Newline stream)

330

(setq col 0))))

331

(dotimes (ipad padding-chars)

332

(declare (fixnum ipad))

333

(write-char pad stream)

334

(when (plusp columns)

335

(incf col)

336

(when (= col columns)

337

(write-char #\Newline stream)

338

(setq col 0)))))

339

stream)

340

(declare (fixnum 6bit-value strpos)

341

(integer int))

342

(setf (schar str (- last-nonpad-char strpos))

343

(schar encode-table 6bit-value))

344

))))

345

346

(define-condition base64-error (error)

347

((input

348

:initarg :input

349

:reader base64-error-input)

350

(position

351

:initarg :position

352

:reader base64-error-position

353

:type unsigned-byte)))

354

355

(define-condition bad-base64-character (base64-error)

356

((code :initarg :code :reader bad-base64-character-code))

357

(:report (lambda (condition stream)

358

(format stream "Bad character ~S at index ~D of ~S"

359

(code-char (bad-base64-character-code condition))

360

(base64-error-position condition)

361

(base64-error-input condition)))))

362

363

(define-condition incomplete-base64-data (base64-error)

364

()

365

(:report (lambda (condition stream)

366

(format stream "Unexpected end of Base64 data at index ~D of ~S"

367

(base64-error-position condition)

368

(base64-error-input condition)))))

369

370

(deftype array-index (&optional (length array-dimension-limit))

371

`(integer 0 (,length)))

372

373

(deftype array-length (&optional (length array-dimension-limit))

374

`(integer 0 ,length))

375

376

(deftype character-code ()

377

`(integer 0 (,char-code-limit)))

378

379

(defmacro etypecase/unroll ((var &rest types) &body body)

380

#+sbcl `(etypecase ,var

381

,@(loop for type in types

382

collect `(,type ,@body)))

383

#-sbcl `(locally

384

(declare (type (or ,@types) ,var))

385

,@body))

386

387

(defmacro let/typed ((&rest vars) &body body)

388

`(let ,(loop for (var value) in vars

389

collect (list var value))

390

(declare ,@(loop for (var nil type) in vars

391

when type

392

collect (list 'type type var)))

393

,@body))

394

395

(defmacro define-base64-decoder (hose sink)

396

`(defun ,(intern (format nil "~A-~A-~A-~A" '#:base64 hose '#:to sink))

397

(input &key (table +decode-table+)

398

(uri nil)

399

,@(when (eq sink :stream) `(stream))

400

(whitespace :ignore))

401

,(format nil "~

402

Decode Base64 ~(~A~) to ~(~A~).

403

404

TABLE is the decode table to use. Two decode tables are provided:

405

+DECODE-TABLE+ (used by default) and +URI-DECODE-TABLE+. See

406

MAKE-DECODE-TABLE.

407

408

For backwards-compatibility the URI parameter is supported. If it is

409

true, then +URI-DECODE-TABLE+ is used, and the value for TABLE

410

parameter is ignored.

411

412

WHITESPACE can be one of:

413

414

:ignore - Whitespace characters are ignored (default).

415

:signal - Signal a BAD-BASE64-CHARACTER condition using SIGNAL.

416

:error - Signal a BAD-BASE64-CHARACTER condition using ERROR."

417

hose sink)

418

(declare (optimize (speed 3) (safety 1))

419

(type decode-table table)

420

(type ,(ecase hose

421

(:stream 'stream)

422

(:string 'string))

423

input))

424

(let/typed ((decode-table (if uri +uri-decode-table+ table)

425

decode-table)

426

,@(ecase sink

427

(:stream)

428

(:octet-vector

429

(ecase hose

430

(:stream

431

`((result (make-array 1024

432

                                                :element-type '(unsigned-byte 8)

433

:adjustable t

434

:fill-pointer 0)

435

(array (unsigned-byte 8) (*)))))

436

(:string

437

`((result (make-array (* 3 (ceiling (length input) 4))

438

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

439

(simple-array (unsigned-byte 8) (*)))

440

(rpos 0 array-index)))))

441

(:string

442

(case hose

443

(:stream

444

`((result (make-array 1024

445

                                                :element-type 'character

446

:adjustable t

447

:fill-pointer 0)

448

(array character (*)))))

449

(:string

450

`((result (make-array (* 3 (ceiling (length input) 4))

451

                                                :element-type 'character)

452

(simple-array character (*)))

453

(rpos 0 array-index)))))

454

(:integer

455

`((result 0 unsigned-byte)))))

456

(flet ((bad-char (pos code &optional (action :error))

457

(let ((args (list 'bad-base64-character

458

:input input

459

:position pos

460

:code code)))

461

(ecase action

462

(:error

463

(apply #'error args))

464

(:cerror

465

(apply #'cerror "Ignore the error and continue." args))

466

(:signal

467

(apply #'signal args)))))

468

(incomplete-input (pos)

469

(error 'incomplete-base64-data :input input :position pos)))

470

,(let ((body

471

`(let/typed ((ipos 0 array-index)

472

(bitstore 0 (unsigned-byte 24))

473

(bitcount 0 (integer 0 14))

474

(svalue -1 (signed-byte 8))

475

(padchar 0 (integer 0 3))

476

(code 0 fixnum))

477

(loop

478

,@(ecase hose

479

(:string

480

`((if (< ipos length)

481

                                      (setq code (char-code (aref input ipos)))

482

(return))))

483

(:stream

484

`((let ((char (read-char input nil nil)))

485

(if char

486

(setq code (char-code char))

487

(return))))))

488

(cond

489

((or (< 127 code)

490

(= -1 (setq svalue (aref decode-table code))))

491

(bad-char ipos code))

492

((= -2 svalue)

493

(cond ((<= (incf padchar) 2)

494

(unless (<= 2 bitcount)

495

(bad-char ipos code))

496

(decf bitcount 2))

497

(t

498

(bad-char ipos code))))

499

((= -3 svalue)

500

(ecase whitespace

501

(:ignore

502

;; Do nothing.

503

)

504

(:error

505

(bad-char ipos code :error))

506

(:signal

507

(bad-char ipos code :signal))))

508

((not (zerop padchar))

509

(bad-char ipos code))

510

(t

511

(setf bitstore (logior (the (unsigned-byte 24)

512

                                                          (ash bitstore 6))

513

svalue))

514

(incf bitcount 6)

515

(when (>= bitcount 8)

516

(decf bitcount 8)

517

(let ((byte (logand (the (unsigned-byte 24)

518

                                                         (ash bitstore (- bitcount)))

519

#xFF)))

520

(declare (type (unsigned-byte 8) byte))

521

,@(ecase sink

522

(:octet-vector

523

(ecase hose

524

(:string

525

`((setf (aref result rpos) byte)

526

(incf rpos)))

527

(:stream

528

                                          `((vector-push-extend byte result)))))

529

(:string

530

(ecase hose

531

(:string

532

`((setf (schar result rpos)

533

(code-char byte))

534

(incf rpos)))

535

(:stream

536

                                          `((vector-push-extend (code-char byte)

537

                                                                result)))))

538

(:integer

539

`((setq result

540

                                               (logior (ash result 8) byte))))

541

(:stream

542

                                       '((write-char (code-char byte) stream)))))

543

(setf bitstore (logand bitstore #xFF)))))

544

(incf ipos))

545

(unless (zerop bitcount)

546

(incomplete-input ipos))

547

,(ecase sink

548

((:string :octet-vector)

549

(ecase hose

550

(:string

551

`(if (= rpos (length result))

552

result

553

(subseq result 0 rpos)))

554

(:stream

555

`(copy-seq result))))

556

(:integer

557

'result)

558

(:stream

559

'stream)))))

560

(ecase hose

561

(:string

562

`(let ((length (length input)))

563

(declare (type array-length length))

564

(etypecase/unroll (input simple-base-string

565

simple-string

566

string)

567

,body)))

568

(:stream

569

body)))))))

570

571

(define-base64-decoder :string :octet-vector)

572

(define-base64-decoder :string :string)

573

(define-base64-decoder :string :integer)

574

(define-base64-decoder :string :stream)

575

576

(define-base64-decoder :stream :octet-vector)

577

(define-base64-decoder :stream :string)

578

(define-base64-decoder :stream :integer)

579

(define-base64-decoder :stream :stream)

580

581

;; input-mode can be :string or :stream

582

;; input-format can be :character or :octet-vector