-
Notifications
You must be signed in to change notification settings - Fork 0
/
print-mime.lisp
108 lines (93 loc) · 3.59 KB
/
print-mime.lisp
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; print-mime.lisp: Tools for printing a mime object
;;;; Copyright (C) 2004 Robert Marlow <bobstopper@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 add-to-print-headers (key alist headers-out)
"Adds a requested header from the provided alist to a printable
headers string"
(aif (assoc key alist)
(concatenate 'string headers-out
(format nil "~A: ~A~%"
(if (eql :mime-version (car it))
"MIME-Version"
(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))
;;; Note that the way we print the headers, other than type-compulsory
;;; content-type parameters, all parameters are folded as per RFC822, once
;;; for each parameter such that each parameter begins a new line. This is
;;; so header lines don't get too long and so we don't have to fuss about
;;; too much counting line length and figuring out where to break up long
;;; lines. I couldn't find anything in the RFC which prohibited this so
;;; I'm taking the easy route.
(defun print-headers (stream headers version-p)
"Prints headers in the provided assoc-list"
(let ((headers-to-print '(:content-type
:content-transfer-encoding
:content-description
:content-id
:content-disposition))
(headers-out ""))
(if version-p
(push :mime-version headers-to-print))
(mapc (lambda (header-key)
(setq headers-out
(add-to-print-headers header-key
headers
headers-out)))
headers-to-print)
(format stream "~A" headers-out)))
(defgeneric print-mime (stream mime-obj headers-p version-p)
(: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
(concatenate 'string
(print-headers nil (get-mime-headers mime-obj)
version-p)
(string #\newline))
"")
(encode-content mime-obj)))
(defmethod print-mime (stream (mime-obj multipart-mime) headers-p version-p)
(format stream "~A~%~A~{~{--~A~%~:/mime:print-mime/~%~}~}~%--~A--~%~A"
(if headers-p
(concatenate 'string
(print-headers nil (get-mime-headers mime-obj)
version-p)
(string #\newline))
"")
(aif (prologue mime-obj)
(concatenate 'string it (string #\newline))
"")
(mapcar (lambda (mime-child)
(list
(boundary mime-obj)
mime-child))
(content mime-obj))
(boundary mime-obj)
(aif (epilogue mime-obj)
(concatenate 'string it (string #\newline))
"")))