#+(version= 8 1)
(sys:defpatch "mime" 4
"v1: changes to internal/undocumented portions of module;
v2: better parse-mime-structure behavior in the face of malformatted headers;
v3: Improved performance when converting charset to external-format;
v4: decode-header-text: handle underscore & remove soft newlines."
:type :system
:post-loadable t)
#+(version= 8 0)
(sys:defpatch "mime" 3
"v0: New module. See documentation.;
v1: Improve default transfer encoding determination;
v2: make-mime-part: Default external-format is :utf8;
v3: add mime structure parsing support."
:type :system
:post-loadable t)
;; -*- mode: common-lisp; package: net.post-office -*-
;;
;; imap.cl
;; imap and pop interface
;;
;; See the file LICENSE for the full license governing this code.
;;
(defpackage :net.post-office
(:use #:lisp #:excl)
(:export
;; functions/methods
#:make-mime-part
#:mime-part-writer
#:mime-part-p
#:mime-part-constructed-p
#:map-over-parts
#:decode-header-text
;; macros
#:mime-get-header
#:with-mime-part-constructed-stream
;; classes
#:mime-part-constructed
;; slot accessors
#:mime-part-type
#:mime-part-subtype
#:mime-part-parameters
#:mime-part-id
#:mime-part-description
#:mime-part-encoding
#:mime-part-headers
#:mime-part-parts
#:mime-part-boundary))
(provide :mime)
(in-package :net.post-office)
(eval-when (compile load eval)
(require :osi)
(require :regexp2))
(defclass mime-part ()
(
(type :accessor mime-part-type :initform nil)
(subtype :accessor mime-part-subtype :initform nil)
(parameters :accessor mime-part-parameters :initform nil) ;; alist
(id :accessor mime-part-id :initform nil)
(description :accessor mime-part-description :initform nil)
(encoding :accessor mime-part-encoding :initform nil)
(headers ;; parsed headers alist
:accessor mime-part-headers :initform nil)
(parts ;; list of subparts (for multipart types)
:accessor mime-part-parts :initform nil)
(boundary :accessor mime-part-boundary :initform nil)))
(defclass mime-part-constructed (mime-part)
(
(source-type :accessor source-type)
(source :accessor source)
(disposition :accessor disposition :initform nil)
(disposition-name :accessor disposition-name :initform nil)))
(defmacro mime-get-header (header part)
`(cdr (assoc ,header (mime-part-headers ,part) :test #'equalp)))
(defun message-rfc822-p (type subtype)
(and (equalp type "message") (equalp subtype "rfc822")))
(defun multipart-p (part)
(equalp (mime-part-type part) "multipart"))
(defun multipart-mixed-p (part)
(and (equalp (mime-part-type part) "multipart")
(equalp (mime-part-subtype part) "mixed")))
(defun mime-part-p (thing)
(typep thing 'mime-part))
(defun mime-part-constructed-p (thing)
(typep thing 'mime-part-constructed))
(defun generate-boundary ()
(declare (optimize (speed 3)))
(let ((hex "01234567890abcdef"))
(with-output-to-string (s)
(write-string "----------_" s)
(dotimes (n 32)
(write-char (schar hex (random 16)) s)))))
(defun make-mime-part (&key content-type encoding headers
(attachmentp nil attachmentp-supplied)
name text (start 0) end file
subparts (external-format :utf8)
parameters charset id description)
(let ((part (make-instance 'mime-part-constructed))
type subtype multipart textp filepath orig-text)
(if* (and text file)
then (error "Only one of :text or :file may be specified"))
(if* (and text (null end))
then (setf end (length text)))
(when file
(if* (streamp file)
then (setf filepath (ignore-errors (namestring file)))
else (setf filepath file)))
;; Select default content-type
(when (null content-type)
(if* filepath
then (setf content-type (lookup-mime-type filepath)))
(when (null content-type)
(setf content-type
(if* subparts
then "multipart/mixed"
elseif file
then "application/octet-stream"
elseif (and text (stringp text))
then "text/plain"
else "application/octet-stream"))))
(let ((pos (position #\/ content-type)))
(if (null pos)
(error "Invalid content-type: ~s" content-type))
(setf type (subseq content-type 0 pos))
(setf subtype (subseq content-type (1+ pos))))
(setf multipart (equalp type "multipart"))
(setf textp (or (equalp type "text") (message-rfc822-p type subtype)))
(if* (and subparts (not multipart))
then (error "subparts may not be specified for non-multipart parts"))
(if* (and (not multipart) (null text) (null file))
then (error "One of :text or :file must be specified"))
;; Select default charset
(if* (and (null charset) textp)
then (setf charset
(or
(guess-charset-from-ef (find-external-format external-format))
"us-ascii")))
;; For :text, break down to the final usb8.
(when text
(setf orig-text text)
(setf text (if* (stringp text)
then (string-to-octets text :null-terminate nil
:external-format external-format
:start start
:end end)
else (subseq text start end))))
;; Select default encoding, which is always base64 except for
;; when :text was supplied as a string, in which case we scan to
;; choose between 7bit and base64.
(when (and (not multipart) (null encoding))
(setf encoding
(if* (and (stringp orig-text) (not (8-bit-array-p text)))
then "7bit"
else "base64")))
(setf (mime-part-type part) type)
(setf (mime-part-subtype part) subtype)
(setf (mime-part-parameters part) parameters)
(if* charset
then (push (cons "charset" charset) (mime-part-parameters part)))
(setf (mime-part-encoding part) encoding)
(setf (mime-part-id part) id)
(setf (mime-part-description part) description)
(setf (mime-part-headers part) headers)
(if* file
then (setf (source part) file)
(if* (streamp file)
then (setf (source-type part) :stream)
else (with-open-file (f file)) ;; make sure we can read it.
(setf (source-type part) :file))
(if* (not attachmentp-supplied)
then (setf attachmentp t))
else (setf (source-type part) :usb8)
(setf (source part) text))
(if* (and (not textp) (not attachmentp) (not multipart))
then (setf (disposition part) "inline"))
(when attachmentp
(setf (disposition part) "attachment")
(if* (and (null name) file)
then (setf name (excl.osi:basename filepath))))
(if* name
then (setf (disposition-name part) name))
(if* multipart
then (let ((boundary (generate-boundary)))
(setf (mime-part-boundary part) boundary)
(push (cons "boundary" boundary)
(mime-part-parameters part))))
(setf (mime-part-parts part) subparts)
part))
(defun 8-bit-array-p (usb8)
(declare (optimize (speed 3) (safety 0))
((simple-array (unsigned-byte 8) (*)) usb8))
(dotimes (n (length usb8))
(declare (fixnum n))
(if (> (aref usb8 n) 127)
(return t))))
(defparameter *ef-nick-to-mime-charset*
'((:ascii . "us-ascii")
(:iso-2022-jp . "iso-2022-jp")
(:koi8-r . "koi8-r")
(:shiftjis . "shift_jis")
(:euc . "euc-jp")
(:gb2312 . "gb2312")
(:big5 . "big5")
(:utf8 . "utf-8")))
(defun guess-charset-from-ef (ef)
(dolist (nick (ef-nicknames (find-external-format ef)))
(let ((charset (cdr (assoc nick *ef-nick-to-mime-charset*))))
(if charset (return-from guess-charset-from-ef charset))))
(let ((ef-name (string-downcase (symbol-name (ef-name (crlf-base-ef ef))))))
;; Try iso-8559-x names.
(multiple-value-bind (found ignore suffix)
(match-re "^iso8859-(\\d+)-base" ef-name)
(declare (ignore ignore))
(if found
(return-from guess-charset-from-ef
(format nil "iso-8859-~a" suffix))))
;; Try windows- names.
(multiple-value-bind (found whole value)
(match-re "^(\\d+)-base$" ef-name)
(declare (ignore whole))
(if found
(return-from guess-charset-from-ef
(format nil "windows-~a" value))))))
(defmethod mime-part-writer ((part mime-part-constructed)
&key (stream *terminal-io*))
(mime-part-constructed-writer part stream t))
(defun mime-part-constructed-writer (part stream top-level)
(if* top-level
then (format stream "MIME-Version: 1.0~%"))
;; First dump user-supplied headers.
(dolist (h (mime-part-headers part))
(format stream "~a: ~a~%" (car h) (cdr h)))
;; Now dump headers that are based on class fields.
(let* ((type (mime-part-type part))
(multipart (equalp type "multipart")))
(format stream "Content-Type: ~a/~a" type (mime-part-subtype part))
(dolist (param (mime-part-parameters part))
(format stream ";~% ~a=~s" (car param) (cdr param)))
(format stream "~%")
(if* (mime-part-encoding part)
then (format stream "Content-Transfer-Encoding: ~a~%"
(mime-part-encoding part)))
(if* (mime-part-id part)
then (format stream "Content-Id: ~a~%" (mime-part-id part)))
(if* (mime-part-description part)
then (format stream "Content-Description: ~a~%"
(mime-part-description part)))
(if* (disposition part)
then (format stream "Content-Disposition: ~a" (disposition part))
(if* (disposition-name part)
then (format stream ";~% filename=~s" (disposition-name part)))
(format stream "~%"))
(format stream "~%") ;; terminate headers
(if* multipart
then (let ((boundary (mime-part-boundary part)))
(if top-level
(format stream "~
This is a multi-part message in MIME format.~%"))
(dolist (subpart (mime-part-parts part))
(format stream "~%--~a~%" boundary)
(mime-part-constructed-writer subpart stream nil))
(format stream "~%--~a--~%" boundary))
else (let ((instream (if* (eq (source-type part) :stream)
then (source part)
elseif (eq (source-type part) :file)
then (open (source part))
else (make-buffer-input-stream (source part)))))
(unwind-protect
(let ((encoding (mime-part-encoding part)))
(if* (equalp encoding "base64")
then (excl::base64-encode-stream instream stream)
elseif (equalp encoding "quoted-printable")
then (qp-encode-stream instream stream)
else (raw-encode-stream instream stream)))
;; cleanup
(if* (not (eq (source-type part) :stream))
then (close instream)))))))
(defun mime-part-writer-1 (stream part)
(mime-part-writer part :stream stream))
(defmacro with-mime-part-constructed-stream ((stream part) &body body)
`(excl::with-function-input-stream (,stream #'mime-part-writer-1 ,part)
,@body))
;; misc
(defun map-over-parts (part function)
(funcall function part)
(if* (multipart-p part)
then (dolist (p (mime-part-parts part))
(map-over-parts p function))
elseif (message-rfc822-p (mime-part-type part) (mime-part-subtype part))
then (map-over-parts (mime-part-message part) function)))
;;
(defparameter *default-charset-to-ef*
'(("us-ascii" . :latin1)
("ansi_x3.4-1968" . :latin1)
("shift-jis" . :shiftjis)
("gbk" . :936)
#+ignore("euc-kr" :iso-2022-kr)))
(defparameter *charset-to-ef* nil)
(defparameter *charset-to-ef-lock* (mp:make-process-lock))
(defparameter *debug-charset-to-ef* nil)
(defun init-charset-to-ef ()
(let ((ht (make-hash-table :test #'equal)))
(dolist (pair *default-charset-to-ef*)
(setf (gethash (car pair) ht) (find-external-format (cdr pair) :errorp nil)))
(setf *charset-to-ef* ht)))
(defun charset-to-external-format (charset)
(setf charset (string-downcase charset))
(mp:with-process-lock (*charset-to-ef-lock*)
(if (null *charset-to-ef*)
(init-charset-to-ef))
(macrolet ((save-and-return (ef)
(let ((ef-x (gensym)))
`(let ((,ef-x ,ef))
(progn (setf (gethash charset *charset-to-ef*) ,ef-x)
(return-from charset-to-external-format ,ef-x))))))
(let ((ef (gethash charset *charset-to-ef*)))
(if ef
(return-from charset-to-external-format ef)) ;; Use cached result
(if (setf ef (find-external-format charset :errorp nil))
(save-and-return ef))
(multiple-value-bind (matched x inner)
(match-re "^windows-(\\d+)$" charset)
(declare (ignore x))
(if (and matched (setf ef (find-external-format inner :errorp nil)))
(save-and-return ef)))
(multiple-value-bind (matched x dig)
(match-re "^iso-8859-(\\d+)(?:-[ie])?$" charset)
(declare (ignore x))
(if (and matched (setf ef (find-external-format (format nil "iso8859-~a" dig) :errorp nil)))
(save-and-return ef)))
(if *debug-charset-to-ef*
(format t "no external found for ~a~%" charset))
;; No luck
nil))))
(defun decode-header-text (text)
(declare (optimize (speed 3))
(string text))
(when (null text) (error "first argument expected to be non-nil."))
(let ((pos 0)
(len (length text))
last-tail)
(declare (fixnum pos len))
(with-output-to-string (res)
(while (< pos len)
(multiple-value-bind (matched whole charset encoding encoded tail)
(match-re "=\\?([^?]+)\\?(q|b)\\?(.*?)\\?=(\\s+)?" text
:start pos
:case-fold t
:return :index)
(when (null matched)
(when last-tail
(write-string text res
:start (car last-tail) :end (cdr last-tail)))
(return))
;; Write out the "before" stuff.
(write-string text res :start pos :end (car whole))
(let* ((charset (subseq text (car charset) (cdr charset)))
(ef (charset-to-external-format charset)))
(if (null ef)
(error "No external format found for MIME charset ~s" charset))
(write-string
(if* (char-equal (char text (car encoding)) #\q)
then (qp-decode-string text
:start (car encoded)
:end (cdr encoded)
:external-format ef
:underscores-are-spaces t)
else ;; FIXME: Clean this up with/if rfe6174 is completed.
(octets-to-string
(base64-string-to-usb8-array
(subseq text (car encoded) (cdr encoded)))
:external-format ef))
res))
(setf pos (cdr whole))
(setf last-tail tail)))
;; Write out the remaining portion.
(write-string text res :start pos))))
;; Stuff ripped off from aserve
(defun split-namestring (file)
;; split the namestring into root and tail and then the tail
;; into name and type
;;
;; any of the return value can be nil if the corresponding item
;; isn't present.
;;
;; rules for splitting the tail into name and type components:
;; if the last period in the tail is at the beginning or end of the
;; tail, then the name is exactly the tail and type is nil.
;; Thus .foo and bar. are just names, no type
;; but .foo.c has a name of ".foo" and a type of "c"
;; Thus if there is a non-nil type then it means that
;; 1. there will be a non nil name as well
;; 2. to reconstruct the filename you need to add a period between
;; the name and type.
;;
(let ((pos (min (or (or (position #\/ file :from-end t) most-positive-fixnum)
#+mswindows (position #\\ file :from-end t))))
root
tail)
(if* (equal file "") then (return-from split-namestring nil))
(if* (and pos (< pos most-positive-fixnum))
then ; we have root and tail
(if* (eql pos (1- (length file)))
then ; just have root
(return-from split-namestring
(values file nil nil nil)))
(setq root (subseq file 0 (1+ pos))
tail (subseq file (1+ pos)))
else (setq tail file))
; split the tail
(let ((pos (position #\. tail :from-end t)))
(if* (or (null pos)
(zerop pos)
(equal pos (1- (length tail))))
then ; name begins or ends with . so it's not
; a type separator
(values root tail tail nil)
else ; have all pieces
(values root tail
(subseq tail 0 pos)
(subseq tail (1+ pos)))))))
; we can specify either an exact url or one that handles all
; urls with a common prefix.
;;
;; if the prefix is given as a list: e.g. ("ReadMe") then it says that
;; this mime type applie to file named ReadMe. Note that file types
;; are checked first and if no match then a filename match is done.
;
(defparameter *file-type-to-mime-type*
;; this list constructed by generate-mime-table in parse.cl
'(("application/EDI-Consent") ("application/EDI-X12") ("application/EDIFACT")
("application/activemessage") ("application/andrew-inset" "ez")
("application/applefile") ("application/atomicmail")
("application/batch-SMTP") ("application/beep+xml") ("application/cals-1840")
("application/commonground") ("application/cybercash")
("application/dca-rft") ("application/dec-dx") ("application/dvcs")
("application/eshop") ("application/http") ("application/hyperstudio")
("application/iges") ("application/index") ("application/index.cmd")
("application/index.obj") ("application/index.response")
("application/index.vnd") ("application/iotp") ("application/ipp")
("application/isup") ("application/font-tdpfr")
("application/mac-binhex40" "hqx") ("application/mac-compactpro" "cpt")
("application/macwriteii") ("application/marc") ("application/mathematica")
("application/mathematica-old") ("application/msword" "doc")
("application/news-message-id") ("application/news-transmission")
("application/ocsp-request") ("application/ocsp-response")
("application/octet-stream" "bin" "dms" "lha" "lzh" "exe" "class" "so" "dll"
"img" "iso")
("application/ogg" "ogg") ("application/parityfec") ("application/pdf" "pdf")
("application/pgp-encrypted") ("application/pgp-keys")
("application/pgp-signature") ("application/pkcs10")
("application/pkcs7-mime") ("application/pkcs7-signature")
("application/pkix-cert") ("application/pkix-crl") ("application/pkixcmp")
("application/postscript" "ai" "eps" "ps")
("application/prs.alvestrand.titrax-sheet") ("application/prs.cww")
("application/prs.nprend") ("application/qsig")
("application/remote-printing") ("application/riscos")
("application/rtf" "rtf") ("application/sdp") ("application/set-payment")
("application/set-payment-initiation") ("application/set-registration")
("application/set-registration-initiation") ("application/sgml")
("application/sgml-open-catalog") ("application/sieve") ("application/slate")
("application/smil" "smi" "smil") ("application/timestamp-query")
("application/timestamp-reply") ("application/vemmi")
("application/vnd.3M.Post-it-Notes") ("application/vnd.FloGraphIt")
("application/vnd.accpac.simply.aso") ("application/vnd.accpac.simply.imp")
("application/vnd.acucobol") ("application/vnd.aether.imp")
("application/vnd.anser-web-certificate-issue-initiation")
("application/vnd.anser-web-funds-transfer-initiation")
("application/vnd.audiograph") ("application/vnd.businessobjects")
("application/vnd.bmi") ("application/vnd.canon-cpdl")
("application/vnd.canon-lips") ("application/vnd.claymore")
("application/vnd.commerce-battelle") ("application/vnd.commonspace")
("application/vnd.comsocaller") ("application/vnd.contact.cmsg")
("application/vnd.cosmocaller") ("application/vnd.cups-postscript")
("application/vnd.cups-raster") ("application/vnd.cups-raw")
("application/vnd.ctc-posml") ("application/vnd.cybank")
("application/vnd.dna") ("application/vnd.dpgraph") ("application/vnd.dxr")
("application/vnd.ecdis-update") ("application/vnd.ecowin.chart")
("application/vnd.ecowin.filerequest") ("application/vnd.ecowin.fileupdate")
("application/vnd.ecowin.series") ("application/vnd.ecowin.seriesrequest")
("application/vnd.ecowin.seriesupdate") ("application/vnd.enliven")
("application/vnd.epson.esf") ("application/vnd.epson.msf")
("application/vnd.epson.quickanime") ("application/vnd.epson.salt")
("application/vnd.epson.ssf") ("application/vnd.ericsson.quickcall")
("application/vnd.eudora.data") ("application/vnd.fdf")
("application/vnd.ffsns") ("application/vnd.framemaker")
("application/vnd.fsc.weblaunch") ("application/vnd.fujitsu.oasys")
("application/vnd.fujitsu.oasys2") ("application/vnd.fujitsu.oasys3")
("application/vnd.fujitsu.oasysgp") ("application/vnd.fujitsu.oasysprs")
("application/vnd.fujixerox.ddd") ("application/vnd.fujixerox.docuworks")
("application/vnd.fujixerox.docuworks.binder") ("application/vnd.fut-misnet")
("application/vnd.grafeq") ("application/vnd.groove-account")
("application/vnd.groove-identity-message")
("application/vnd.groove-injector") ("application/vnd.groove-tool-message")
("application/vnd.groove-tool-template") ("application/vnd.groove-vcard")
("application/vnd.hhe.lesson-player") ("application/vnd.hp-HPGL")
("application/vnd.hp-PCL") ("application/vnd.hp-PCLXL")
("application/vnd.hp-hpid") ("application/vnd.hp-hps")
("application/vnd.httphone") ("application/vnd.hzn-3d-crossword")
("application/vnd.ibm.afplinedata") ("application/vnd.ibm.MiniPay")
("application/vnd.ibm.modcap") ("application/vnd.informix-visionary")
("application/vnd.intercon.formnet") ("application/vnd.intertrust.digibox")
("application/vnd.intertrust.nncp") ("application/vnd.intu.qbo")
("application/vnd.intu.qfx") ("application/vnd.irepository.package+xml")
("application/vnd.is-xpr") ("application/vnd.japannet-directory-service")
("application/vnd.japannet-jpnstore-wakeup")
("application/vnd.japannet-payment-wakeup")
("application/vnd.japannet-registration")
("application/vnd.japannet-registration-wakeup")
("application/vnd.japannet-setstore-wakeup")
("application/vnd.japannet-verification")
("application/vnd.japannet-verification-wakeup") ("application/vnd.koan")
("application/vnd.lotus-1-2-3") ("application/vnd.lotus-approach")
("application/vnd.lotus-freelance") ("application/vnd.lotus-notes")
("application/vnd.lotus-organizer") ("application/vnd.lotus-screencam")
("application/vnd.lotus-wordpro") ("application/vnd.mcd")
("application/vnd.mediastation.cdkey") ("application/vnd.meridian-slingshot")
("application/vnd.mif" "mif") ("application/vnd.minisoft-hp3000-save")
("application/vnd.mitsubishi.misty-guard.trustweb")
("application/vnd.mobius.daf") ("application/vnd.mobius.dis")
("application/vnd.mobius.msl") ("application/vnd.mobius.plc")
("application/vnd.mobius.txf") ("application/vnd.motorola.flexsuite")
("application/vnd.motorola.flexsuite.adsi")
("application/vnd.motorola.flexsuite.fis")
("application/vnd.motorola.flexsuite.gotap")
("application/vnd.motorola.flexsuite.kmr")
("application/vnd.motorola.flexsuite.ttc")
("application/vnd.motorola.flexsuite.wem")
("application/vnd.mozilla.xul+xml") ("application/vnd.ms-artgalry")
("application/vnd.ms-asf") ("application/vnd.ms-excel" "xls")
("application/vnd.ms-lrm") ("application/vnd.ms-powerpoint" "ppt")
("application/vnd.ms-project") ("application/vnd.ms-tnef")
("application/vnd.ms-works") ("application/vnd.mseq")
("application/vnd.msign") ("application/vnd.music-niff")
("application/vnd.musician") ("application/vnd.netfpx")
("application/vnd.noblenet-directory") ("application/vnd.noblenet-sealer")
("application/vnd.noblenet-web") ("application/vnd.novadigm.EDM")
("application/vnd.novadigm.EDX") ("application/vnd.novadigm.EXT")
("application/vnd.osa.netdeploy") ("application/vnd.palm")
("application/vnd.pg.format") ("application/vnd.pg.osasli")
("application/vnd.powerbuilder6") ("application/vnd.powerbuilder6-s")
("application/vnd.powerbuilder7") ("application/vnd.powerbuilder7-s")
("application/vnd.powerbuilder75") ("application/vnd.powerbuilder75-s")
("application/vnd.previewsystems.box")
("application/vnd.publishare-delta-tree") ("application/vnd.pvi.ptid1")
("application/vnd.pwg-xhtml-print+xml") ("application/vnd.rapid")
("application/vnd.s3sms") ("application/vnd.seemail")
("application/vnd.shana.informed.formdata")
("application/vnd.shana.informed.formtemplate")
("application/vnd.shana.informed.interchange")
("application/vnd.shana.informed.package") ("application/vnd.sss-cod")
("application/vnd.sss-dtf") ("application/vnd.sss-ntf")
("application/vnd.sun.xml.writer" "sxw")
("application/vnd.sun.xml.writer.template" "stw")
("application/vnd.sun.xml.calc" "sxc")
("application/vnd.sun.xml.calc.template" "stc")
("application/vnd.sun.xml.draw" "sxd")
("application/vnd.sun.xml.draw.template" "std")
("application/vnd.sun.xml.impress" "sxi")
("application/vnd.sun.xml.impress.template" "sti")
("application/vnd.sun.xml.writer.global" "sxg")
("application/vnd.sun.xml.math" "sxm") ("application/vnd.street-stream")
("application/vnd.svd") ("application/vnd.swiftview-ics")
("application/vnd.triscape.mxs") ("application/vnd.trueapp")
("application/vnd.truedoc") ("application/vnd.tve-trigger")
("application/vnd.ufdl") ("application/vnd.uplanet.alert")
("application/vnd.uplanet.alert-wbxml")
("application/vnd.uplanet.bearer-choice-wbxml")
("application/vnd.uplanet.bearer-choice") ("application/vnd.uplanet.cacheop")
("application/vnd.uplanet.cacheop-wbxml") ("application/vnd.uplanet.channel")
("application/vnd.uplanet.channel-wbxml") ("application/vnd.uplanet.list")
("application/vnd.uplanet.list-wbxml") ("application/vnd.uplanet.listcmd")
("application/vnd.uplanet.listcmd-wbxml") ("application/vnd.uplanet.signal")
("application/vnd.vcx") ("application/vnd.vectorworks")
("application/vnd.vidsoft.vidconference") ("application/vnd.visio")
("application/vnd.vividence.scriptfile") ("application/vnd.wap.sic")
("application/vnd.wap.slc") ("application/vnd.wap.wbxml" "wbxml")
("application/vnd.wap.wmlc" "wmlc")
("application/vnd.wap.wmlscriptc" "wmlsc") ("application/vnd.webturbo")
("application/vnd.wrq-hp3000-labelled") ("application/vnd.wt.stf")
("application/vnd.xara") ("application/vnd.xfdl")
("application/vnd.yellowriver-custom-menu") ("application/whoispp-query")
("application/whoispp-response") ("application/wita")
("application/wordperfect5.1") ("application/x-bcpio" "bcpio")
("application/x-bittorrent" "torrent") ("application/x-bzip2" "bz2")
("application/x-cdlink" "vcd") ("application/x-chess-pgn" "pgn")
("application/x-compress") ("application/x-cpio" "cpio")
("application/x-csh" "csh") ("application/x-director" "dcr" "dir" "dxr")
("application/x-dvi" "dvi") ("application/x-futuresplash" "spl")
("application/x-gtar" "gtar") ("application/x-gzip" "gz" "tgz")
("application/x-hdf" "hdf") ("application/x-javascript" "js")
("application/x-kword" "kwd" "kwt") ("application/x-kspread" "ksp")
("application/x-kpresenter" "kpr" "kpt") ("application/x-kchart" "chrt")
("application/x-killustrator" "kil")
("application/x-koan" "skp" "skd" "skt" "skm")
("application/x-latex" "latex") ("application/x-netcdf" "nc" "cdf")
("application/x-rpm" "rpm") ("application/x-sh" "sh")
("application/x-shar" "shar") ("application/x-shockwave-flash" "swf")
("application/x-stuffit" "sit") ("application/x-sv4cpio" "sv4cpio")
("application/x-sv4crc" "sv4crc") ("application/x-tar" "tar")
("application/x-tcl" "tcl") ("application/x-tex" "tex")
("application/x-texinfo" "texinfo" "texi")
("application/x-troff" "t" "tr" "roff") ("application/x-troff-man" "man")
("application/x-troff-me" "me") ("application/x-troff-ms" "ms")
("application/x-ustar" "ustar") ("application/x-wais-source" "src")
("application/x400-bp") ("application/xhtml+xml" "xhtml" "xht")
("application/xml") ("application/xml-dtd")
("application/xml-external-parsed-entity") ("application/zip" "zip")
("audio/32kadpcm") ("audio/basic" "au" "snd") ("audio/g.722.1") ("audio/l16")
("audio/midi" "mid" "midi" "kar") ("audio/mp4a-latm") ("audio/mpa-robust")
("audio/mpeg" "mpga" "mp2" "mp3") ("audio/parityfec") ("audio/prs.sid")
("audio/telephone-event") ("audio/tone") ("audio/vnd.cisco.nse")
("audio/vnd.cns.anp1") ("audio/vnd.cns.inf1") ("audio/vnd.digital-winds")
("audio/vnd.everad.plj") ("audio/vnd.lucent.voice") ("audio/vnd.nortel.vbk")
("audio/vnd.nuera.ecelp4800") ("audio/vnd.nuera.ecelp7470")
("audio/vnd.nuera.ecelp9600") ("audio/vnd.octel.sbc") ("audio/vnd.qcelp")
("audio/vnd.rhetorex.32kadpcm") ("audio/vnd.vmx.cvsd")
("audio/x-aiff" "aif" "aiff" "aifc") ("audio/x-mpegurl" "m3u")
("audio/x-pn-realaudio" "ram" "rm") ("audio/x-realaudio" "ra")
("audio/x-wav" "wav") ("chemical/x-pdb" "pdb") ("chemical/x-xyz" "xyz")
("image/bmp" "bmp") ("image/cgm") ("image/g3fax") ("image/gif" "gif")
("image/ief" "ief") ("image/jpeg" "jpeg" "jpg" "jpe") ("image/naplps")
("image/png" "png") ("image/prs.btif") ("image/prs.pti")
("image/tiff" "tiff" "tif") ("image/vnd.cns.inf2")
("image/vnd.djvu" "djvu" "djv") ("image/vnd.dwg") ("image/vnd.dxf")
("image/vnd.fastbidsheet") ("image/vnd.fpx") ("image/vnd.fst")
("image/vnd.fujixerox.edmics-mmr") ("image/vnd.fujixerox.edmics-rlc")
("image/vnd.mix") ("image/vnd.net-fpx") ("image/vnd.svf")
("image/vnd.wap.wbmp" "wbmp") ("image/vnd.xiff") ("image/x-cmu-raster" "ras")
("image/x-portable-anymap" "pnm") ("image/x-portable-bitmap" "pbm")
("image/x-portable-graymap" "pgm") ("image/x-portable-pixmap" "ppm")
("image/x-rgb" "rgb") ("image/x-xbitmap" "xbm") ("image/x-xpixmap" "xpm")
("image/x-xwindowdump" "xwd") ("message/delivery-status")
("message/disposition-notification") ("message/external-body")
("message/http") ("message/news") ("message/partial") ("message/rfc822")
("message/s-http") ("model/iges" "igs" "iges")
("model/mesh" "msh" "mesh" "silo") ("model/vnd.dwf")
("model/vnd.flatland.3dml") ("model/vnd.gdl") ("model/vnd.gs-gdl")
("model/vnd.gtw") ("model/vnd.mts") ("model/vnd.vtu")
("model/vrml" "wrl" "vrml") ("multipart/alternative")
("multipart/appledouble") ("multipart/byteranges") ("multipart/digest")
("multipart/encrypted") ("multipart/form-data") ("multipart/header-set")
("multipart/mixed") ("multipart/parallel") ("multipart/related")
("multipart/report") ("multipart/signed") ("multipart/voice-message")
("text/calendar") ("text/css" "css") ("text/directory") ("text/enriched")
("text/html" "html" "htm") ("text/parityfec") ("text/plain" "asc" "txt")
("text/prs.lines.tag") ("text/rfc822-headers") ("text/richtext" "rtx")
("text/rtf" "rtf") ("text/sgml" "sgml" "sgm")
("text/tab-separated-values" "tsv") ("text/t140") ("text/uri-list")
("text/vnd.DMClientScript") ("text/vnd.IPTC.NITF") ("text/vnd.IPTC.NewsML")
("text/vnd.abc") ("text/vnd.curl") ("text/vnd.flatland.3dml")
("text/vnd.fly") ("text/vnd.fmi.flexstor") ("text/vnd.in3d.3dml")
("text/vnd.in3d.spot") ("text/vnd.latex-z") ("text/vnd.motorola.reflex")
("text/vnd.ms-mediapackage") ("text/vnd.wap.si") ("text/vnd.wap.sl")
("text/vnd.wap.wml" "wml") ("text/vnd.wap.wmlscript" "wmls")
("text/x-setext" "etx") ("text/xml" "xml" "xsl")
("text/xml-external-parsed-entity") ("video/mp4v-es")
("video/mpeg" "mpeg" "mpg" "mpe") ("video/parityfec") ("video/pointer")
("video/quicktime" "qt" "mov") ("video/vnd.fvt") ("video/vnd.motorola.video")
("video/vnd.motorola.videop") ("video/vnd.mpegurl" "mxu") ("video/vnd.mts")
("video/vnd.nokia.interleaved-multimedia") ("video/vnd.vivo")
("video/x-msvideo" "avi") ("video/x-sgi-movie" "movie")
("x-conference/x-cooltalk" "ice")))
(defvar *mime-types* nil)
(defun build-mime-types-table ()
(if* (null *mime-types*)
then (setf *mime-types* (make-hash-table :test #'equalp))
(dolist (ent *file-type-to-mime-type*)
(dolist (type (cdr ent))
(setf (gethash type *mime-types*) (car ent))))))
(build-mime-types-table) ;; build the table now
;; return mime type if known
(defmethod lookup-mime-type (filename)
(if* (pathnamep filename)
then (setq filename (namestring filename)))
(multiple-value-bind (root tail name type)
(split-namestring filename)
(declare (ignore root name))
(if* (and type (gethash type *mime-types*))
thenret
elseif (gethash (list tail) *mime-types*)
thenret)))