Commit e7c25e03 authored by Max Rottenkolber's avatar Max Rottenkolber
Browse files

Major rewrite, kept test suite.

parent e41f9da1
(in-package #:asdf)
;;;; System definition for CL-RFC2047.
(defpackage cl-rfc2047-asd
(:use :cl :asdf))
(in-package :cl-rfc2047-asd)
(defsystem cl-rfc2047
:description "Support for rfc-2047 de-/encoding"
:version "0.2"
:description "Implemntation of RFC2047."
:version "0.3"
:author "Christian Haselbach"
:license "MIT"
:components ((:file "package")
(:file "cl-rfc2047" :depends-on ("package")))
:depends-on (:cl-base64 :flexi-streams :cl-ppcre))
(:file "constants" :depends-on ("package"))
(:file "encode" :depends-on ("package"
"constants"))
(:file "decode" :depends-on ("package"
"constants")))
:depends-on (:cl-base64 :babel))
(in-package :cl-rfc2047)
(eval-when (:compile-toplevel)
(defconstant +crlfsp+
(concatenate 'string
(string #\return) (string #\linefeed) (string #\space))
"The character sequence <CRLFSP> which seperates the lines of multi
line fields.")
(defconstant +decoded-line-regexp+
"=\\?([a-zA-Z0-9-]+)\\?([qQbB])\\?([^ ?]+)\\?="
"The regular expression that matches a single encoded word."))
(defun char-max-len (charset)
"returns the maximum number of bytes a character uses in the given
charset and as second value a boolean denoting whether the length is fixed.
Throws an error if the charset is unknown."
(case charset
(:utf-8 (values 4 nil))
(:utf-16 (values 4 nil))
(:ISO-8859-1 (values 1 t))
(:ISO-8859-2 (values 1 t))
(:ISO-8859-3 (values 1 t))
(:ISO-8859-4 (values 1 t))
(:ISO-8859-5 (values 1 t))
(:ISO-8859-6 (values 1 t))
(:ISO-8859-7 (values 1 t))
(:ISO-8859-8 (values 1 t))
(:ISO-8859-9 (values 1 t))
(:ISO-8859-10 (values 1 t))
(:ISO-8859-11 (values 1 t))
(:ISO-8859-12 (values 1 t))
(:ISO-8859-13 (values 1 t))
(:ISO-8859-14 (values 1 t))
(:ISO-8859-15 (values 1 t))
(:ISO-8859-16 (values 1 t))
(:US-ASCII (values 1 t))
(:KOI8-R (values 1 t))
(otherwise (error "charset ~A unknown" charset))))
(defun direct-q-p (c)
"Whether a character can be used directly in Q encoding."
(or (<= (char-code #\a) c (char-code #\z))
(<= (char-code #\A) c (char-code #\Z))
(<= (char-code #\0) c (char-code #\9))))
(defun map-to-external-format (name)
"Maps a character encoding name to the internal symbol.
Throws an error if the character encoding is not known."
(make-external-format
(cond
((string-equal name "UTF-8") :UTF-8)
((string-equal name "ISO-8859-1") :ISO-8859-1)
((string-equal name "ISO-8859-2") :ISO-8859-2)
((string-equal name "ISO-8859-3") :ISO-8859-3)
((string-equal name "ISO-8859-4") :ISO-8859-4)
((string-equal name "ISO-8859-5") :ISO-8859-5)
((string-equal name "ISO-8859-6") :ISO-8859-6)
((string-equal name "ISO-8859-7") :ISO-8859-7)
((string-equal name "ISO-8859-8") :ISO-8859-8)
((string-equal name "ISO-8859-9") :ISO-8859-9)
((string-equal name "ISO-8859-10") :ISO-8859-10)
((string-equal name "ISO-8859-11") :ISO-8859-11)
((string-equal name "ISO-8859-12") :ISO-8859-12)
((string-equal name "ISO-8859-13") :ISO-8859-13)
((string-equal name "ISO-8859-14") :ISO-8859-14)
((string-equal name "ISO-8859-15") :ISO-8859-15)
((string-equal name "ISO-8859-16") :ISO-8859-16)
((string-equal name "US-ASCII") :US-ASCII)
((string-equal name "KOI8-R") :KOI8-R)
(t (error "charset ~A unknown" name)))))
(defun encode (str &optional &key (encoding :b) (charset :utf-8))
"encodes the string using the given encoding and character set"
(let ((slen (length str))
(wlen (floor (+ 75 -8 (- (length (symbol-name charset))))
(char-max-len charset)))
(ext-format (make-external-format charset))
(stream (make-string-output-stream)))
(labels
((b-enc (i n)
(if (>= i slen)
n
(let* ((j (min slen (+ i (* 4 (ceiling wlen 5)))))
(substr (subseq str i j))
(octets (string-to-octets substr
:external-format ext-format))
(b64str (usb8-array-to-base64-string octets)))
(unless (zerop n) (princ +crlfsp+ stream))
(format stream "=?~A?~A?~A?=" charset encoding b64str)
(b-enc j (1+ n)))))
(q-enc* (i len octets)
(if (or (>= i slen) (>= len wlen))
i
(let ((c (elt octets i)))
(if (direct-q-p c)
(progn
(princ (code-char c) stream)
(q-enc* (1+ i) (1+ len) octets))
(progn
(if (>= (+ len 3) wlen)
i
(progn
(format stream "=~2,'0,X" c)
(q-enc* (1+ i) (+ len 3) octets))))))))
(q-enc (i n octets)
(if (>= i slen)
n
(progn
(unless (zerop n) (princ +crlfsp+ stream))
(format stream "=?~A?~A?" charset encoding)
(let ((i* (q-enc* i 0 octets)))
(princ "?=" stream)
(q-enc i* (1+ n) octets))))))
(case encoding
(:b (b-enc 0 0))
(:q (if (= (char-max-len charset) 1)
(q-enc 0 0 (string-to-octets str :external-format ext-format))
(error
"can only use q encoding on 1 byte charset encodings")))
(otherwise (error "encoding ~A unknown" encoding)))
(get-output-stream-string stream))))
(defun decode-q-to-octets (str)
"decodes q encoded strings to octet arrays"
(let* ((len (length str))
(octets (make-array len :fill-pointer 0 :adjustable t)))
(labels
((q-loop (i)
(when (< i len)
(let ((c (elt str i)))
(if (char= c #\=)
(progn
(vector-push-extend
(parse-integer str :start(+ i 1) :end (+ i 3) :radix 16)
octets)
(q-loop (+ i 3)))
(progn
(vector-push-extend
(if (char= c #\_) 32 (char-code c))
octets)
(q-loop (+ i 1))))))))
(q-loop 0)
octets)))
(defun decode-one-word (str)
"Decodes a single encoded word. Encodings can consist of multiple words,
seperated by <CRLFSP>"
(multiple-value-bind (start end reg-starts reg-ends)
(ppcre:scan +decoded-line-regexp+ str)
(declare (ignore end))
(if (null start)
(error "Not a valid encoded word ~A" str)
(let ((charset (subseq str (elt reg-starts 0) (elt reg-ends 0)))
(encoding (subseq str (elt reg-starts 1) (elt reg-ends 1)))
(code (subseq str (elt reg-starts 2) (elt reg-ends 2))))
(cond
((string-equal encoding "b")
(octets-to-string
(base64-string-to-usb8-array code)
:external-format (map-to-external-format charset)))
((string-equal encoding "q")
(octets-to-string
(decode-q-to-octets code)
:external-format (map-to-external-format charset)))
(t (error "unknown encoding ~A" encoding)))))))
(defun decode (str &key (start 0) (end (length str)))
"Decodes an encoded string and returns the result.
Start and end can be defined if only a part of the sring shell be decoded."
(loop
:with stream = (make-string-output-stream)
:for word :in (ppcre:split +crlfsp+ str :start start :end end)
:do (princ (decode-one-word word) stream)
:finally (return (get-output-stream-string stream))))
(defun decode* (str &key (start 0) (end (length str)))
"Decodes a mixed string, i.e., a string that may contain encoded and
unencoded words."
(loop
:with stream = (make-string-output-stream)
:for x = 0 :then end
:for (estart eend)
:on (ppcre:all-matches #.(concatenate
'string
+decoded-line-regexp+
"(" +crlfsp+ +decoded-line-regexp+ ")*")
str :start start :end end)
:by #'cddr
:unless (= x estart) :do (princ (subseq str x estart) stream)
:do (princ (decode str :start estart :end eend) stream)
:finally (let ((eend* (if (null eend) 0 eend)))
(unless (= eend* end)
(princ (subseq str eend* end) stream))
(return (get-output-stream-string stream)))))
;;;; Cl-RFC2047 constants.
(in-package :cl-rfc2047)
(defparameter *encoded-word-length* 75
"Maximum length of an encoded word.")
(defparameter *encoded-word-length-overhead* 7
"Number of syntax overhead characters for encoded words.")
(defparameter *crlfsp* (format nil "~a~a " #\Cr #\Lf)
"<CRLFSP>")
(defparameter *ascii-boundary* 127
"ASCII boundary.")
(defparameter *ascii-space* 32
"ASCII space character code.")
(defparameter *ascii-equals* 61
"ASCII equals sign character code.")
(defparameter *ascii-question-mark* 63
"ASCII question mark character code.")
(defparameter *ascii-underscore* 95
"ASCII underscore character code.")
(defparameter *underscore-value*
(make-array 1 :element-type '(unsigned-byte 8)
:initial-element #x20)
"RFC2047 mandaed value for underscore character in q encoded strings.")
;;;; RFC2037 decoding.
(in-package :cl-rfc2047)
(defun intern* (string)
"Intern STRING upcased in KEYWORD package."
(intern (string-upcase string) :keyword))
(defun parse-encoded-word (encoded-word)
"Parse encoding, charset and encoded string of ENCODED-WORD."
(let* ((charset-start 2)
(charset-end (position #\? encoded-word :start charset-start))
(encoding-start (1+ charset-end))
(encoding-end (1+ encoding-start))
(encoded-string-start (1+ encoding-end))
(encoded-string-end (- (length encoded-word) 2)))
(values
(intern* (subseq encoded-word encoding-start encoding-end))
(intern* (subseq encoded-word charset-start charset-end))
(subseq encoded-word encoded-string-start encoded-string-end))))
(defun decode-bytes (encoded-bytes charset)
"Decode ENCODED-BYTES according to CHARSET."
(let ((length (length encoded-bytes)))
(octets-to-string
(coerce (loop for i = 1 then (+ i 3) while (< i length)
collect (parse-integer encoded-bytes
:start i
:end (+ i 2)
:radix 16))
'(vector (unsigned-byte 8)))
:encoding charset)))
(defun write-decoded-underscore-value (charset stream)
"Write decoded *UNDERSCORE-VALUE* to STREAM according to CHARSET."
(write-string (octets-to-string *underscore-value* :encoding charset)
stream))
(defun q-decode (encoded-string charset)
"Decode ENCODED-STRING according to CHARSET."
(flet ((token-p (char)
(or (char= #\= char)
(char= #\_ char)))
(encoded-to (from)
(loop for i = from then (+ i 3)
while (< i (length encoded-string))
unless (char= #\= (aref encoded-string i))
return i)))
(with-output-to-string (out)
(loop for start = 0 then to
for from = (position-if #'token-p encoded-string
:start start)
for token = (when from
(aref encoded-string from))
for to = (case token
(#\= (encoded-to from))
(#\_ (1+ from)))
do (write-string encoded-string out :start start :end from)
when token
do (ecase token
(#\= (write-string
(decode-bytes (subseq encoded-string from to)
charset)
out))
(#\_ (write-decoded-underscore-value charset out)))
while to))))
(defun decode-word (encoded-word)
"Decode ENCODED-WORD."
(multiple-value-bind (encoding charset encoded-string)
(parse-encoded-word encoded-word)
(case encoding
(:b (octets-to-string (base64-string-to-usb8-array encoded-string)
:encoding charset))
(:q (q-decode encoded-string charset)))))
(defun decode (string &key (start 0) end)
"Decode encoded word in STRING from START to END."
(decode-word (subseq string start end)))
(defun crlfsp-p (string start end)
"Predicate to test if STRING equals to *CRLFSP* from START to END."
(unless (> end (length string))
(string= *crlfsp* string :start2 start :end2 end)))
(defun decoded-word-to (string from)
"Find end of decoded word in STRING starting at FROM."
(let* ((?1 (position #\? string :start from))
(?2 (position #\? string :start (1+ ?1)))
(?3 (position #\? string :start (1+ ?2))))
(+ 2 (search "?=" string :start2 (1+ ?3)))))
(defun decode-word* (string)
"Decode mixed STRING."
(with-output-to-string (out)
(loop for start = 0 then (if (crlfsp-p string to (+ to 3))
(+ to 3)
to)
for from = (position #\= string :start start)
for to = (when from (decoded-word-to string from))
do (write-string (subseq string start from) out)
when from
do (write-string (decode string :start from :end to) out)
while (and from to))))
(defun decode* (string &key (start 0) end)
"Decode mixed STRING (possibly containing encoded as well as unencoded
words) from START to END."
(decode-word* (subseq string start end)))
+ Add {BLACKLISTED-CHARS} parameter to {ENCODE}.
\ No newline at end of file
;;;; RFC2047 encoding.
(in-package :cl-rfc2047)
(defun encoded-word (encoding charset string)
"Return encoded word for ENCODING, CHARSET and STRING."
(format nil "=?~a?~a?~a?="
(symbol-name charset)
(symbol-name encoding)
string))
(defun encoded-words (encoding charset strings)
"Return encoded words for ENCODING, CHARSET and STRINGS."
(format nil (format nil "~~{~~a~~^~a~~}" *crlfsp*)
(loop for string in strings
collect (encoded-word encoding charset string))))
(defun encoded-word-content-length (charset)
"Return maximum length of encoded word contents for CHARSET."
(- *encoded-word-length* (+ *encoded-word-length-overhead*
(length (symbol-name charset)))))
(defun limited-words (pieces length word-type)
"Return list of words no longer than LENGTH concatenated from PIECES
destructively."
(flet ((next-word ()
(loop for count = 0 then (+ count (length piece))
for piece = (car pieces)
while (and piece
(<= (+ count (length piece))
length))
collect (pop pieces))))
(loop for word = (next-word)
while word collect (apply #'concatenate word-type word))))
(defun string-to-grouped-bytes (string charset)
"Return list of byte vectors for STRING using CHARSET."
(loop for i from 0 to (1- (length string))
collect (string-to-octets (subseq string i (1+ i))
:encoding charset)))
(defun encoded-word-content-bytes (charset)
"Return number of maximum bytes per b-encoded word using CHARSET."
(floor (* (encoded-word-content-length charset) 0.7))) ; magic number
(defun b-split (string charset)
"Return STRING split up in parts for b-encoding according to CHARSET."
(limited-words (string-to-grouped-bytes string charset)
(encoded-word-content-bytes charset)
'(vector (unsigned-byte 8))))
(defun b-encode (string charset)
"Return list of base64 encoded words for STRING using CHARSET."
(loop for buffer in (b-split string charset)
collect (usb8-array-to-base64-string buffer)))
(defun char-utf-8 (character)
"Return UTF-8 buffer for CHARACTER."
(string-to-octets (make-string 1 :initial-element character)
:encoding :utf-8))
(defun q-encode-p (character)
"Predicate to test if CHARACTER needs to be q-encoded."
(let ((code (aref (char-utf-8 character) 0)))
(or (> code *ascii-boundary*)
(= code *ascii-space*)
(= code *ascii-equals*)
(= code *ascii-question-mark*)
(= code *ascii-underscore*))))
(defun q-encode-string (string charset)
"Return q encoded STRING using CHARSET."
(with-output-to-string (out)
(loop for character across string
do (if (q-encode-p character)
(loop for byte across (string-to-octets
string :encoding charset)
do (format out "=~2,'0,X" byte))
(write-char character out)))))
(defun q-encode-characters (string charset)
"Return list of q encoded characters for STRING using CHARSET."
(loop for i from 0 to (1- (length string))
collect (q-encode-string (subseq string i (1+ i)) charset)))
(defun q-encode (string charset)
"Return list of q encoded words for STRING using CHARSET."
(limited-words (q-encode-characters string charset)
(encoded-word-content-length charset)
'string))
(defun encode (string &key (encoding :b) (charset :utf-8))
"Return encoded STRING using ENCODING and CHARSET."
(encoded-words encoding charset (ecase encoding
(:b (b-encode string charset))
(:q (q-encode string charset)))))
(defpackage :cl-rfc2047
(:use :common-lisp :flexi-streams :cl-base64)
(:export encode decode decode*))
\ No newline at end of file
;;;; Package definition for Cl-RFC2047
(defpackage cl-rfc2047
(:documentation "Implmentation of RFC2047.")
(:use :cl
:babel
:cl-base64)
(:export :encode
:decode
:decode*))
(in-package #:asdf)
;;;; System definition for CL-RFC2047-TEST
(defsystem klatschbase
(defpackage cl-rfc2047-test-asd
(:use :cl :asdf))
(in-package :cl-rfc2047-test-asd)
(defsystem cl-rfc2047-test
:description "Testpackage for cl-rfc2047"
:version "0.2"
:author "Christian Haselbach"
:license "MIT"
:components ((:file "package")
(:file "cl-rfc2047-test" :depends-on ("package")))
:depends-on (:cl-rfc2047 :lift))
:depends-on (:cl-rfc2047 :cl-ppcre :lift))
......@@ -8,39 +8,51 @@
(deftestsuite encode-tests () ())
(defun ensure-encoding (original encoded)
(loop
:for word :in (cl-ppcre:split cl-rfc2047::*crlfsp* encoded)
:do (ensure (<= (length word) 75)
:report "length (~A) must not be larger than 75"
:arguments ((length word)))
(ensure (string= original (decode encoded))
:report "~A must be equal to ~A"
:arguments (original (decode encoded)))))
(loop for word in (cl-ppcre:split cl-rfc2047::*crlfsp* encoded) do
(ensure (<= (length word) 75)
:report "length (~A) must not be larger than 75"
:arguments ((length word)))
(ensure (string= original (decode* encoded))
:report "~A must be equal to ~A"
:arguments (original (decode* encoded)))))
(defun ensure-encodings (string)
(ensure-encoding string (encode string :encoding :b))
(ensure-encoding string (encode string :encoding :q)))
(addtest encode-test
(loop
:for word :in *ascii-phrases*
:do (ensure-encoding word (encode word))))
(loop for word in *ascii-phrases*
do (ensure-encodings word)))
(defun random-string (length)
(let ((string (make-string length)))
(loop for i from 0 to (1- length)
do (setf (aref string i) (code-char (random 1000))))
string))
(addtest encode-random-test
(loop for i from 0 to 300
do (ensure-encodings (random-string i))))
(addtest decode-known-encodings-test
(loop
:for (encoded decoded)
:in '(("=?US-ASCII?Q?foo_bar=20baz?=" "foo bar baz")
("=?ISO-8859-1?Q?n=e4n=F6n=fC?=" "nänönü")
("=?uTf-8?b?Zm9vIGJhciBiYXo=?=" "foo bar baz"))
:do (ensure (string= decoded (decode encoded)))))
(loop for (encoded decoded)
in '(("=?US-ASCII?Q?foo_bar=20baz?=" "foo bar baz")
("=?ISO-8859-1?Q?n=e4n=F6n=fC?=" "nänönü")
("=?uTf-8?b?Zm9vIGJhciBiYXo=?=" "foo bar baz"))
do (ensure (string= decoded (decode encoded)))))
(addtest decode*-test
(loop
:for (encoded decoded)
:in `(("=?US-ASCII?Q?foo_bar=20baz?="
"foo bar baz")
("some =?US-ASCII?Q?foo_bar=20baz?=bla"
"some foo bar bazbla")
(,(cl-rfc2047::string+ "some=?uTf-8?b?Zm9v?=" cl-rfc2047::*crlfsp*
"=?uTf-8?b?YmF6?=bar")
"somefoobazbar")
("foo" "foo"))
:for result = (decode* encoded)
:do (ensure (string= decoded result)
:report "expected ~A, got ~A" :arguments (decoded result))))
\ No newline at end of file
(loop for (encoded decoded)
in `(("=?US-ASCII?Q?foo_bar=20baz?="
"foo bar baz")
("some =?US-ASCII?Q?foo_bar=20baz?=bla"
"some foo bar bazbla")
(,(concatenate 'string "some=?uTf-8?b?Zm9v?="
cl-rfc2047::*crlfsp*
"=?uTf-8?b?YmF6?=bar")
"somefoobazbar")
("foo" "foo"))
for result = (decode* encoded)
do (ensure (string= decoded result)
:report "expected ~A, got ~A"
:arguments (decoded result))))
\ No newline at end of file
(defpackage :cl-rfc2047-test
(:use :common-lisp :cl-rfc2047))
(:use :common-lisp :cl-rfc2047 :lift))
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment