mdebray/tvl-depot
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

chore(3p/lisp): import mime4cl source tarball

Browse source 
Used http://wcp.sdf-eu.org/software/mime4cl-20150207T211851.tbz (sha256
5a914669bba7561efe59a4fd0817204c07ad2add98b03ae206ef185ac04affb3).
Importing seems sensible since there's no upstream repo nor has their
been a release since 2015.

This is just an import commit, so the changes made to make it build are
more discoverable as their own commit.

Change-Id: I2ff28c3c7433abdf7857204bc89eaf9edc0b1cbc
Reviewed-on: https://cl.tvl.fyi/c/depot/+/3378
Tested-by: BuildkiteCI
Reviewed-by: grfn <grfn@gws.fyi>
This commit is contained in:
sterni 2021-08-21 15:29:43 +02:00
parent de0f0164d2
commit 901364869c
13 changed files with 3313 additions and 0 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

301
third_party/lisp/mime4cl/address.lisp vendored Normal file
View file

@ -0,0 +1,301 @@
;;; address.lisp --- e-mail address parser
;;; Copyright (C) 2007, 2008, 2009 by Walter C. Pelissero
;;; Author: Walter C. Pelissero <walter@pelissero.de>
;;; Project: mime4cl
#+cmu (ext:file-comment "$Module: address.lisp $")
;;; 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
;;; Although not MIME specific, this parser is often useful together
;;; with the MIME primitives. It should be able to parse the address
;;; syntax described in RFC2822 excluding the obsolete syntax (see
;;; RFC822). Have a look at the test suite to get an idea of what
;;; kind of addresses it can parse.
(in-package :mime4cl)
(defstruct (mailbox (:conc-name mbx-))
description
user
host
domain)
(defstruct (mailbox-group (:conc-name mbxg-))
name
mailboxes)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun write-mailbox-domain-name (addr &optional (stream *standard-output*))
(when (eq :internet (mbx-domain addr))
(write-char #\[ stream))
(write-string (mbx-host addr) stream)
(when (eq :internet (mbx-domain addr))
(write-char #\] stream))
(when (stringp (mbx-domain addr))
(write-char #\. stream)
(write-string (mbx-domain addr) stream)))
(defun write-mailbox-address (addr &optional (stream *standard-output*))
(write-string (mbx-user addr) stream)
(when (mbx-host addr)
(write-char #\@ stream)
(write-mailbox-domain-name addr stream)))
(defmethod mbx-domain-name ((MBX mailbox))
"Return the complete domain name string of MBX, in the form
\"host.domain\"."
(with-output-to-string (out)
(write-mailbox-domain-name mbx out)))
(defmethod mbx-address ((mbx mailbox))
"Return the e-mail address string of MBX, in the form
\"user@host.domain\"."
(with-output-to-string (out)
(write-mailbox-address mbx out)))
(defun write-mailbox (addr &optional (stream *standard-output*))
(awhen (mbx-description addr)
(write it :stream stream :readably t)
(write-string " <" stream))
(write-mailbox-address addr stream)
(awhen (mbx-description addr)
(write-char #\> stream)))
(defun write-mailbox-group (grp &optional (stream *standard-output*))
(write-string (mbxg-name grp) stream)
(write-string ": " stream)
(loop
for mailboxes on (mbxg-mailboxes grp)
for mailbox = (car mailboxes)
do (write-mailbox mailbox stream)
unless (endp (cdr mailboxes))
do (write-string ", " stream))
(write-char #\; stream))
(defmethod print-object ((mbx mailbox) stream)
(if (or *print-readably* *print-escape*)
(call-next-method)
(write-mailbox mbx stream)))
(defmethod print-object ((grp mailbox-group) stream)
(if (or *print-readably* *print-escape*)
(call-next-method)
(write-mailbox-group grp stream)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun parser-make-mailbox (description address-list)
(make-mailbox :description description
:user (car address-list)
:host (cadr address-list)
:domain (when (cddr address-list)
(string-concat (cddr address-list) "."))))
(defun populate-grammar ()
(defrule address-list
:= (+ address ","))
(defrule address
:= mailbox
:= group)
(defrule mailbox
:= display-name? angle-addr comment?
:reduce (parser-make-mailbox (or display-name comment) angle-addr)
:= addr-spec comment?
:reduce (parser-make-mailbox comment addr-spec))
(defrule angle-addr
:= "<" addr-spec ">")
(defrule group
:= display-name ":" mailbox-list ";"
:reduce (make-mailbox-group :name display-name :mailboxes mailbox-list))
(defrule display-name
:= phrase
:reduce (string-concat phrase " "))
(defrule phrase
:= word+)
(defrule word
:= atext
:= string)
(defrule mailbox-list
:= (+ mailbox ","))
(defrule addr-spec
:= local-part "@" domain :reduce (cons local-part domain))
(defrule local-part
:= dot-atom :reduce (string-concat dot-atom ".")
:= string)
(defrule domain
:= dot-atom
:= domain-literal :reduce (list domain-literal :internet))
;; actually, according to the RFC, dot-atoms don't allow spaces in
;; between but these rules do
(defrule dot-atom
:= (+ atom "."))
(defrule atom
:= atext+
:reduce (apply #'concatenate 'string atext)))
(deflazy define-grammar
(let ((*package* #.*package*)
(*compile-print* (when npg::*debug* t)))
(reset-grammar)
(format t "~&creating e-mail address grammar...~%")
(populate-grammar)
(let ((grammar (npg:generate-grammar #'string=)))
(reset-grammar)
(npg:print-grammar-figures grammar)
grammar)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; The lexical analyser
(defstruct cursor
stream
(position 0))
(defun read-delimited-string (stream end-char &key nesting-start-char (escape-char #\\))
(labels ((collect ()
(with-output-to-string (out)
(loop
for c = (read-char stream nil)
while (and c (not (char= c end-char)))
do (cond ((char= c escape-char)
(awhen (read-char stream nil)
(write-char it out)))
((and nesting-start-char
(char= c nesting-start-char))
(write-char nesting-start-char out)
(write-string (collect) out)
(write-char end-char out))
(t (write-char c out)))))))
(collect)))
(defun read-string (cursor)
(make-token :type 'string
:value (read-delimited-string (cursor-stream cursor) #\")
:position (incf (cursor-position cursor))))
(defun read-domain-literal (cursor)
(make-token :type 'domain-literal
:value (read-delimited-string (cursor-stream cursor) #\])
:position (incf (cursor-position cursor))))
(defun read-comment (cursor)
(make-token :type 'comment
:value (read-delimited-string (cursor-stream cursor) #\) :nesting-start-char #\()
:position (incf (cursor-position cursor))))
(declaim (inline atom-component-p))
(defun atom-component-p (c)
(declare (type character c))
(not (find c " ()\"[]@.<>:;,")))
(defun read-atext (first-character cursor)
(be string (with-output-to-string (out)
(write-char first-character out)
(loop
for c = (read-char (cursor-stream cursor) nil)
while (and c (atom-component-p c))
do (write-char c out)
finally (when c
(unread-char c (cursor-stream cursor)))))
(make-token :type 'atext
:value string
:position (incf (cursor-position cursor)))))
(defmethod read-next-tokens ((cursor cursor))
(flet ((make-keyword (c)
(make-token :type 'keyword
:value (string c)
:position (incf (cursor-position cursor)))))
(be in (cursor-stream cursor)
(loop
for c = (read-char in nil)
while c
unless (whitespace-p c)
return (list
(cond ((char= #\( c)
(read-comment cursor))
((char= #\" c)
(read-string cursor))
((char= #\[ c)
(read-domain-literal cursor))
((find c "@.<>:;,")
(make-keyword c))
(t
;; anything else is considered a text atom even
;; though it's just a single character
(read-atext c cursor))))))))
(defun analyse-string (string)
"Return the list of tokens produced by a lexical analysis of
STRING. These are the tokens that would be seen by the parser."
(with-input-from-string (stream string)
(be cursor (make-cursor :stream stream)
(loop
for tokens = (read-next-tokens cursor)
until (endp tokens)
append tokens))))
(defun mailboxes-only (list-of-mailboxes-and-groups)
"Return a flat list of MAILBOX-ADDRESSes from
LIST-OF-MAILBOXES-AND-GROUPS, which is the kind of list returned
by PARSE-ADDRESSES. This turns out to be useful when your
program is not interested in mailbox groups and expects the user
addresses only."
(mapcan #'(lambda (mbx)
(if (typep mbx 'mailbox-group)
(mbxg-mailboxes mbx)
(list mbx)))
list-of-mailboxes-and-groups))
(defun parse-addresses (string &key no-groups)
"Parse STRING and return a list of MAILBOX-ADDRESSes or
MAILBOX-GROUPs. If STRING is unparsable return NIL. If
NO-GROUPS is true, return a flat list of mailboxes throwing away
the group containers, if any."
(be grammar (force define-grammar)
(with-input-from-string (stream string)
(be* cursor (make-cursor :stream stream)
mailboxes (ignore-errors ; ignore parsing errors
(parse grammar 'address-list cursor))
(if no-groups
(mailboxes-only mailboxes)
mailboxes)))))
(defun debug-addresses (string)
"More or less like PARSE-ADDRESSES, but don't ignore parsing errors."
(be grammar (force define-grammar)
(with-input-from-string (stream string)
(be cursor (make-cursor :stream stream)
(parse grammar 'address-list cursor)))))

683
third_party/lisp/mime4cl/endec.lisp vendored Normal file
View file

@ -0,0 +1,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))))

1037
third_party/lisp/mime4cl/mime.lisp vendored Normal file
View file

File diff suppressed because it is too large Load diff

54
third_party/lisp/mime4cl/mime4cl-tests.asd vendored Normal file
View file

@ -0,0 +1,54 @@
;;; mime4cl-tests.asd --- system description for the regression tests
;;; Copyright (C) 2006, 2007, 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
#-(or sbcl cmu)
(warn "This code hasn't been tested on your Lisp system.")
(defpackage :mime4cl-tests-system
(:use :common-lisp :asdf #+asdfa :asdfa)
(:export #:*base-directory*
#:*compilation-epoch*))
(in-package :mime4cl-tests-system)
(defsystem mime4cl-tests
:name "MIME4CL-tests"
:author "Walter C. Pelissero <walter@pelissero.de>"
:maintainer "Walter C. Pelissero <walter@pelissero.de>"
:description "Test suite for the MIME4CL library"
:long-description
"These regression tests require rt.lisp from MIT. It is included."
:licence "LGPL"
:depends-on (:mime4cl)
:components
((:module test
:components
((:file "rt")
(:file "package" :depends-on ("rt"))
(:file "endec" :depends-on ("rt" "package"))
(:file "address" :depends-on ("rt" "package"))
(:file "mime" :depends-on ("rt" "package"))))))
;; when loading this form the regression-test, the package is yet to
;; be loaded so we cannot use rt:do-tests directly or we would get a
;; reader error (unknown package)
(defmethod perform ((o test-op) (c (eql (find-system :mime4cl-tests))))
(or (funcall (intern "DO-TESTS" "REGRESSION-TEST"))
(error "test-op failed")))

53
third_party/lisp/mime4cl/mime4cl.asd vendored Normal file
View file

@ -0,0 +1,53 @@
;;; mime4cl.asd --- system definition
;;; Copyright (C) 2005-2007, 2010 by Walter C. Pelissero
;;; Author: Walter C. Pelissero <walter@pelissero.de>
;;; Project: mime4cl
;;; This program is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU General Public License as
;;; published by the Free Software Foundation; either version 2, or (at
;;; your option) any later version.
;;; This program 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
;;; General Public License for more details.
;;; You should have received a copy of the GNU General Public License
;;; along with this program; see the file COPYING. If not, write to
;;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;;; Boston, MA 02111-1307, USA.
(in-package :cl-user)
#+(and cmu (not gray-streams))
(eval-when (:compile-toplevel :load-toplevel :execute)
(ext:without-package-locks
(load "library:subsystems/gray-streams-library")))
(defpackage :mime4cl-system
(:use :common-lisp :asdf))
(in-package :mime4cl-system)
(defsystem mime4cl
:name "MIME4CL"
:author "Walter C. Pelissero <walter@pelissero.de>"
:maintainer "Walter C. Pelissero <walter@pelissero.de>"
;; :version "0.0"
:description "MIME primitives for Common Lisp"
:long-description
"A collection of Common Lisp primitives to forge and handle
MIME mail contents."
:licence "LGPL"
:depends-on (:npg :sclf)
:components
((:file "package")
(:file "mime" :depends-on ("package" "endec" "streams"))
(:file "endec" :depends-on ("package"))
(:file "streams" :depends-on ("package" "endec"))
(:file "address" :depends-on ("package"))))
(defmethod perform ((o test-op) (c (eql (find-system 'mime4cl))))
(oos 'load-op 'mime4cl-tests)
(oos 'test-op 'mime4cl-tests :force t))

107
third_party/lisp/mime4cl/package.lisp vendored Normal file
View file

@ -0,0 +1,107 @@
;;; package.lisp --- package declaration
;;; Copyright (C) 2005-2007, 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 :cl-user)
(defpackage :mime4cl
(:nicknames :mime)
(:use :common-lisp :npg :sclf
;; for Gray streams
#+cmu :extensions #+sbcl :sb-gray)
;; this is stuff that comes from SCLF and clashes with CMUCL's EXT
;; package
(:shadowing-import-from :sclf
#:process-wait
#:process-alive-p
#:run-program)
(:export #:*lazy-mime-decode*
#:print-mime-part
#:read-mime-message
#:mime-part
#:mime-text
#:mime-binary
#:mime-id
#:mime-image
#:mime-message
#:mime-multipart
#:mime-audio
#:mime-unknown-part
#:get-mime-disposition-parameter
#:get-mime-type-parameter
#:mime-disposition
#:mime-disposition-parameters
#:mime-encoding
#:mime-application
#:mime-video
#:mime-description
#:mime-part-size
#:mime-subtype
#:mime-body
#:mime-body-stream
#:mime-body-length
#:mime-parts
#:mime-part-p
#:mime-type
#:mime-type-string
#:mime-type-parameters
#:mime-message-headers
#:mime=
#:find-mime-part-by-path
#:find-mime-part-by-id
#:encode-mime-part
#:encode-mime-body
#:decode-quoted-printable-stream
#:decode-quoted-printable-string
#:encode-quoted-printable-stream
#:encode-quoted-printable-sequence
#:decode-base64-stream
#:decode-base64-string
#:encode-base64-stream
#:encode-base64-sequence
#:parse-RFC2047-text
#:parse-RFC822-header
#:read-RFC822-headers
#:time-RFC822-string
#:parse-RFC822-date
#:map-parts
#:do-parts
#:apply-on-parts
#:mime-part-file-name
#:mime-text-charset
#:with-input-from-mime-body-stream
;; endec.lisp
#:base64-encoder
#:base64-decoder
#:null-encoder
#:null-decoder
#:byte-encoder
#:byte-decoder
#:quoted-printable-encoder
#:quoted-printable-decoder
#:encoder-write-byte
#:encoder-finish-output
#:decoder-read-byte
#:decoder-read-sequence
#:*base64-line-length*
#:*quoted-printable-line-length*
;; address.lisp
#:parse-addresses #:mailboxes-only
#:mailbox #:mbx-description #:mbx-user #:mbx-host #:mbx-domain #:mbx-domain-name #:mbx-address
#:mailbox-group #:mbxg-name #:mbxg-mailboxes))

366
third_party/lisp/mime4cl/streams.lisp vendored Normal file
View file

@ -0,0 +1,366 @@
;;; eds.lisp --- En/De-coding Streams
;;; Copyright (C) 2012 by Walter C. Pelissero
;;; Author: Walter C. Pelissero <walter@pelissero.de>
;;; Project: mime4cl
#+cmu (ext:file-comment "$Module: eds.lisp")
;;; 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)
#+cmu
(eval-when (:load-toplevel :compile-toplevel :execute)
;; CMUCL doesn't provide the STREAM-FILE-POSITION method in its
;; implementation of Gray streams. We patch it in ourselves.
(defgeneric stream-file-position (stream &optional position))
(defun my-file-position (stream &optional position)
(stream-file-position stream position))
(defvar *original-file-position-function*
(prog1
(symbol-function 'file-position)
(setf (symbol-function 'file-position) (symbol-function 'my-file-position))))
(defmethod stream-file-position (stream &optional position)
(if position
(funcall *original-file-position-function* stream position)
(funcall *original-file-position-function* stream)))
;; oddly CMUCL doesn't seem to provide a default for STREAM-READ-SEQUENCE
(defmacro make-read-sequence (stream-type element-reader)
`(defmethod stream-read-sequence ((stream ,stream-type) seq &optional start end)
(unless start
(setf start 0))
(unless end
(setf end (length seq)))
(loop
for i from start below end
for b = (,element-reader stream)
until (eq b :eof)
do (setf (elt seq i) b)
finally (return i))))
(make-read-sequence fundamental-binary-input-stream stream-read-byte)
(make-read-sequence fundamental-character-input-stream stream-read-char))
(defclass coder-stream-mixin ()
((real-stream :type stream
:initarg :stream
:reader real-stream)
(dont-close :initform nil
:initarg :dont-close)))
(defmethod stream-file-position ((stream coder-stream-mixin) &optional position)
(file-position (slot-value stream 'real-stream) position))
(defclass coder-input-stream-mixin (fundamental-binary-input-stream coder-stream-mixin)
())
(defclass coder-output-stream-mixin (fundamental-binary-output-stream coder-stream-mixin)
())
(defclass quoted-printable-decoder-stream (coder-input-stream-mixin quoted-printable-decoder) ())
(defclass base64-decoder-stream (coder-input-stream-mixin base64-decoder) ())
(defclass 8bit-decoder-stream (coder-input-stream-mixin 8bit-decoder) ())
(defclass quoted-printable-encoder-stream (coder-output-stream-mixin quoted-printable-encoder) ())
(defclass base64-encoder-stream (coder-output-stream-mixin base64-encoder) ())
(defclass 8bit-encoder-stream (coder-output-stream-mixin 8bit-encoder) ())
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defmethod initialize-instance :after ((stream coder-stream-mixin) &key &allow-other-keys)
(unless (slot-boundp stream 'real-stream)
(error "REAL-STREAM is unbound. Must provide a :STREAM argument.")))
(defmethod initialize-instance ((stream coder-output-stream-mixin) &key &allow-other-keys)
(call-next-method)
(unless (slot-boundp stream 'output-function)
(setf (slot-value stream 'output-function)
#'(lambda (char)
(write-char char (slot-value stream 'real-stream))))))
(defmethod initialize-instance ((stream coder-input-stream-mixin) &key &allow-other-keys)
(call-next-method)
(unless (slot-boundp stream 'input-function)
(setf (slot-value stream 'input-function)
#'(lambda ()
(read-char (slot-value stream 'real-stream) nil)))))
(defmethod stream-read-byte ((stream coder-input-stream-mixin))
(or (decoder-read-byte stream)
:eof))
(defmethod stream-write-byte ((stream coder-output-stream-mixin) byte)
(encoder-write-byte stream byte))
(defmethod close ((stream coder-stream-mixin) &key abort)
(with-slots (real-stream dont-close) stream
(unless dont-close
(close real-stream :abort abort))))
(defmethod close ((stream coder-output-stream-mixin) &key abort)
(unless abort
(encoder-finish-output stream))
(call-next-method))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defclass encoder-input-stream (fundamental-character-input-stream coder-stream-mixin)
((encoder)
(buffer-queue :initform (make-queue)))
(:documentation
"This is the base class for encoders with the direction swapped. It
reads from REAL-STREAM a stream of bytes, encodes it and returnes it
in a stream of character."))
(defclass quoted-printable-encoder-input-stream (encoder-input-stream) ())
(defclass base64-encoder-input-stream (encoder-input-stream) ())
(defclass 8bit-encoder-input-stream (fundamental-character-input-stream coder-stream-mixin) ())
(defmethod initialize-instance ((stream quoted-printable-encoder-input-stream) &key &allow-other-keys)
(call-next-method)
(with-slots (encoder buffer-queue) stream
(setf encoder
(make-instance 'quoted-printable-encoder
:output-function #'(lambda (char)
(queue-append buffer-queue char))))))
(defmethod initialize-instance ((stream base64-encoder-input-stream) &key &allow-other-keys)
(call-next-method)
(with-slots (encoder buffer-queue) stream
(setf encoder
(make-instance 'base64-encoder
:output-function #'(lambda (char)
(queue-append buffer-queue char))))))
(defmethod stream-read-char ((stream encoder-input-stream))
(with-slots (encoder buffer-queue real-stream) stream
(loop
while (queue-empty-p buffer-queue)
do (be byte (read-byte real-stream nil)
(if byte
(encoder-write-byte encoder byte)
(progn
(encoder-finish-output encoder)
(queue-append buffer-queue :eof)))))
(queue-pop buffer-queue)))
(defmethod stream-read-char ((stream 8bit-encoder-input-stream))
(with-slots (real-stream) stream
(aif (read-byte real-stream nil)
(code-char it)
:eof)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defclass input-adapter-stream ()
((source :initarg :source)
(real-stream)
(input-function)))
(defclass binary-input-adapter-stream (fundamental-binary-input-stream input-adapter-stream) ())
(defclass character-input-adapter-stream (fundamental-character-input-stream input-adapter-stream) ())
(defmethod stream-element-type ((stream binary-input-adapter-stream))
'(unsigned-byte 8))
(defmethod initialize-instance ((stream input-adapter-stream) &key &allow-other-keys)
(call-next-method)
(assert (slot-boundp stream 'source)))
(defmethod initialize-instance ((stream binary-input-adapter-stream) &key &allow-other-keys)
(call-next-method)
;; REAL-STREAM slot is set only if we are going to close it later on
(with-slots (source real-stream input-function) stream
(etypecase source
(string
(setf real-stream (make-string-input-stream source)
input-function #'(lambda ()
(awhen (read-char real-stream nil)
(char-code it)))))
((vector (unsigned-byte 8))
(be i 0
(setf input-function #'(lambda ()
(when (< i (length source))
(prog1 (aref source i)
(incf i)))))))
(stream
(assert (input-stream-p source))
(setf input-function (if (subtypep (stream-element-type source) 'character)
#'(lambda ()
(awhen (read-char source nil)
(char-code it)))
#'(lambda ()
(read-byte source nil)))))
(pathname
(setf real-stream (open source :element-type '(unsigned-byte 8))
input-function #'(lambda ()
(read-byte real-stream nil))))
(file-portion
(setf real-stream (open-decoded-file-portion source)
input-function #'(lambda ()
(read-byte real-stream nil)))))))
(defmethod initialize-instance ((stream character-input-adapter-stream) &key &allow-other-keys)
(call-next-method)
;; REAL-STREAM slot is set only if we are going to close later on
(with-slots (source real-stream input-function) stream
(etypecase source
(string
(setf real-stream (make-string-input-stream source)
input-function #'(lambda ()
(read-char real-stream nil))))
((vector (unsigned-byte 8))
(be i 0
(setf input-function #'(lambda ()
(when (< i (length source))
(prog1 (code-char (aref source i))
(incf i)))))))
(stream
(assert (input-stream-p source))
(setf input-function (if (subtypep (stream-element-type source) 'character)
#'(lambda ()
(read-char source nil))
#'(lambda ()
(awhen (read-byte source nil)
(code-char it))))))
(pathname
(setf real-stream (open source :element-type 'character)
input-function #'(lambda ()
(read-char real-stream nil))))
(file-portion
(setf real-stream (open-decoded-file-portion source)
input-function #'(lambda ()
(awhen (read-byte real-stream nil)
(code-char it))))))))
(defmethod close ((stream input-adapter-stream) &key abort)
(when (slot-boundp stream 'real-stream)
(with-slots (real-stream) stream
(close real-stream :abort abort))))
(defmethod stream-read-byte ((stream binary-input-adapter-stream))
(with-slots (input-function) stream
(or (funcall input-function)
:eof)))
(defmethod stream-read-char ((stream character-input-adapter-stream))
(with-slots (input-function) stream
(or (funcall input-function)
:eof)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defclass delimited-input-stream (fundamental-character-input-stream coder-stream-mixin)
((start-offset :initarg :start
:initform 0
:reader stream-start
:type integer)
(end-offset :initarg :end
:initform nil
:reader stream-end
:type (or null integer))))
(defmethod print-object ((object delimited-input-stream) stream)
(if *print-readably*
(call-next-method)
(with-slots (start-offset end-offset) object
(print-unreadable-object (object stream :type t :identity t)
(format stream "start=~A end=~A" start-offset end-offset)))))
(defun base-stream (stream)
(if (typep stream 'delimited-input-stream)
(base-stream (real-stream stream))
stream))
(defmethod initialize-instance ((stream delimited-input-stream) &key &allow-other-keys)
(call-next-method)
(unless (slot-boundp stream 'real-stream)
(error "REAL-STREAM is unbound. Must provide a :STREAM argument."))
(with-slots (start-offset) stream
(when start-offset
(file-position stream start-offset))))
(defmethod stream-read-char ((stream delimited-input-stream))
(with-slots (real-stream end-offset) stream
(if (or (not end-offset)
(< (file-position real-stream) end-offset))
(or (read-char real-stream nil)
:eof)
:eof)))
#+(OR)(defmethod stream-read-byte ((stream delimited-input-stream))
(with-slots (real-stream end-offset) stream
(if (or (not end-offset)
(< (file-position real-stream) end-offset))
(or (read-byte real-stream nil)
:eof)
:eof)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defclass my-string-input-stream (fundamental-character-input-stream coder-stream-mixin)
((string :initarg :string
:reader stream-string)))
(defmethod initialize-instance ((stream my-string-input-stream) &key &allow-other-keys)
(call-next-method)
(assert (slot-boundp stream 'string))
(with-slots (string real-stream) stream
(setf real-stream (make-string-input-stream string))))
(defmethod stream-read-char ((stream my-string-input-stream))
(with-slots (real-stream) stream
(or (read-char real-stream nil)
:eof)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defstruct file-portion
data ; string or a pathname
encoding
start
end)
(defun open-file-portion (file-portion)
(be data (file-portion-data file-portion)
(etypecase data
(pathname
(be stream (open data)
(make-instance 'delimited-input-stream
:stream stream
:start (file-portion-start file-portion)
:end (file-portion-end file-portion))))
(string
(make-instance 'delimited-input-stream
:stream (make-string-input-stream data)
:start (file-portion-start file-portion)
:end (file-portion-end file-portion)))
(stream
(make-instance 'delimited-input-stream
:stream data
:dont-close t
:start (file-portion-start file-portion)
:end (file-portion-end file-portion))))))
(defun open-decoded-file-portion (file-portion)
(make-instance (case (file-portion-encoding file-portion)
(:quoted-printable 'quoted-printable-decoder-stream)
(:base64 'base64-decoder-stream)
(t '8bit-decoder-stream))
:stream (open-file-portion file-portion)))

124
third_party/lisp/mime4cl/test/address.lisp vendored Normal file
View file

@ -0,0 +1,124 @@
;;; address.lisp --- tests for the e-mail address parser
;;; Copyright (C) 2007, 2009 by Walter C. Pelissero
;;; Author: Walter C. Pelissero <walter@pelissero.de>
;;; Project: mime4cl
#+cmu (ext:file-comment "$Module: address.lisp $")
;;; 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-tests)
(defun test-parsing (string)
(format nil "~{~A~^, ~}" (parse-addresses string)))
(deftest address-parse-simple.1
(test-parsing "foo@bar")
"foo@bar")
(deftest address-parse-simple.2
(test-parsing "foo@bar.com")
"foo@bar.com")
(deftest address-parse-simple.3
(test-parsing "foo@bar.baz.com")
"foo@bar.baz.com")
(deftest address-parse-simple.4
(test-parsing "foo.ooo@bar.baz.com")
"foo.ooo@bar.baz.com")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(deftest address-parse-simple-commented.1
(test-parsing "foo@bar (Some Comment)")
"\"Some Comment\" <foo@bar>")
(deftest address-parse-simple-commented.2
(test-parsing "foo@bar (Some, Comment)")
"\"Some, Comment\" <foo@bar>")
(deftest address-parse-simple-commented.3
(test-parsing "foo@bar (Some Comment (yes, indeed))")
"\"Some Comment (yes, indeed)\" <foo@bar>")
(deftest address-parse-simple-commented.4
(test-parsing "foo.bar@host.complicated.domain.net (Some Comment (yes, indeed))")
"\"Some Comment (yes, indeed)\" <foo.bar@host.complicated.domain.net>")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(deftest address-parse-angle.1
(test-parsing "<foo@bar.baz.net>")
"foo@bar.baz.net")
(deftest address-parse-angle.2
(test-parsing "My far far friend <foo@bar.baz.net>")
"\"My far far friend\" <foo@bar.baz.net>")
(deftest address-parse-angle.3
(test-parsing "\"someone, I don't like\" <foo@bar.baz.net>")
"\"someone, I don't like\" <foo@bar.baz.net>")
(deftest address-parse-angle.4
(test-parsing "\"this could (be a comment)\" <foo@bar.net>")
"\"this could (be a comment)\" <foo@bar.net>")
(deftest address-parse-angle.5
(test-parsing "don't be fooled <foo@bar.net>")
"\"don't be fooled\" <foo@bar.net>")
(deftest address-parse-angle.6
(test-parsing "<foo@bar>")
"foo@bar")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(deftest address-parse-domain-literal.1
(test-parsing "<foo@[bar]>")
"foo@[bar]")
(deftest address-parse-domain-literal.2
(test-parsing "<foo@[bar.net]>")
"foo@[bar.net]")
(deftest address-parse-domain-literal.3
(test-parsing "<foo@[10.0.0.2]>")
"foo@[10.0.0.2]")
(deftest address-parse-domain-literal.4
(test-parsing "<foo.bar@[10.0.0.2]>")
"foo.bar@[10.0.0.2]")
(deftest address-parse-domain-literal.5
(test-parsing "somewhere unkown <foo.bar@[10.0.0.2]>")
"\"somewhere unkown\" <foo.bar@[10.0.0.2]>")
(deftest address-parse-domain-literal.6
(test-parsing "\"Some--One\" <foo.bar@[10.0.0.23]>")
"\"Some--One\" <foo.bar@[10.0.0.23]>")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(deftest address-parse-group.1
(test-parsing "friends:john@bar.in.soho, jack@pub.round.the.corner, jim@[10.0.1.2];")
"friends: john@bar.in.soho, jack@pub.round.the.corner, jim@[10.0.1.2];")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(deftest address-parse-mixed.1
(test-parsing "Foo BAR <foo@bar.com>, \"John, Smith (that one!)\" <john.smith@host.domain.org>, friends:john@bar,jack@pub;, foo.bar.baz@wow.mail.mine, dont.bark@me (Fierce Dog)")
"\"Foo BAR\" <foo@bar.com>, \"John, Smith (that one!)\" <john.smith@host.domain.org>, friends: john@bar, jack@pub;, foo.bar.baz@wow.mail.mine, \"Fierce Dog\" <dont.bark@me>")

167
third_party/lisp/mime4cl/test/endec.lisp vendored Normal file
View file

@ -0,0 +1,167 @@
;;; endec.lisp --- test suite for the MIME encoder/decoder functions
;;; Copyright (C) 2006, 2007, 2009, 2010 by Walter C. Pelissero
;;; Author: Walter C. Pelissero <walter@pelissero.de>
;;; Project: mime4cl
#+cmu (ext:file-comment "$Module: endec.lisp $")
;;; 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-tests)
(deftest quoted-printable.1
(encode-quoted-printable-sequence (map '(vector (unsigned-byte 8)) #'char-code
"Français, Español, böse, skøl"))
"Fran=E7ais, Espa=F1ol, b=F6se, sk=F8l")
(deftest quoted-printable.2
(encode-quoted-printable-sequence (map '(vector (unsigned-byte 8)) #'char-code
"Français, Español, böse, skøl")
:start 10 :end 17)
"Espa=F1ol")
(deftest quoted-printable.3
(map 'string #'code-char
(decode-quoted-printable-string "Fran=E7ais, Espa=F1ol, b=F6se, sk=F8l"))
"Français, Español, böse, skøl")
(deftest quoted-printable.4
(map 'string #'code-char
(decode-quoted-printable-string "Fran=E7ais, Espa=F1ol, b=F6se, sk=F8l"
:start 12 :end 21))
"Español")
(deftest quoted-printable.5
(map 'string #'code-char
(decode-quoted-printable-string "this = wrong"))
"this = wrong")
(deftest quoted-printable.6
(map 'string #'code-char
(decode-quoted-printable-string "this is wrong="))
"this is wrong=")
(deftest quoted-printable.7
(map 'string #'code-char
(decode-quoted-printable-string "this is wrong=1"))
"this is wrong=1")
(deftest quoted-printable.8
(encode-quoted-printable-sequence (map '(vector (unsigned-byte 8)) #'char-code
"x = x + 1"))
"x =3D x + 1")
(deftest quoted-printable.9
(encode-quoted-printable-sequence (map '(vector (unsigned-byte 8)) #'char-code
"x = x + 1 "))
"x =3D x + 1 =20")
(deftest quoted-printable.10
(encode-quoted-printable-sequence (map '(vector (unsigned-byte 8)) #'char-code
"this string is very very very very very very very very very very very very very very very very very very very very long"))
"this string is very very very very very very very very very very very ve=
ry very very very very very very very very long")
(deftest quoted-printable.11
(encode-quoted-printable-sequence (map '(vector (unsigned-byte 8)) #'char-code
"this string is very very very very long"))
"this string is very very =
very very long")
(deftest quoted-printable.12
(encode-quoted-printable-sequence (map '(vector (unsigned-byte 8)) #'char-code
"please read the next
line"))
"please read the next =20
line")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(deftest base64.1
(let ((*base64-line-length* nil))
(encode-base64-sequence (map '(vector (unsigned-byte 8)) #'char-code
"Some random string.")))
"U29tZSByYW5kb20gc3RyaW5nLg==")
(deftest base64.2
(let ((*base64-line-length* nil))
(encode-base64-sequence (map '(vector (unsigned-byte 8)) #'char-code
"Some random string.") :start 5 :end 11))
"cmFuZG9t")
(deftest base64.3
(map 'string #'code-char
(decode-base64-string "U29tZSByYW5kb20gc3RyaW5nLg=="))
"Some random string.")
(deftest base64.4
(map 'string #'code-char
(decode-base64-string "some rubbish U29tZSByYW5kb20gc3RyaW5nLg== more rubbish"
:start 13 :end 41))
"Some random string.")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(deftest RFC2047.1
(parse-RFC2047-text "foo bar")
("foo bar"))
(defun perftest-encoder (encoder-class &optional (megs 100))
(declare (optimize (speed 3) (debug 0) (safety 0))
(type fixnum megs))
(with-open-file (in #P"/dev/random" :element-type '(unsigned-byte 8))
(let* ((meg (* 1024 1024))
(buffer (make-sequence '(vector (unsigned-byte 8)) meg))
(encoder (make-instance encoder-class
:output-function #'(lambda (c) (declare (ignore c))))))
(declare (type fixnum meg))
(time
(progn
(dotimes (x megs)
(read-sequence buffer in)
(dotimes (i meg)
(mime4cl:encoder-write-byte encoder (aref buffer i))))
(mime4cl:encoder-finish-output encoder))))))
(defun perftest-decoder (decoder-class &optional (megs 100))
(declare (optimize (speed 3) (debug 0) (safety 0))
(type fixnum megs))
(with-open-file (in #P"/dev/random" :element-type '(unsigned-byte 8))
(let ((sclf:*tmp-file-defaults* (make-pathname :defaults #.(or *load-pathname* *compile-file-pathname*)
:type "encoded-data")))
(sclf:with-temp-file (tmp nil :direction :io)
(let* ((meg (* 1024 1024))
(buffer (make-sequence '(vector (unsigned-byte 8)) meg))
(encoder-class (ecase decoder-class
(mime4cl:base64-decoder 'mime4cl:base64-encoder)
(mime4cl:quoted-printable-decoder 'mime4cl:quoted-printable-encoder)))
(encoder (make-instance encoder-class
:output-function #'(lambda (c)
(write-char c tmp))))
(decoder (make-instance decoder-class
:input-function #'(lambda ()
(read-char tmp nil)))))
(declare (type fixnum meg))
(dotimes (x megs)
(read-sequence buffer in)
(dotimes (i meg)
(mime4cl:encoder-write-byte encoder (aref buffer i))))
(mime4cl:encoder-finish-output encoder)
(file-position tmp 0)
(time
(loop
for b = (mime4cl:decoder-read-byte decoder)
while b)))))))

53
third_party/lisp/mime4cl/test/mime.lisp vendored Normal file
View file

@ -0,0 +1,53 @@
;;; mime.lisp --- MIME regression tests
;;; Copyright (C) 2012 by Walter C. Pelissero
;;; Author: Walter C. Pelissero <walter@pelissero.de>
;;; Project: mime4cl
#+cmu (ext:file-comment "$Module: mime.lisp")
;;; 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-tests)
(defvar *samples-directory*
(merge-pathnames (make-pathname :directory '(:relative "samples"))
#.(or *compile-file-pathname*
*load-pathname*
#P"")))
(deftest mime.1
(let* ((orig (mime-message (make-pathname :defaults #.(or *compile-file-pathname*
*load-pathname*)
:name "sample1"
:type "msg")))
(dup (mime-message (with-output-to-string (out) (encode-mime-part orig out)))))
(mime= orig dup))
t)
(deftest mime.2
(loop
for f in (directory (make-pathname :defaults *samples-directory*
:name :wild
:type "txt"))
do
(format t "~A:~%" f)
(finish-output)
(let* ((orig (mime-message f))
(dup (mime-message (with-output-to-string (out) (encode-mime-part orig out)))))
(unless (mime= orig dup)
(return nil)))
finally (return t))
t)

28
third_party/lisp/mime4cl/test/package.lisp vendored Normal file
View file

@ -0,0 +1,28 @@
;;; package.lisp --- package description for the regression tests
;;; Copyright (C) 2006, 2009 by Walter C. Pelissero
;;; Author: Walter C. Pelissero <walter@pelissero.de>
;;; Project: mime4cl
#+cmu (ext:file-comment "$Module: package.lisp $")
;;; 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
(cl:in-package :common-lisp)
(defpackage :mime4cl-tests
(:use :common-lisp
:rtest :mime4cl)
(:export))

254
third_party/lisp/mime4cl/test/rt.lisp vendored Normal file
View file

@ -0,0 +1,254 @@
#|----------------------------------------------------------------------------|
| Copyright 1990 by the Massachusetts Institute of Technology, Cambridge MA. |
| |
| Permission to use, copy, modify, and distribute this software and its |
| documentation for any purpose and without fee is hereby granted, provided |
| that this copyright and permission notice appear in all copies and |
| supporting documentation, and that the name of M.I.T. not be used in |
| advertising or publicity pertaining to distribution of the software |
| without specific, written prior permission. M.I.T. makes no |
| representations about the suitability of this software for any purpose. |
| It is provided "as is" without express or implied warranty. |
| |
| M.I.T. DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING |
| ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL |
| M.I.T. BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR |
| ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, |
| WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, |
| ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS |
| SOFTWARE. |
|----------------------------------------------------------------------------|#
(defpackage #:regression-test
(:nicknames #:rtest #-lispworks #:rt)
(:use #:cl)
(:export #:*do-tests-when-defined* #:*test* #:continue-testing
#:deftest #:do-test #:do-tests #:get-test #:pending-tests
#:rem-all-tests #:rem-test)
(:documentation "The MIT regression tester with pfdietz's modifications"))
(in-package :regression-test)
(defvar *test* nil "Current test name")
(defvar *do-tests-when-defined* nil)
(defvar *entries* '(nil) "Test database")
(defvar *in-test* nil "Used by TEST")
(defvar *debug* nil "For debugging")
(defvar *catch-errors* t
"When true, causes errors in a test to be caught.")
(defvar *print-circle-on-failure* nil
"Failure reports are printed with *PRINT-CIRCLE* bound to this value.")
(defvar *compile-tests* nil
"When true, compile the tests before running them.")
(defvar *optimization-settings* '((safety 3)))
(defvar *expected-failures* nil
"A list of test names that are expected to fail.")
(defstruct (entry (:conc-name nil)
(:type list))
pend name form)
(defmacro vals (entry) `(cdddr ,entry))
(defmacro defn (entry) `(cdr ,entry))
(defun pending-tests ()
(do ((l (cdr *entries*) (cdr l))
(r nil))
((null l) (nreverse r))
(when (pend (car l))
(push (name (car l)) r))))
(defun rem-all-tests ()
(setq *entries* (list nil))
nil)
(defun rem-test (&optional (name *test*))
(do ((l *entries* (cdr l)))
((null (cdr l)) nil)
(when (equal (name (cadr l)) name)
(setf (cdr l) (cddr l))
(return name))))
(defun get-test (&optional (name *test*))
(defn (get-entry name)))
(defun get-entry (name)
(let ((entry (find name (cdr *entries*)
:key #'name
:test #'equal)))
(when (null entry)
(report-error t
"~%No test with name ~:@(~S~)."
name))
entry))
(defmacro deftest (name form &rest values)
`(add-entry '(t ,name ,form .,values)))
(defun add-entry (entry)
(setq entry (copy-list entry))
(do ((l *entries* (cdr l))) (nil)
(when (null (cdr l))
(setf (cdr l) (list entry))
(return nil))
(when (equal (name (cadr l))
(name entry))
(setf (cadr l) entry)
(report-error nil
"Redefining test ~:@(~S~)"
(name entry))
(return nil)))
(when *do-tests-when-defined*
(do-entry entry))
(setq *test* (name entry)))
(defun report-error (error? &rest args)
(cond (*debug*
(apply #'format t args)
(if error? (throw '*debug* nil)))
(error? (apply #'error args))
(t (apply #'warn args))))
(defun do-test (&optional (name *test*))
(do-entry (get-entry name)))
(defun equalp-with-case (x y)
"Like EQUALP, but doesn't do case conversion of characters."
(cond
((eq x y) t)
((consp x)
(and (consp y)
(equalp-with-case (car x) (car y))
(equalp-with-case (cdr x) (cdr y))))
((and (typep x 'array)
(= (array-rank x) 0))
(equalp-with-case (aref x) (aref y)))
((typep x 'vector)
(and (typep y 'vector)
(let ((x-len (length x))
(y-len (length y)))
(and (eql x-len y-len)
(loop
for e1 across x
for e2 across y
always (equalp-with-case e1 e2))))))
((and (typep x 'array)
(typep y 'array)
(not (equal (array-dimensions x)
(array-dimensions y))))
nil)
((typep x 'array)
(and (typep y 'array)
(let ((size (array-total-size x)))
(loop for i from 0 below size
always (equalp-with-case (row-major-aref x i)
(row-major-aref y i))))))
(t (eql x y))))
(defun do-entry (entry &optional
(s *standard-output*))
(catch '*in-test*
(setq *test* (name entry))
(setf (pend entry) t)
(let* ((*in-test* t)
;; (*break-on-warnings* t)
(aborted nil)
r)
;; (declare (special *break-on-warnings*))
(block aborted
(setf r
(flet ((%do
()
(if *compile-tests*
(multiple-value-list
(funcall (compile
nil
`(lambda ()
(declare
(optimize ,@*optimization-settings*))
,(form entry)))))
(multiple-value-list
(eval (form entry))))))
(if *catch-errors*
(handler-bind
((style-warning #'muffle-warning)
(error #'(lambda (c)
(setf aborted t)
(setf r (list c))
(return-from aborted nil))))
(%do))
(%do)))))
(setf (pend entry)
(or aborted
(not (equalp-with-case r (vals entry)))))
(when (pend entry)
(let ((*print-circle* *print-circle-on-failure*))
(format s "~&Test ~:@(~S~) failed~
~%Form: ~S~
~%Expected value~P: ~
~{~S~^~%~17t~}~%"
*test* (form entry)
(length (vals entry))
(vals entry))
(format s "Actual value~P: ~
~{~S~^~%~15t~}.~%"
(length r) r)))))
(when (not (pend entry)) *test*))
(defun continue-testing ()
(if *in-test*
(throw '*in-test* nil)
(do-entries *standard-output*)))
(defun do-tests (&optional
(out *standard-output*))
(dolist (entry (cdr *entries*))
(setf (pend entry) t))
(if (streamp out)
(do-entries out)
(with-open-file
(stream out :direction :output)
(do-entries stream))))
(defun do-entries (s)
(format s "~&Doing ~A pending test~:P ~
of ~A tests total.~%"
(count t (cdr *entries*)
:key #'pend)
(length (cdr *entries*)))
(dolist (entry (cdr *entries*))
(when (pend entry)
(format s "~@[~<~%~:; ~:@(~S~)~>~]"
(do-entry entry s))))
(let ((pending (pending-tests))
(expected-table (make-hash-table :test #'equal)))
(dolist (ex *expected-failures*)
(setf (gethash ex expected-table) t))
(let ((new-failures
(loop for pend in pending
unless (gethash pend expected-table)
collect pend)))
(if (null pending)
(format s "~&No tests failed.")
(progn
(format s "~&~A out of ~A ~
total tests failed: ~
~:@(~{~<~% ~1:;~S~>~
~^, ~}~)."
(length pending)
(length (cdr *entries*))
pending)
(if (null new-failures)
(format s "~&No unexpected failures.")
(when *expected-failures*
(format s "~&~A unexpected failures: ~
~:@(~{~<~% ~1:;~S~>~
~^, ~}~)."
(length new-failures)
new-failures)))
))
(null pending))))

86
third_party/lisp/mime4cl/test/sample1.msg vendored Normal file
View file

@ -0,0 +1,86 @@
From wcp@scylla.home.lan Fri Feb 17 11:02:28 2012
Status: RO
X-VM-v5-Data: ([nil nil nil nil nil nil nil nil nil]
["1133" "Friday" "17" "February" "2012" "11:02:27" "+0100" "Walter C. Pelissero" "walter@pelissero.de" nil "56" "test" "^From:" nil nil "2" nil nil nil nil nil nil nil nil nil nil]
nil)
X-Clpmr-Processed: 2012-02-17T11:02:31
X-Clpmr-Version: 2011-10-23T12:55:20, SBCL 1.0.49
Received: from scylla.home.lan (localhost [127.0.0.1])
by scylla.home.lan (8.14.5/8.14.5) with ESMTP id q1HA2Sik004513
for <wcp@scylla.home.lan>; Fri, 17 Feb 2012 11:02:28 +0100 (CET)
(envelope-from wcp@scylla.home.lan)
Received: (from wcp@localhost)
by scylla.home.lan (8.14.5/8.14.5/Submit) id q1HA2SqU004512;
Fri, 17 Feb 2012 11:02:28 +0100 (CET)
(envelope-from wcp)
Message-ID: <20286.9651.890757.323027@scylla.home.lan>
X-Mailer: VM 8.1.1 under 23.3.1 (amd64-portbld-freebsd8.2)
Reply-To: walter@pelissero.de
X-Attribution: WP
X-For-Spammers: blacklistme@pelissero.de
X-MArch-Processing-Time: 0.552s
MIME-Version: 1.0
Content-Type: multipart/mixed; boundary="615CiWUaGO"
Content-Transfer-Encoding: 7BIT
From: walter@pelissero.de (Walter C. Pelissero)
To: wcp@scylla.home.lan
Subject: test
Date: Fri, 17 Feb 2012 11:02:27 +0100
--615CiWUaGO
Content-Type: text/plain; charset="us-ascii"
Content-Transfer-Encoding: 7BIT
Content-Description: message body text
Hereafter three attachments.
The first:
--615CiWUaGO
Content-Type: application/octet-stream; name="attach1"
Content-Transfer-Encoding: BASE64
Content-Disposition: attachment; filename="attach1"
YXR0YWNoMQo=
--615CiWUaGO
Content-Type: text/plain; charset="us-ascii"
Content-Transfer-Encoding: 7BIT
Content-Description: message body text
The second:
--615CiWUaGO
Content-Type: application/octet-stream; name="attach2"
Content-Transfer-Encoding: BASE64
Content-Disposition: attachment; filename="attach2"
YXR0YWNoMgo=
--615CiWUaGO
Content-Type: text/plain; charset="us-ascii"
Content-Transfer-Encoding: 7BIT
Content-Description: message body text
The third:
--615CiWUaGO
Content-Type: application/octet-stream; name="attach3"
Content-Transfer-Encoding: BASE64
Content-Disposition: attachment; filename="attach3"
YXR0YWNoMwo=
--615CiWUaGO
Content-Type: text/plain; charset="us-ascii"
Content-Transfer-Encoding: 7BIT
Content-Description: .signature
--
http://pelissero.de
--615CiWUaGO--