Author: hhubner
Date: 2006-09-24 15:13:31 -0400 (Sun, 24 Sep 2006)
New Revision: 1984
Added:
branches/xml-class-rework/thirdparty/cl-mime/README
branches/xml-class-rework/thirdparty/cl-mime/cl-mime.asd
branches/xml-class-rework/thirdparty/cl-mime/encoding.lisp
branches/xml-class-rework/thirdparty/cl-mime/package.lisp
Removed:
branches/xml-class-rework/thirdparty/cl-mime/fundamentals.lisp
branches/xml-class-rework/thirdparty/cl-mime/mime.asd
Modified:
branches/xml-class-rework/thirdparty/cl-mime/classes.lisp
branches/xml-class-rework/thirdparty/cl-mime/headers.lisp
branches/xml-class-rework/thirdparty/cl-mime/parse-mime.lisp
branches/xml-class-rework/thirdparty/cl-mime/print-mime.lisp
branches/xml-class-rework/thirdparty/cl-mime/utilities.lisp
Log:
Update to cl-mime 0.5.1
Added: branches/xml-class-rework/thirdparty/cl-mime/README
===================================================================
--- branches/xml-class-rework/thirdparty/cl-mime/README 2006-09-15 14:21:24 UTC (rev 1983)
+++ branches/xml-class-rework/thirdparty/cl-mime/README 2006-09-24 19:13:31 UTC (rev 1984)
@@ -0,0 +1,9 @@
+This is a library for reading and printing MIME content. It supports
+automatic conversion between 7bit, quoted-printable and base64
+encodings via cl-base64 and cl-qprint libraries.
+
+The required libraries can be found at:
+http://files.b9.com/cl-base64/cl-base64-latest.tar.gz
+http://www.bobturf.org/software/cl-qprint
+http://weitz.de/cl-ppcre/
+
Added: branches/xml-class-rework/thirdparty/cl-mime/cl-mime.asd
===================================================================
--- branches/xml-class-rework/thirdparty/cl-mime/cl-mime.asd 2006-09-15 14:21:24 UTC (rev 1983)
+++ branches/xml-class-rework/thirdparty/cl-mime/cl-mime.asd 2006-09-24 19:13:31 UTC (rev 1984)
@@ -0,0 +1,42 @@
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;; cl-mime.asd: System Definition
+;;;; Copyright (C) 2004 Robert Marlow <bobstopper(a)bobturf.org>
+;;;;
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Library General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 2 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
+;;;; Library General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Library 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.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+
+
+(defpackage :cl-mime-system
+ (:use :asdf :cl))
+
+(in-package :cl-mime-system)
+
+(defsystem :cl-mime
+ :name "MIME"
+ :author "Robert Marlow <bobstopper(a)bobturf.org>"
+ :version "0.5.1"
+ :maintainer "Robert Marlow <bobstopper(a)bobturf.org>"
+ :depends-on (:cl-ppcre :cl-base64 :cl-qprint)
+ :serial t
+ :components
+ ((:file "package")
+ (:file "utilities")
+ (:file "classes")
+ (:file "headers")
+ (:file "encoding")
+ (:file "parse-mime")
+ (:file "print-mime")))
Modified: branches/xml-class-rework/thirdparty/cl-mime/classes.lisp
===================================================================
--- branches/xml-class-rework/thirdparty/cl-mime/classes.lisp 2006-09-15 14:21:24 UTC (rev 1983)
+++ branches/xml-class-rework/thirdparty/cl-mime/classes.lisp 2006-09-24 19:13:31 UTC (rev 1984)
@@ -47,7 +47,16 @@
(content-transfer-encoding
:accessor content-transfer-encoding
:initarg :encoding
- :initform "7bit")
+ :initform :7bit
+ :documentation
+ "Encoding to use when printing the MIME content.
+May be :7BIT :BASE64 or :QUOTED-PRINTABLE")
+ (content-encoding
+ :accessor content-encoding
+ :initarg :content-encoding
+ :initform :7bit
+ :documentation "Encoding the MIME content is currently in.
+May be :7BIT :BASE64 or :QUOTED-PRINTABLE")
(content-disposition
:accessor content-disposition
:initarg :disposition
Added: branches/xml-class-rework/thirdparty/cl-mime/encoding.lisp
===================================================================
--- branches/xml-class-rework/thirdparty/cl-mime/encoding.lisp 2006-09-15 14:21:24 UTC (rev 1983)
+++ branches/xml-class-rework/thirdparty/cl-mime/encoding.lisp 2006-09-24 19:13:31 UTC (rev 1984)
@@ -0,0 +1,46 @@
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;; encoding.lisp: Tools for converting content encoding
+;;;; Copyright (C) 2004 Robert Marlow <bobstopper(a)bobturf.org>
+;;;;
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Library General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 2 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
+;;;; Library General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Library 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 :mime)
+
+
+(defun encode-content (mime)
+ (if (eql (content-transfer-encoding mime)
+ (content-encoding mime))
+ (content mime)
+ (let ((content (decode-content mime)))
+ (ecase (content-transfer-encoding mime)
+ (:7bit content)
+ (:base64
+ (typecase content
+ (string (string-to-base64-string content :columns 75))
+ ((array (unsigned-byte 8))
+ (usb8-array-to-base64-string content :columns 75))))
+ (:quoted-printable (qprint:encode content 75))))))
+
+
+(defun decode-content (mime)
+ (ecase (content-encoding mime)
+ (:7bit (content mime))
+ (:base64 (base64-string-to-usb8-array (content mime)))
+ (:quoted-printable (qprint:decode (content mime)))))
+
Deleted: branches/xml-class-rework/thirdparty/cl-mime/fundamentals.lisp
===================================================================
--- branches/xml-class-rework/thirdparty/cl-mime/fundamentals.lisp 2006-09-15 14:21:24 UTC (rev 1983)
+++ branches/xml-class-rework/thirdparty/cl-mime/fundamentals.lisp 2006-09-24 19:13:31 UTC (rev 1984)
@@ -1,58 +0,0 @@
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;; fundamentals.lisp: Package definition and any globals
-;;;; Copyright (C) 2004 Robert Marlow <bobstopper(a)bobturf.org>
-;;;;
-;;;; This library is free software; you can redistribute it and/or
-;;;; modify it under the terms of the GNU Library General Public
-;;;; License as published by the Free Software Foundation; either
-;;;; version 2 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
-;;;; Library General Public License for more details.
-;;;;
-;;;; You should have received a copy of the GNU Library 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.
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-
-
-(defpackage :mime
- (:documentation "A package for constructing MIME objects for printing and
-parsing MIME formatted strings or streams.")
- (:nicknames :cl-mime)
- (:use :cl :kmrcl :cl-ppcre)
- (:shadow :read-stream-to-string)
- (:export :text-mime
- :multipart-mime
- :mime
- :make-content-id
- :content-type
- :content-subtype
- :content-type-parameters
- :content-id
- :content-description
- :content-transfer-encoding
- :content-disposition
- :content-disposition-parameters
- :mime-version
- :charset
- :boundary
- :prologue
- :epilogue
- :content
- :get-header
- :get-mime-headers
- :get-content-type-parameter
- :get-content-disposition-parameter
- :print-headers
- :header-value
- :header-parms
- :header-comments
- :print-mime
- :parse-mime))
-
-(in-package :mime)
Modified: branches/xml-class-rework/thirdparty/cl-mime/headers.lisp
===================================================================
--- branches/xml-class-rework/thirdparty/cl-mime/headers.lisp 2006-09-15 14:21:24 UTC (rev 1983)
+++ branches/xml-class-rework/thirdparty/cl-mime/headers.lisp 2006-09-24 19:13:31 UTC (rev 1984)
@@ -51,16 +51,16 @@
(defmethod get-header ((mime-obj mime) (header (eql :content-disposition)))
- (aif (slot-value mime-obj (intern (string header) :mime))
- (cons header
- (format nil "~A~A"
- (content-disposition mime-obj)
- (format nil "~{~{;~%~5,5T~A=\"~A\"~}~}"
- (mapcar
- (lambda (parm-pair)
- (cons (string-downcase (symbol-name (car parm-pair)))
- (cdr parm-pair)))
- (content-disposition-parameters mime-obj)))))))
+ (when (content-disposition mime-obj)
+ (cons header
+ (format nil "~A~A"
+ (content-disposition mime-obj)
+ (format nil "~{~{;~%~5,5T~A=\"~A\"~}~}"
+ (mapcar
+ (lambda (parm-pair)
+ (cons (string-downcase (symbol-name (car parm-pair)))
+ (cdr parm-pair)))
+ (content-disposition-parameters mime-obj)))))))
(defmethod get-header ((mime-obj mime) (header symbol))
Deleted: branches/xml-class-rework/thirdparty/cl-mime/mime.asd
===================================================================
--- branches/xml-class-rework/thirdparty/cl-mime/mime.asd 2006-09-15 14:21:24 UTC (rev 1983)
+++ branches/xml-class-rework/thirdparty/cl-mime/mime.asd 2006-09-24 19:13:31 UTC (rev 1984)
@@ -1,41 +0,0 @@
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;; mime.asd: System Definition
-;;;; Copyright (C) 2004 Robert Marlow <bobstopper(a)bobturf.org>
-;;;;
-;;;; This library is free software; you can redistribute it and/or
-;;;; modify it under the terms of the GNU Library General Public
-;;;; License as published by the Free Software Foundation; either
-;;;; version 2 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
-;;;; Library General Public License for more details.
-;;;;
-;;;; You should have received a copy of the GNU Library 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.
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-
-
-(defpackage :mime-system
- (:use :asdf :cl))
-
-(in-package :mime-system)
-
-(defsystem :mime
- :name "MIME"
- :author "Robert Marlow <rob(a)bobturf.org>"
- :version "0.3.0"
- :maintainer "Robert Marlow <rob(a)bobturf.org>"
- :depends-on (:kmrcl :cl-ppcre)
- :serial t
- :components
- ((:file "fundamentals")
- (:file "utilities")
- (:file "classes")
- (:file "headers")
- (:file "parse-mime")
- (:file "print-mime")))
Added: branches/xml-class-rework/thirdparty/cl-mime/package.lisp
===================================================================
--- branches/xml-class-rework/thirdparty/cl-mime/package.lisp 2006-09-15 14:21:24 UTC (rev 1983)
+++ branches/xml-class-rework/thirdparty/cl-mime/package.lisp 2006-09-24 19:13:31 UTC (rev 1984)
@@ -0,0 +1,62 @@
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;; package.lisp: Package definition
+;;;; Copyright (C) 2004 Robert Marlow <bobstopper(a)bobturf.org>
+;;;;
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Library General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 2 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
+;;;; Library General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Library 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.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+
+
+(defpackage :cl-mime
+ (:documentation "A package for constructing MIME objects for printing and
+parsing MIME formatted strings or streams.")
+ (:nicknames :mime)
+ (:use :cl :cl-ppcre :base64)
+ (:export :text-mime
+ :multipart-mime
+ :mime
+ :lookup-mime
+ :make-content-id
+ :content-type
+ :content-subtype
+ :content-type-parameters
+ :content-id
+ :content-description
+ :content-transfer-encoding
+ :content-disposition
+ :content-disposition-parameters
+ :mime-version
+ :charset
+ :boundary
+ :prologue
+ :epilogue
+ :content
+ :get-header
+ :get-mime-headers
+ :get-content-type-parameter
+ :get-content-disposition-parameter
+ :header-value
+ :header-parms
+ :header-comments
+ :print-mime
+ :print-headers
+ :parse-mime
+ :parse-body
+ :parse-headers
+ :decode-content
+ :encode-content))
+
+(in-package :mime)
Modified: branches/xml-class-rework/thirdparty/cl-mime/parse-mime.lisp
===================================================================
--- branches/xml-class-rework/thirdparty/cl-mime/parse-mime.lisp 2006-09-15 14:21:24 UTC (rev 1983)
+++ branches/xml-class-rework/thirdparty/cl-mime/parse-mime.lisp 2006-09-24 19:13:31 UTC (rev 1984)
@@ -29,8 +29,7 @@
(defmethod parse-mime ((mime string) &optional headers)
- (declare (ignore headers))
- (parse-mime (make-string-input-stream mime)))
+ (parse-mime (make-string-input-stream mime) headers))
(defmethod parse-mime ((mime stream) &optional headers)
@@ -56,19 +55,23 @@
(if (equal mime-version "1.0")
- (let ((mime-obj-gen
- (list
- mime-type
- :type content-type
- :subtype content-subtype
- ; :parameters content-parm
- :encoding (cdr (assoc :content-transfer-encoding
- headers))
- :description (cdr (assoc :content-description
- headers))
- :id (remove #\< (remove #\> (cdr (assoc :content-id headers))))
- :disposition content-disposition
- :disposition-parameters content-disposition-parm)))
+ (let* ((encoding (intern (or (string-upcase
+ (cdr (assoc :content-transfer-encoding
+ headers)))
+ "7BIT")
+ :keyword))
+ (mime-obj-gen
+ (list
+ mime-type
+ :type content-type
+ :subtype content-subtype
+ :encoding encoding
+ :content-encoding encoding
+ :description (cdr (assoc :content-description
+ headers))
+ :id (remove #\< (remove #\> (cdr (assoc :content-id headers))))
+ :disposition content-disposition
+ :disposition-parameters content-disposition-parm)))
(case mime-type
((text-mime)
@@ -289,3 +292,31 @@
(setq end-type 'end-mime))))
end-type)))
+
+(defparameter *mime-types-file*
+ (make-pathname :directory '(:absolute "etc")
+ :name "mime"
+ :type "types"))
+
+
+(defun lookup-mime (pathname &optional mime-types-file)
+ "Takes a PATHNAME argument and uses MIME-TYPES-FILE (or the system
+default) to determine the mime type of PATHNAME. Returns two values:
+the content type and the the content subtype"
+ (let ((extension (pathname-type pathname)))
+ (with-open-file
+ (mime (or mime-types-file *mime-types-file*) :direction :input)
+ (read-lines
+ (line mime)
+ ((register-groups-bind
+ (extensions)
+ ("^[^#\\s]+\\s+([^#]+)" line)
+ (find extension (split "\\s+" extensions)
+ :test #'string-equal))
+ (if (eq line 'eof)
+ (values "application" "octet-stream")
+ (register-groups-bind
+ (content-type content-subtype)
+ ("^([^\/]+)\/([^\\s]+)" line)
+ (values (or content-type "application")
+ (or content-subtype "octet-stream")))))))))
Modified: branches/xml-class-rework/thirdparty/cl-mime/print-mime.lisp
===================================================================
--- branches/xml-class-rework/thirdparty/cl-mime/print-mime.lisp 2006-09-15 14:21:24 UTC (rev 1983)
+++ branches/xml-class-rework/thirdparty/cl-mime/print-mime.lisp 2006-09-24 19:13:31 UTC (rev 1984)
@@ -30,10 +30,14 @@
(format nil "~A: ~A~%"
(if (eql :mime-version (car it))
"MIME-Version"
- (string-capitalize (symbol-name (car it))))
- (if (eql :content-id (car it))
- (format nil "<~A>" (cdr it))
- (cdr it))))
+ (string-capitalize (symbol-name (car it))))
+ (cond
+ ((eql :content-id (car it))
+ (format nil "<~A>" (cdr it)))
+ ((eql :content-transfer-encoding (car it))
+ (string-downcase (symbol-name (cdr it))))
+ (t
+ (cdr it)))))
headers-out))
@@ -68,6 +72,7 @@
(:documentation
"Prints a mime object's contents, optionally with headers"))
+
(defmethod print-mime (stream (mime-obj mime) headers-p version-p)
(format stream "~A~A"
(if headers-p
@@ -75,8 +80,8 @@
(print-headers nil (get-mime-headers mime-obj)
version-p)
(string #\newline))
- "")
- (content mime-obj)))
+ "")
+ (encode-content mime-obj)))
(defmethod print-mime (stream (mime-obj multipart-mime) headers-p version-p)
Modified: branches/xml-class-rework/thirdparty/cl-mime/utilities.lisp
===================================================================
--- branches/xml-class-rework/thirdparty/cl-mime/utilities.lisp 2006-09-15 14:21:24 UTC (rev 1983)
+++ branches/xml-class-rework/thirdparty/cl-mime/utilities.lisp 2006-09-24 19:13:31 UTC (rev 1984)
@@ -47,3 +47,18 @@
(,exit-clause t)
(princ ,line-var ,string-stream)
(terpri ,string-stream)))))
+
+
+;;; These macros stolen from KMRCL
+(defmacro aif (test then &optional else)
+ `(let ((it ,test))
+ (if it ,then ,else)))
+
+
+(defun ensure-keyword (name)
+ "Returns keyword for a name"
+ (etypecase name
+ (keyword name)
+ (string (nth-value 0 (intern (string-upcase name) :keyword)))
+ (symbol (nth-value 0 (intern (symbol-name name) :keyword)))))
+
)){kind=link}