(eword-decode-string, eword-decode-region): Mention language info in doc string.
[elisp/flim.git] / mime.el
1 ;;; mime.el --- MIME library module
2
3 ;; Copyright (C) 1998,1999,2000,2001,2003 Free Software Foundation, Inc.
4
5 ;; Author: MORIOKA Tomohiko <tomo@m17n.org>
6 ;; Keywords: MIME, multimedia, mail, news
7
8 ;; This file is part of FLIM (Faithful Library about Internet Message).
9
10 ;; This program is free software; you can redistribute it and/or
11 ;; modify it under the terms of the GNU General Public License as
12 ;; published by the Free Software Foundation; either version 2, or (at
13 ;; your option) any later version.
14
15 ;; This program is distributed in the hope that it will be useful, but
16 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
18 ;; General Public License for more details.
19
20 ;; You should have received a copy of the GNU General Public License
21 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
22 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
23 ;; Boston, MA 02110-1301, USA.
24
25 ;;; Code:
26
27 (require 'alist)
28 (require 'std11)
29 (require 'mime-def)
30 (require 'eword-decode)
31
32 (eval-when-compile (require 'mmgeneric))
33
34 (eval-and-compile
35
36 (autoload 'mime-encode-header-in-buffer "eword-encode"
37   "Encode header fields to network representation, such as MIME encoded-word.")
38
39 (autoload 'mime-parse-Content-Type "mime-parse"
40   "Parse STRING as field-body of Content-Type field.")
41 (autoload 'mime-read-Content-Type "mime-parse"
42   "Read field-body of Content-Type field from current-buffer,
43 and return parsed it.")
44
45 (autoload 'mime-parse-Content-Disposition "mime-parse"
46   "Parse STRING as field-body of Content-Disposition field.")
47 (autoload 'mime-read-Content-Disposition "mime-parse"
48   "Read field-body of Content-Disposition field from current-buffer,
49 and return parsed it.")
50
51 (autoload 'mime-parse-Content-Transfer-Encoding "mime-parse"
52   "Parse STRING as field-body of Content-Transfer-Encoding field.")
53 (autoload 'mime-read-Content-Transfer-Encoding "mime-parse"
54   "Read field-body of Content-Transfer-Encoding field from
55 current-buffer, and return it.")
56
57 (autoload 'mime-parse-msg-id "mime-parse"
58   "Parse TOKENS as msg-id of Content-Id or Message-Id field.")
59
60 (autoload 'mime-uri-parse-cid "mime-parse"
61   "Parse STRING as cid URI.")
62
63 (autoload 'mime-parse-buffer "mime-parse"
64   "Parse BUFFER as a MIME message.")
65
66 )
67
68 (autoload 'mime-encode-field-body "eword-encode"
69   "Encode FIELD-BODY as FIELD-NAME, and return the result.")
70
71
72 ;;; @ Entity Representation and Implementation
73 ;;;
74
75 (defmacro mime-entity-send (entity message &rest args)
76   `(luna-send ,entity ',(intern (format "mime-%s" (eval message))) ,@args))
77
78 (defun mime-open-entity (type location)
79   "Open an entity and return it.
80 TYPE is representation-type.
81 LOCATION is location of entity.  Specification of it is depended on
82 representation-type."
83   (require (intern (format "mm%s" type)))
84   (luna-make-entity (mm-expand-class-name type) :location location))
85
86 (luna-define-generic mime-entity-cooked-p (entity)
87   "Return non-nil if contents of ENTITY has been already code-converted.")
88
89
90 ;;; @ Entity as node of message
91 ;;;
92
93 (defun mime-entity-children (entity)
94   "Return list of entities included in the ENTITY."
95   (or (mime-entity-children-internal entity)
96       (luna-send entity 'mime-entity-children entity)))
97
98 (defun mime-entity-node-id (entity)
99   "Return node-id of ENTITY."
100   (mime-entity-node-id-internal entity))
101
102 (defun mime-entity-number (entity)
103   "Return entity-number of ENTITY."
104   (reverse (mime-entity-node-id-internal entity)))
105
106 (defun mime-find-entity-from-number (entity-number message)
107   "Return entity from ENTITY-NUMBER in MESSAGE."
108   (let ((sn (car entity-number)))
109     (if (null sn)
110         message
111       (let ((rc (nth sn (mime-entity-children message))))
112         (if rc
113             (mime-find-entity-from-number (cdr entity-number) rc)
114           ))
115       )))
116
117 (defun mime-find-entity-from-node-id (entity-node-id message)
118   "Return entity from ENTITY-NODE-ID in MESSAGE."
119   (mime-find-entity-from-number (reverse entity-node-id) message))
120
121 (defun mime-find-entity-from-content-id (cid message)
122   "Return entity from CID in MESSAGE."
123   (if (equal cid (mime-entity-read-field message "Content-Id"))
124       message
125     (let ((children (mime-entity-children message))
126           ret)
127       (while (and children
128                   (null (setq ret (mime-find-entity-from-content-id
129                                    cid (car children)))))
130         (setq children (cdr children)))
131       ret)))
132
133 (defun mime-entity-parent (entity &optional message)
134   "Return mother entity of ENTITY.
135 If MESSAGE is specified, it is regarded as root entity."
136   (if (equal entity message)
137       nil
138     (mime-entity-parent-internal entity)))
139
140 (defun mime-root-entity-p (entity &optional message)
141   "Return t if ENTITY is root-entity (message).
142 If MESSAGE is specified, it is regarded as root entity."
143   (null (mime-entity-parent entity message)))
144
145 (defun mime-find-root-entity (entity)
146   "Return root entity of ENTITY."
147   (while (not (mime-root-entity-p entity))
148     (setq entity (mime-entity-parent entity)))
149   entity)
150
151
152 ;;; @ Header buffer (obsolete)
153 ;;;
154
155 ;; (luna-define-generic mime-entity-header-buffer (entity))
156
157 ;; (luna-define-generic mime-goto-header-start-point (entity)
158 ;;   "Set buffer and point to header-start-position of ENTITY.")
159
160 ;; (luna-define-generic mime-entity-header-start-point (entity)
161 ;;   "Return header-start-position of ENTITY.")
162
163 ;; (luna-define-generic mime-entity-header-end-point (entity)
164 ;;   "Return header-end-position of ENTITY.")
165
166 ;; (make-obsolete 'mime-entity-header-buffer "don't use it.")
167 ;; (make-obsolete 'mime-goto-header-start-point "don't use it.")
168 ;; (make-obsolete 'mime-entity-header-start-point "don't use it.")
169 ;; (make-obsolete 'mime-entity-header-end-point "don't use it.")
170
171
172 ;;; @ Body buffer (obsolete)
173 ;;;
174
175 ;; (luna-define-generic mime-entity-body-buffer (entity))
176
177 ;; (luna-define-generic mime-goto-body-start-point (entity)
178 ;;   "Set buffer and point to body-start-position of ENTITY.")
179
180 ;; (luna-define-generic mime-goto-body-end-point (entity)
181 ;;   "Set buffer and point to body-end-position of ENTITY.")
182
183 ;; (luna-define-generic mime-entity-body-start-point (entity)
184 ;;   "Return body-start-position of ENTITY.")
185
186 ;; (luna-define-generic mime-entity-body-end-point (entity)
187 ;;   "Return body-end-position of ENTITY.")
188
189 ;; (defalias 'mime-entity-body-start 'mime-entity-body-start-point)
190 ;; (defalias 'mime-entity-body-end 'mime-entity-body-end-point)
191
192 ;; (make-obsolete 'mime-entity-body-buffer "don't use it.")
193 ;; (make-obsolete 'mime-goto-body-start-point "don't use it.")
194 ;; (make-obsolete 'mime-goto-body-end-point "don't use it.")
195 ;; (make-obsolete 'mime-entity-body-start-point "don't use it.")
196 ;; (make-obsolete 'mime-entity-body-end-point "don't use it.")
197 ;; (make-obsolete 'mime-entity-body-start "don't use it.")
198 ;; (make-obsolete 'mime-entity-body-end "don't use it.")
199
200
201 ;;; @ Entity buffer (obsolete)
202 ;;;
203
204 ;; (luna-define-generic mime-entity-buffer (entity))
205 ;; (make-obsolete 'mime-entity-buffer "don't use it.")
206
207 ;; (luna-define-generic mime-entity-point-min (entity))
208 ;; (make-obsolete 'mime-entity-point-min "don't use it.")
209
210 ;; (luna-define-generic mime-entity-point-max (entity))
211 ;; (make-obsolete 'mime-entity-point-max "don't use it.")
212
213
214 ;;; @ Entity
215 ;;;
216
217 (luna-define-generic mime-insert-entity (entity)
218   "Insert header and body of ENTITY at point.")
219
220 (luna-define-generic mime-write-entity (entity filename)
221   "Write header and body of ENTITY into FILENAME.")
222
223
224 ;;; @ Entity Body
225 ;;;
226
227 (luna-define-generic mime-entity-body (entity)
228   "Return network representation of ENTITY body.")
229
230 (luna-define-generic mime-insert-entity-body (entity)
231   "Insert network representation of ENTITY body at point.")
232
233 (luna-define-generic mime-write-entity-body (entity filename)
234   "Write body of ENTITY into FILENAME.")
235
236
237 ;;; @ Entity Content
238 ;;;
239
240 (luna-define-generic mime-entity-content (entity)
241   "Return content of ENTITY as byte sequence (string).")
242
243 (luna-define-generic mime-insert-entity-content (entity)
244   "Insert content of ENTITY at point.")
245
246 (luna-define-generic mime-write-entity-content (entity filename)
247   "Write content of ENTITY into FILENAME.")
248
249 (luna-define-generic mime-insert-text-content (entity)
250   "Insert decoded text body of ENTITY.")
251
252
253 ;;; @ Header fields
254 ;;;
255
256 (luna-define-generic mime-entity-fetch-field (entity field-name)
257   "Return the value of the ENTITY's header field whose type is FIELD-NAME.")
258
259 ;; (defun mime-fetch-field (field-name &optional entity)
260 ;;   "Return the value of the ENTITY's header field whose type is FIELD-NAME."
261 ;;   (if (symbolp field-name)
262 ;;       (setq field-name (symbol-name field-name))
263 ;;     )
264 ;;   (or entity
265 ;;       (setq entity mime-message-structure))
266 ;;   (mime-entity-fetch-field entity field-name)
267 ;;   )
268 ;; (make-obsolete 'mime-fetch-field 'mime-entity-fetch-field)
269
270 (defun mime-entity-content-type (entity)
271   "Return content-type of ENTITY."
272   (or (mime-entity-content-type-internal entity)
273       (let ((ret (mime-entity-fetch-field entity "Content-Type")))
274         (if ret
275             (mime-entity-set-content-type-internal
276              entity (mime-parse-Content-Type ret))
277           ))))
278
279 (defun mime-entity-content-disposition (entity)
280   "Return content-disposition of ENTITY."
281   (or (mime-entity-content-disposition-internal entity)
282       (let ((ret (mime-entity-fetch-field entity "Content-Disposition")))
283         (if ret
284             (mime-entity-set-content-disposition-internal
285              entity (mime-parse-Content-Disposition ret))
286           ))))
287
288 (defun mime-entity-encoding (entity &optional default-encoding)
289   "Return content-transfer-encoding of ENTITY.
290 If the ENTITY does not have Content-Transfer-Encoding field, this
291 function returns DEFAULT-ENCODING.  If it is nil, \"7bit\" is used as
292 default value."
293   (or (mime-entity-encoding-internal entity)
294       (let ((ret (mime-entity-fetch-field entity "Content-Transfer-Encoding")))
295         (mime-entity-set-encoding-internal
296          entity
297          (or (and ret (mime-parse-Content-Transfer-Encoding ret))
298              default-encoding "7bit"))
299         )))
300
301 (defvar mime-field-parser-alist
302   '((Return-Path        . std11-parse-route-addr)
303     
304     (Reply-To           . std11-parse-addresses)
305     
306     (Sender             . std11-parse-mailbox)
307     (From               . std11-parse-addresses)
308
309     (Resent-Reply-To    . std11-parse-addresses)
310     
311     (Resent-Sender      . std11-parse-mailbox)
312     (Resent-From        . std11-parse-addresses)
313
314     (To                 . std11-parse-addresses)
315     (Resent-To          . std11-parse-addresses)
316     (Cc                 . std11-parse-addresses)
317     (Resent-Cc          . std11-parse-addresses)
318     (Bcc                . std11-parse-addresses)
319     (Resent-Bcc         . std11-parse-addresses)
320     
321     (Message-Id         . mime-parse-msg-id)
322     (Recent-Message-Id  . mime-parse-msg-id)
323     
324     (In-Reply-To        . std11-parse-msg-ids)
325     (References         . std11-parse-msg-ids)
326     
327     (Content-Id         . mime-parse-msg-id)
328     ))
329
330 (defun mime-entity-read-field (entity field-name)
331   (let ((sym (if (symbolp field-name)
332                  (prog1
333                      field-name
334                    (setq field-name (symbol-name field-name)))
335                (intern (capitalize field-name)))))
336     (cond ((eq sym 'Content-Type)
337            (mime-entity-content-type entity)
338            )
339           ((eq sym 'Content-Disposition)
340            (mime-entity-content-disposition entity)
341            )
342           ((eq sym 'Content-Transfer-Encoding)
343            (mime-entity-encoding entity)
344            )
345           (t
346            (let* ((header (mime-entity-parsed-header-internal entity))
347                   (field (cdr (assq sym header))))
348              (or field
349                  (let ((field-body (mime-entity-fetch-field entity field-name))
350                        parser)
351                    (when field-body
352                      (setq parser
353                            (cdr (assq sym mime-field-parser-alist)))
354                      (setq field
355                            (if parser
356                                (funcall parser
357                                         (eword-lexical-analyze field-body))
358                              (mime-decode-field-body field-body sym 'plain)
359                              ))
360                      (mime-entity-set-parsed-header-internal
361                       entity (put-alist sym field header))
362                      field))))))))
363
364 ;; (defun mime-read-field (field-name &optional entity)
365 ;;   (or entity
366 ;;       (setq entity mime-message-structure))
367 ;;   (mime-entity-read-field entity field-name)
368 ;;   )
369 ;; (make-obsolete 'mime-read-field 'mime-entity-read-field)
370
371 (luna-define-generic mime-insert-header (entity &optional invisible-fields
372                                                 visible-fields)
373   "Insert before point a decoded header of ENTITY.")
374
375
376 ;;; @ Entity Attributes
377 ;;;
378
379 (luna-define-generic mime-entity-name (entity)
380   "Return name of the ENTITY.")
381
382 (defun mime-entity-uu-filename (entity)
383   (if (member (mime-entity-encoding entity) mime-uuencode-encoding-name-list)
384       (with-temp-buffer
385         (mime-insert-entity-body entity)
386         (if (re-search-forward "^begin [0-9]+ " nil t)
387             (if (looking-at ".+$")
388                 (buffer-substring (match-beginning 0)(match-end 0))
389               )))))
390
391 ;; unlimited patch by simm-emacs@fan.gr.jp
392 ;;   Mon, 10 Jan 2000 12:59:46 +0900
393 (defun mime-entity-filename (entity)
394   "Return filename of ENTITY."
395   (let ((filename
396          (or (mime-entity-uu-filename entity)
397              (mime-content-disposition-filename
398               (mime-entity-content-disposition entity))
399              (cdr (let ((param (mime-content-type-parameters
400                                 (mime-entity-content-type entity))))
401                     (or (assoc "name" param)
402                         (assoc "x-name" param))))
403              "")))
404     (or (and mime-decode-unlimited
405              (string-match "\033" filename)
406              (decode-mime-charset-string filename 'iso-2022-jp 'CRLF))
407         (eword-decode-string filename))))
408
409
410 (defsubst mime-entity-media-type (entity)
411   "Return primary media-type of ENTITY."
412   (mime-content-type-primary-type (mime-entity-content-type entity)))
413
414 (defsubst mime-entity-media-subtype (entity)
415   "Return media-subtype of ENTITY."
416   (mime-content-type-subtype (mime-entity-content-type entity)))
417
418 (defsubst mime-entity-parameters (entity)
419   "Return parameters of Content-Type of ENTITY."
420   (mime-content-type-parameters (mime-entity-content-type entity)))
421
422 (defsubst mime-entity-type/subtype (entity-info)
423   "Return type/subtype of Content-Type of ENTITY."
424   (mime-type/subtype-string (mime-entity-media-type entity-info)
425                             (mime-entity-media-subtype entity-info)))
426
427 (defun mime-entity-set-content-type (entity content-type)
428   "Set ENTITY's content-type to CONTENT-TYPE."
429   (mime-entity-set-content-type-internal entity content-type))
430
431 (defun mime-entity-set-encoding (entity encoding)
432   "Set ENTITY's content-transfer-encoding to ENCODING."
433   (mime-entity-set-encoding-internal entity encoding))
434
435
436 ;;; @ unlimited patch
437 ;;;
438
439 ;; unlimited patch by simm-emacs@fan.gr.jp (code derives from irchat-pj)
440 ;;   Tue, 01 Feb 2000 01:42:05 +0900
441 (defun mime-detect-coding-system-region-unlimited (beg end)
442   "Detect coding system on region."
443   (let (ch esc prev flag)
444     (save-excursion
445       (catch 'detect
446         ;; check ISO-2022-JP / ascii
447         (catch 'quit
448           (goto-char beg)
449           (while (< (point) end)
450             (setq ch (following-char))
451             (and (<= 256 ch)
452                  (throw 'detect nil)) ;;'noconv))
453             (and (<= 128 ch)
454                  (throw 'quit t))
455             (and (= 27 ch)
456                  (setq esc t))
457             (forward-char 1))
458           (throw 'detect (if esc 'iso-2022-jp nil))) ;;'noconv)))
459         ;; check EUC-JP / SHIFT-JIS
460         (if esc (throw 'detect 'iso-2022-jp))
461         (while (< (point) end)
462           (setq ch (following-char))
463           (or (and (= 27 ch)                        ;; ESC
464                    (throw 'detect 'iso-2022-jp))
465               (and (<= 128 ch) (<= ch 141)          ;; 0x80 <= ch <= 0x8d
466                    (throw 'detect 'shift_jis))
467               (and (<= 144 ch) (<= ch 159)          ;; 0x90 <= ch <= 0x9f
468                    (throw 'detect 'shift_jis))
469               (and (eq 'shift_jis prev) (<= ch 127) ;; second byte MSB == 0
470                    (throw 'detect 'shift_jis))
471               (and (eq 'euc-jp prev)
472                    (<= 161 ch) (<= ch 243)          ;; second byte of EUC Kana
473                    (setq prev nil
474                          flag 'euc-jp))
475               (and (eq nil prev)
476                    (or (= 164 ch) (= 165 ch))       ;; first byte of EUC kana
477                    (setq prev 'euc-jp))
478               (< ch 160)                            ;;         ch <= 0xa0
479               (and (eq 'euc-jp prev)
480                    (throw 'detect 'euc-jp))
481               (setq prev (if prev nil 'shift_jis)
482                     flag (if (eq 'euc-jp flag) 'euc-jp 'shift_jis)))
483           (forward-char 1))
484         flag))))
485         ;;(or flag 'noconv)))))
486
487 ;; unlimited patch by simm-emacs@fan.gr.jp
488 ;;   Tue, 01 Feb 2000 01:56:38 +0900
489 (defun mime-detect-coding-system-string-unlimited (str)
490   "Detect coding system on string."
491   (save-excursion
492     (set-buffer (get-buffer-create " *Temporary unlimited*"))
493     (insert str)
494     (unwind-protect
495         (mime-detect-coding-system-region-unlimited (point-min) (point-max))
496       (kill-buffer nil))))
497
498 ;; unlimited patch by simm-emacs@fan.gr.jp
499 ;;   Tue, 01 Feb 2000 13:32:14 +0900
500 (defsubst insert-unlimited (str)
501   "Insert with no-conversion.
502 On GNU Emacs 20.*, (insert str) after (set-buffer-multibyte nil).
503 Other environment, perform (insert str)."
504   (static-if (boundp 'nonascii-translation-table-unlimited)
505       (let ((nonascii-translation-table nonascii-translation-table-unlimited))
506         (insert str))
507     (insert str)))
508
509 (defun decode-mime-charset-string-dist-unlimited (str charset &optional lbt)
510   "Detect coding system on string."
511   (if (not (eq 'auto-detect charset))
512       (decode-mime-charset-string str charset lbt)
513     (save-excursion
514       (set-buffer (get-buffer-create " *Temporary unlimited*"))
515       (unwind-protect
516           (let (code)
517             (insert-unlimited str)
518             (setq code (mime-detect-coding-system-region-unlimited (point-min) (point-max)))
519             (cond ((eq code 'euc-jp)
520                    (message "EUC-JP code detected, so convert this message."))
521                   ((eq code 'shift_jis)
522                    (message "SHIFT-JIS code detected, so convert this message.")))
523             (decode-mime-charset-region (point-min) (point-max)
524                                         (or code default-mime-charset)
525                                         lbt)
526             (buffer-substring (point-min) (point-max)))
527         (kill-buffer nil)))))
528
529 (defun decode-mime-charset-string-unlimited (str charset &optional lbt)
530   "Detect coding system on string."
531   (cond ((eq 'auto-detect charset)
532          (save-excursion
533            (set-buffer (get-buffer-create " *Temporary unlimited*"))
534            (unwind-protect
535                (let (code)
536                  (insert-unlimited str)
537                  (setq code
538                        (mime-detect-coding-system-region-unlimited (point-min) (point-max)))
539                  (cond ((eq code 'euc-jp)
540                         (message "EUC-JP code detected, so convert this message."))
541                        ((eq code 'shift_jis)
542                         (message "SHIFT-JIS code detected, so convert this message.")))
543                  (decode-mime-charset-region (point-min) (point-max)
544                                              (or code default-mime-charset)
545                                              lbt)
546                  (buffer-substring (point-min) (point-max)))
547              (kill-buffer nil))))
548         ((string= "us-ascii" charset)
549          (save-excursion
550            (set-buffer (get-buffer-create " *Temporary unlimited*"))
551            (unwind-protect
552                (let ((code 'us-ascii))
553                  (insert-unlimited str)
554                  (goto-char (point-min))
555                  (while (not (eobp))
556                    (if (and (<= 32 (following-char)) (< (following-char) 128))
557                        (forward-char 1)
558                      (setq code nil)
559                      (goto-char (point-max))))
560                  (cond ((eq code 'us-ascii)
561                         (decode-mime-charset-region (point-min) (point-max) nil lbt))
562                        (code
563                         (decode-mime-charset-region (point-min) (point-max) code lbt))
564                        (t
565                         (setq code
566                               (mime-detect-coding-system-region-unlimited
567                                (point-min) (point-max)))
568                         (when code
569                           (message "Declared US-ASCII but detected %s, so convert."
570                                    (if (eq code 'shift_jis) "SHIFT-JIS"
571                                      (upcase (prin1-to-string code))))
572                           (decode-mime-charset-region (point-min) (point-max)
573                                                       (or code default-mime-charset)
574                                                       lbt))))
575                  (buffer-substring (point-min) (point-max)))
576              (kill-buffer nil))))
577         (t
578          (decode-mime-charset-string str charset lbt))))
579
580 ;;; @ end
581 ;;;
582
583 (provide 'mime)
584
585 ;;; mime.el ends here