about summary refs log blame commit diff
path: root/third_party/lisp/mime4cl/endec.lisp
blob: f63eb3c22e1d91fd29024a8314691e1653957c69 (plain) (tree)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683










































































































































































































































































































































































































































































































































































































































































































                                                                                                          
;;;  endec.lisp --- encoder/decoder functions

;;;  Copyright (C) 2005-2008, 2010 by Walter C. Pelissero

;;;  Author: Walter C. Pelissero <walter@pelissero.de>
;;;  Project: mime4cl

;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Lesser General Public License
;;; as published by the Free Software Foundation; either version 2.1
;;; of the License, or (at your option) any later version.
;;; This library is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;; Lesser General Public License for more details.
;;; You should have received a copy of the GNU Lesser General Public
;;; License along with this library; if not, write to the Free
;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
;;; 02111-1307 USA


(in-package :mime4cl)


;; Thank you SBCL for rendering constants totally useless!
(defparameter +base64-encode-table+
  "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/=")

(defparameter +base64-decode-table+
  (let ((da (make-array 256 :element-type '(unsigned-byte 8) :initial-element 65)))
    (dotimes (i 64)
      (setf (aref da (char-code (char +base64-encode-table+ i))) i))
    da))

(declaim (type (simple-array (unsigned-byte 8)) +base64-decode-table+)
	 (type simple-string +base64-encode-table+))

(defvar *base64-line-length* 76
  "Maximum length of the encoded base64 line.  NIL means it can
be of unlimited length \(no line breaks will be done by the
encoding function).")

(defvar *quoted-printable-line-length* 72
  "Maximum length of the encoded quoted printable line.  NIL
means it can be of unlimited length \(no line breaks will be done
by the encoding function).")

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defclass decoder ()
  ((input-function :initarg :input-function
		   :reader decoder-input-function
		   :type function
		   :documentation
		   "Function is called repeatedly by the decoder methods to get the next character.
It should return a character os NIL (indicating EOF)."))
  (:documentation
   "Abstract base class for decoders."))

(defclass parsing-decoder (decoder)
  ((parser-errors :initform nil
		  :initarg :parser-errors
		  :reader decoder-parser-errors
		  :type boolean))
  (:documentation
   "Abstract base class for decoders that do parsing."))

(defclass encoder ()
  ((output-function :initarg :output-function
		    :reader encoder-output-function
		    :type function
		    :documentation
		    "Function is called repeatedly by the encoder methods to output a character.
It should expect a character as its only argument."))
  (:documentation
   "Abstract base class for encoders."))

(defclass line-encoder (encoder)
  ((column :initform 0
	   :type fixnum)
   (line-length :initarg :line-length
		:initform nil
		:reader encoder-line-length
		:type (or fixnum null)))
  (:documentation
   "Abstract base class for line encoders."))

(defclass 8bit-decoder (decoder)
  ()
  (:documentation
   "Class for decoders that do nothing."))

(defclass 8bit-encoder (encoder)
  ()
  (:documentation
   "Class for encoders that do nothing."))

(defclass 7bit-decoder (decoder)
  ()
  (:documentation
   "Class for decoders that do nothing."))

(defclass 7bit-encoder (encoder)
  ()
  (:documentation
   "Class for encoders that do nothing."))

(defclass byte-decoder (decoder)
  ()
  (:documentation
   "Class for decoders that turns chars to bytes."))

(defclass byte-encoder (encoder)
  ()
  (:documentation
   "Class for encoders that turns bytes to chars."))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defgeneric encoder-write-byte (encoder byte))
(defgeneric encoder-finish-output (encoder))
(defgeneric decoder-read-byte (decoder))

(defmethod encoder-finish-output ((encoder encoder))
  (values))

(defmethod encoder-write-byte ((encoder 8bit-encoder) byte)
  (funcall (slot-value encoder 'output-function)
	   (code-char byte))
  (values))

(defmethod decoder-read-byte ((decoder 8bit-decoder))
  (awhen (funcall (slot-value decoder 'input-function))
    (char-code it)))

(defmethod encoder-write-byte ((encoder 7bit-encoder) byte)
  (funcall (slot-value encoder 'output-function)
	   (code-char (logand #x7F byte)))
  (values))

(defmethod decoder-read-byte ((decoder 7bit-decoder))
  (awhen (funcall (slot-value decoder 'input-function))
    (logand #x7F (char-code it))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun decoder-read-sequence (sequence decoder &key (start 0) (end (length sequence)))
  (declare (optimize (speed 3) (safety 0) (debug 0))
	   (type fixnum start end)
	   (type vector sequence))
  (loop
     for i fixnum from start below end
     for byte = (decoder-read-byte decoder)
     while byte
     do (setf (aref sequence i) byte)
     finally (return i)))

(defun decoder-read-line (decoder)
  (with-output-to-string (str)
    (loop
       for byte = (decoder-read-byte decoder)
       unless byte
       do (return-from decoder-read-line nil)
       do (be c (code-char byte)
	    (cond ((char= c #\return)
		   ;; skip the newline
		   (decoder-read-byte decoder)
		   (return nil))
		  ((char= c #\newline)
		   ;; the #\return was missing
		   (return nil))
		  (t (write-char c str)))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(declaim (inline parse-hex))
(defun parse-hex (c1 c2)
  "Parse two characters as hexadecimal and return their combined
value."
  (declare (optimize (speed 3) (safety 0) (debug 0))
	   (type character c1 c2))
  (flet ((digit-value (char)
	   (or (position char "0123456789ABCDEF")
	       (return-from parse-hex nil))))
    (+ (* 16 (digit-value c1))
       (digit-value c2))))

(defclass quoted-printable-decoder (parsing-decoder)
  ((saved-bytes :initform (make-queue))))

(defmethod decoder-read-byte ((decoder quoted-printable-decoder))
  (declare (optimize (speed 3) (safety 0) (debug 0)))
  (with-slots (input-function saved-bytes parser-errors) decoder
    (declare (type function input-function))
    (labels ((saveb (b)
	       (queue-append saved-bytes b)
	       (values))
	     (save (c)
	       (saveb (char-code c)))
	     (push-next ()
	       (be c (funcall input-function)
		 (declare (type (or null character) c))
		 (cond ((not c))
		       ((or (char= c #\space)
			    (char= c #\tab))
			(save c)
			(push-next))
		       ((char= c #\=)
			(be c1 (funcall input-function)
			  (cond ((not c1)
				 (save #\=))
				((char= c1 #\return)
				 ;; soft line break: skip the next
				 ;; character which we assume to be a
				 ;; newline (pity if it isn't)
				 (funcall input-function)
				 (push-next))
				((char= c1 #\newline)
				 ;; soft line break: the #\return is
				 ;; missing, but we are tolerant
				 (push-next))
				(t
				 ;; hexadecimal sequence: get the 2nd digit
				 (be c2 (funcall input-function)
				   (if c2
				       (aif (parse-hex c1 c2)
					    (saveb it)
					    (if parser-errors
						(error "invalid hex sequence ~A~A" c1 c2)
						(progn
						  (save #\=)
						  (save c1)
						  (save c2))))
				       (progn
					 (save c)
					 (save c1))))))))
		       (t
			(save c))))))
      (or (queue-pop saved-bytes)
	  (progn
	    (push-next)
	    (queue-pop saved-bytes))))))

(defmacro make-encoder-loop (encoder-class input-form output-form)
  (with-gensyms (encoder byte)
    `(loop
	with ,encoder = (make-instance ',encoder-class
				       :output-function #'(lambda (char) ,output-form))
	for ,byte = ,input-form
	while ,byte
	do (encoder-write-byte ,encoder ,byte)
	finally (encoder-finish-output ,encoder))))

(defmacro make-decoder-loop (decoder-class input-form output-form &key parser-errors)
  (with-gensyms (decoder)
    `(loop
	with ,decoder = (make-instance ',decoder-class
				       :input-function #'(lambda () ,input-form)
				       :parser-errors ,parser-errors)
	for byte = (decoder-read-byte ,decoder)
	while byte
	do ,output-form)))

(defun decode-quoted-printable-stream (in out &key parser-errors)
  "Read from stream IN a quoted printable text and write to
binary output OUT the decoded stream of bytes."
  (make-decoder-loop quoted-printable-decoder
		     (read-byte in nil) (write-byte byte out)
		     :parser-errors parser-errors))

(defmacro make-stream-to-sequence-decoder (decoder-class input-form &key parser-errors)
  "Decode the character stream STREAM and return a sequence of bytes."
  (with-gensyms (output-sequence)
    `(be ,output-sequence (make-array 0
				      :element-type '(unsigned-byte 8)
				      :fill-pointer 0
				      :adjustable t)
       (make-decoder-loop ,decoder-class ,input-form
			  (vector-push-extend byte ,output-sequence)
			  :parser-errors ,parser-errors)
       ,output-sequence)))

(defun decode-quoted-printable-stream-to-sequence (stream &key parser-errors)
  "Read from STREAM a quoted printable text and return a vector of
bytes."
  (make-stream-to-sequence-decoder quoted-printable-decoder
    (read-char stream nil)
    :parser-errors parser-errors))

(defun decode-quoted-printable-string (string &key (start 0) (end (length string)) parser-errors)
  "Decode STRING as quoted printable sequence of characters and
return a decoded sequence of bytes."
  (with-input-from-string (in string :start start :end end)
    (decode-quoted-printable-stream-to-sequence in :parser-errors parser-errors)))

(defclass quoted-printable-encoder (line-encoder)
  ((line-length :initform *quoted-printable-line-length*
		:type (or fixnum null))
   (pending-space :initform nil
		  :type boolean)))

(defmethod encoder-write-byte ((encoder quoted-printable-encoder) byte)
  (declare (optimize (speed 3) (safety 0) (debug 0))
	   (type (unsigned-byte 8) byte))
  (with-slots (output-function column pending-space line-length) encoder
    (declare (type function output-function)
	     (type fixnum column)
	     (type (or fixnum null) line-length)
	     (type boolean pending-space))
    (labels ((out (c)
	       (funcall output-function c)
	       (values))
	     (outs (str)
	       (declare (type simple-string str))
	       (loop
		  for c across str
		  do (out c))
	       (values))
	     (out2hex (x)
	       (declare (type fixnum x))
	       (multiple-value-bind (a b) (truncate x 16)
		 (out (digit-char a 16))
		 (out (digit-char b 16)))))
      (cond ((= byte #.(char-code #\newline))
	     (when pending-space
	       (outs "=20")
	       (setf pending-space nil))
	     (out #\newline)
	     (setf column 0))
	    ((= byte #.(char-code #\space))
	     (if pending-space
		 (progn
		   (out #\space)
		   (f++ column))
		 (setf pending-space t)))
	    (t
	     (when pending-space
	       (out #\space)
	       (f++ column)
	       (setf pending-space nil))
	     (cond ((or (< byte 32)
			(= byte #.(char-code #\=))
			(> byte 126))
		    (out #\=)
		    (out2hex byte)
		    (f++ column 3))
		   (t
		    (out (code-char byte))
		    (f++ column)))))
      (when (and line-length
		 (>= column line-length))
	;; soft line break
	(outs #.(coerce '(#\= #\newline) 'string))
	(setf column 0)))))

(defmethod encoder-finish-output ((encoder quoted-printable-encoder))
  (declare (optimize (speed 3) (safety 0) (debug 0)))
  (with-slots (pending-space output-function) encoder
    (declare (type boolean pending-space)
	     (type function output-function))
    (when pending-space
      (flet ((outs (s)
	       (declare (type simple-string s))
	       (loop
		  for c across s
		  do (funcall output-function c))))
	(setf pending-space nil)
	(outs "=20")))))

(defun encode-quoted-printable-stream (in out)
  "Read from IN a stream of bytes and write to OUT a stream of
characters quoted printables encoded."
  (make-encoder-loop quoted-printable-encoder
		     (read-byte in nil)
		     (write-char char out)))

(defun encode-quoted-printable-sequence-to-stream (sequence stream &key (start 0) (end (length sequence)))
  "Encode the sequence of bytes SEQUENCE and write to STREAM a
quoted printable sequence of characters."
  (be i start
    (make-encoder-loop quoted-printable-encoder
     (when (< i end)
       (prog1 (elt sequence i)
	 (f++ i)))
     (write-char char stream))))

(defun encode-quoted-printable-sequence (sequence &key (start 0) (end (length sequence)))
  "Encode the sequence of bytes SEQUENCE into a quoted printable
string and return it."
  (with-output-to-string (out)
    (encode-quoted-printable-sequence-to-stream sequence out :start start :end end)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defclass base64-encoder (line-encoder)
  ((line-length :initform *base64-line-length*)
   (bitstore :initform 0
	     :type fixnum)
   (bytecount :initform 0
	      :type fixnum))
  (:documentation
   "Class for Base64 encoder output streams."))


(eval-when (:load-toplevel :compile-toplevel)
  (unless (> most-positive-fixnum (expt 2 (* 8 3)))))

(macrolet ((with-encoder (encoder &body forms)
	     `(with-slots (bitstore line-length column bytecount output-function) ,encoder
		(declare (type fixnum column)
			 (type fixnum bitstore bytecount)
			 (type (or fixnum null) line-length)
			 (type function output-function))
		(labels ((emitr (i b)
			   (declare (type fixnum i b))
			   (unless (zerop i)
			     (emitr (1- i) (ash b -6)))
			   (emitc
			    (char +base64-encode-table+ (logand b #x3F)))
			   (values))
			 (out (c)
			   (funcall output-function c))
			 (eol ()
			   (progn
			     (out #\return)
			     (out #\newline)))
			 (emitc (char)
			   (out char)
			   (f++ column)
			   (when (and line-length
				      (>= column line-length))
			     (setf column 0)
			     (eol))))
		  (declare (inline out eol emitc)
			   (ignorable (function emitr) (function out) (function eol) (function emitc)))
		  ,@forms))))
  ;; For this function to work correctly, the FIXNUM must be at least
  ;; 24 bits.
  (defmethod encoder-write-byte ((encoder base64-encoder) byte)
    (declare (optimize (speed 3) (safety 0) (debug 0))
	     (type (unsigned-byte 8) byte))
    (with-encoder encoder
      (setf bitstore (logior byte (the fixnum (ash bitstore 8))))
      (f++ bytecount)
      (when (= 3 bytecount)
	(emitr 3 bitstore)
	(setf bitstore 0
	      bytecount 0)))
    (values))

  (defmethod encoder-finish-output ((encoder base64-encoder))
    (with-encoder encoder
      (unless (zerop bytecount)
	(multiple-value-bind (saved6 rest) (truncate (* bytecount 8) 6)
	  (setf bitstore (ash bitstore (- 6 rest)))
	  (emitr saved6 bitstore)
	  (dotimes (x (- 3 saved6))
	    (emitc #\=))))
      (when (and line-length
		 (not (zerop column)))
	(eol)))
    (values)))

(defun encode-base64-stream (in out)
  "Read a byte stream from IN and write to OUT the encoded Base64
character stream."
  (make-encoder-loop base64-encoder (read-byte in nil)
		     (write-char char out)))

(defun encode-base64-sequence-to-stream (sequence stream &key (start 0) (end (length sequence)))
  "Encode the sequence of bytes SEQUENCE and write to STREAM the
Base64 character sequence."
  (be i start
    (make-encoder-loop base64-encoder
		       (when (< i end)
			 (prog1 (elt sequence i)
			   (incf i)))
		       (write-char char stream))))

(defun encode-base64-sequence (sequence &key (start 0) (end (length sequence)))
  "Encode the sequence of bytes SEQUENCE into a Base64 string and
return it."
  (with-output-to-string (out)
    (encode-base64-sequence-to-stream sequence out :start start :end end)))

(defclass base64-decoder (parsing-decoder)
  ((bitstore :initform 0
	     :type fixnum)
   (bytecount :initform 0 :type fixnum))
  (:documentation
   "Class for Base64 decoder input streams."))

(defmethod decoder-read-byte ((decoder base64-decoder))
  (declare (optimize (speed 3) (safety 0) (debug 0)))
  (with-slots (bitstore bytecount input-function) decoder
    (declare (type fixnum bitstore bytecount)
	     (type function input-function))
    (labels ((in6 ()
	       (loop
		  for c = (funcall input-function)
		  when (or (not c) (char= #\= c))
		  do (return-from decoder-read-byte nil)
		  do (be sextet (aref +base64-decode-table+ (char-code c))
		       (unless (= sextet 65) ; ignore unrecognised characters
			 (return sextet)))))
	     (push6 (sextet)
	       (declare (type fixnum sextet))
	       (setf bitstore
		     (logior sextet (the fixnum (ash bitstore 6))))))
      (case bytecount
	(0
	 (setf bitstore (in6))
	 (push6 (in6))
	 (setf bytecount 1)
	 (ash bitstore -4))
	(1
	 (push6 (in6))
	 (setf bytecount 2)
	 (logand #xFF (ash bitstore -2)))
	(2
	 (push6 (in6))
	 (setf bytecount 0)
	 (logand #xFF bitstore))))))

(defun decode-base64-stream (in out &key parser-errors)
  "Read from IN a stream of characters Base64 encoded and write
to OUT a stream of decoded bytes."
  (make-decoder-loop base64-decoder
		     (read-byte in nil) (write-byte byte out)
		     :parser-errors parser-errors))

(defun decode-base64-stream-to-sequence (stream &key parser-errors)
  (make-stream-to-sequence-decoder base64-decoder
				   (read-char stream nil)
				   :parser-errors parser-errors))

(defun decode-base64-string (string &key (start 0) (end (length string)) parser-errors)
  (with-input-from-string (in string :start start :end end)
    (decode-base64-stream-to-sequence in :parser-errors parser-errors)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun dump-stream-binary (in out)
  "Write content of IN character stream to OUT binary stream."
  (loop
     for c = (read-char in nil)
     while c
     do (write-byte (char-code c) out)))

(defun decode-stream (in out encoding &key parser-errors-p)
  (gcase (encoding string-equal)
    (:quoted-printable
     (decode-quoted-printable-stream in out
				     :parser-errors parser-errors-p))
    (:base64
     (decode-base64-stream in out
			   :parser-errors parser-errors-p))
    (otherwise
     (dump-stream-binary in out))))

(defun decode-string (string encoding &key parser-errors-p)
  (gcase (encoding string-equal)
    (:quoted-printable
     (decode-quoted-printable-string string
				     :parser-errors parser-errors-p))
    (:base64
     (decode-base64-string string
			   :parser-errors parser-errors-p))
    (otherwise
     (map '(vector (unsigned-byte 8)) #'char-code string))))

(defun decode-stream-to-sequence (stream encoding &key parser-errors-p)
  (gcase (encoding string-equal)
    (:quoted-printable
     (decode-quoted-printable-stream-to-sequence stream
						 :parser-errors parser-errors-p))
    (:base64
     (decode-base64-stream-to-sequence stream
				       :parser-errors parser-errors-p))
    (otherwise
     (loop
	with output-sequence = (make-array 0 :fill-pointer 0
					   :element-type '(unsigned-byte 8)
					   :adjustable t)
	for c = (read-char stream nil)
	while c
	do (vector-push-extend (char-code c) output-sequence)
	finally (return output-sequence)))))

(defun encode-stream (in out encoding)
  (gcase (encoding string-equal)
    (:quoted-printable
     (encode-quoted-printable-stream in out))
    (:base64
     (encode-base64-stream in out))
    (otherwise
     (loop
	for byte = (read-byte in nil)
	while byte
	do (write-char (code-char byte) out)))))

(defun encode-sequence-to-stream (sequence out encoding)
  (gcase (encoding string-equal)
    (:quoted-printable
     (encode-quoted-printable-sequence-to-stream sequence out))
    (:base64
     (encode-base64-sequence-to-stream sequence out))
    (otherwise
     (loop
	for byte across sequence
	do (write-char (code-char byte) out)))))

(defun encode-sequence (sequence encoding)
  (gcase (encoding string-equal)
    (:quoted-printable
     (encode-quoted-printable-sequence sequence))
    (:base64
     (encode-base64-sequence sequence))
    (otherwise
     (map 'string #'code-char sequence))))

;; This is similar to decode-quoted-printable-string but #\_ is used
;; instead of space
(defun decode-quoted-printable-RFC2047-string (string &key (start 0) (end (length string)))
  "Decode a string encoded according to the quoted printable
method of RFC2047 and return a sequence of bytes."
  (declare (optimize (speed 3) (debug 0) (safety 0))
	   (type simple-string string))
  (loop
     with output-sequence = (make-array (length string)
					:element-type '(unsigned-byte 8)
					:fill-pointer 0)
     for i fixnum from start by 1 below end
     for c = (char string i)
     do (case c
	  (#\=
	   (vector-push-extend (or (parse-hex (char string (1+ i)) (char string (+ 2 i)))
				   ;; the char code was malformed
				   #.(char-code #\?))
			       output-sequence)
	   (f++ i 2))
	  (#\_ (vector-push-extend #.(char-code #\space) output-sequence))
	  (otherwise
	   (vector-push-extend (char-code c) output-sequence)))
       finally (return output-sequence)))

(defun decode-RFC2047-string (encoding string &key (start 0) (end (length string)))
  "Decode STRING according to RFC2047 and return a sequence of
bytes."
  (gcase (encoding string-equal)
    ("Q" (decode-quoted-printable-RFC2047-string string :start start :end end))
    ("B" (decode-base64-string string :start start :end end))
    (t string)))

(defun parse-RFC2047-text (text)
  "Parse the string TEXT according to RFC2047 rules and return a list
of pairs and strings.  The strings are the bits interposed between the
actually encoded text.  The pairs are composed of: a decoded byte
sequence, a charset string indicating the original coding."
  (loop
     with result = '()
     with previous-end = 0
     for start = (search "=?" text :start2 previous-end)
     while start
     for first-? = (position #\? text :start (+ 2 start))
     while first-?
     for second-? = (position #\? text :start (1+ first-?))
     while second-?
     for end = (search "?=" text :start2 (1+ second-?))
     while end
     do (let ((charset (string-upcase (subseq text (+ 2 start) first-?)))
	      (encoding (subseq text (1+ first-?) second-?)))
	  (unless (= previous-end start)
	    (push (subseq text previous-end start)
		  result))
	  (setf previous-end (+ end 2))
	  (push (cons (decode-RFC2047-string encoding text :start (1+ second-?) :end end)
		      charset)
		result))
     finally (unless (= previous-end (length text))
	       (push (subseq text previous-end (length text))
		     result))
       (return (nreverse result))))