bknr-cvs

Download

bknr-cvs@common-lisp.net

September 2006

1 participants
2 discussions

[bknr-cvs] r1984 - branches/xml-class-rework/thirdparty/cl-mime
by bknr＠bknr.net 24 Sep '06

24 Sep '06

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))))) +

1 0

[bknr-cvs] r1983 - branches/xml-class-rework/bknr/src/skip-list
by bknr＠bknr.net 15 Sep '06

15 Sep '06

Author: hhubner Date: 2006-09-15 10:21:24 -0400 (Fri, 15 Sep 2006) New Revision: 1983 Modified: branches/xml-class-rework/bknr/src/skip-list/skip-list.lisp Log: Workaround for Kamen Tomov's problem with multiple inheritance. Modified: branches/xml-class-rework/bknr/src/skip-list/skip-list.lisp =================================================================== --- branches/xml-class-rework/bknr/src/skip-list/skip-list.lisp 2006-08-18 16:38:52 UTC (rev 1982) +++ branches/xml-class-rework/bknr/src/skip-list/skip-list.lisp 2006-09-15 14:21:24 UTC (rev 1983) @@ -159,7 +159,7 @@ (multiple-value-bind (update node) (make-update sl key) - (when (= (node-key node) key) + (when (and node (= (node-key node) key)) (do ((level 0 (1+ level))) ((= level (skip-list-level sl))) (let ((next (node-forward update level)))

1 0