Merge `deisui-1_14_0-1'.
[elisp/flim.git] / eword-encode.el
1 ;;; eword-encode.el --- RFC 2047 based encoded-word encoder for GNU Emacs
2
3 ;; Copyright (C) 1995,1996,1997,1998,1999 Free Software Foundation, Inc.
4
5 ;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
6 ;; Keywords: encoded-word, MIME, multilingual, header, 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., 59 Temple Place - Suite 330,
23 ;; Boston, MA 02111-1307, USA.
24
25 ;;; Code:
26
27 (require 'mime-def)
28 (require 'mel)
29 (require 'std11)
30 (require 'eword-decode)
31
32
33 ;;; @ variables
34 ;;;
35
36 (defgroup eword-encode nil
37   "Encoded-word encoding"
38   :group 'mime)
39
40 (defcustom eword-field-encoding-method-alist
41   '(("X-Nsubject" . iso-2022-jp-2)
42     ("Newsgroups" . nil)
43     ("Message-ID" . nil)
44     (t            . mime)
45     )
46   "*Alist to specify field encoding method.
47 Its key is field-name, value is encoding method.
48
49 If method is `mime', this field will be encoded into MIME format.
50
51 If method is a MIME-charset, this field will be encoded as the charset
52 when it must be convert into network-code.
53
54 If method is `default-mime-charset', this field will be encoded as
55 variable `default-mime-charset' when it must be convert into
56 network-code.
57
58 If method is nil, this field will not be encoded."
59   :group 'eword-encode
60   :type '(repeat (cons (choice :tag "Field"
61                                (string :tag "Name")
62                                (const :tag "Default" t))
63                        (choice :tag "Method"
64                                (const :tag "MIME conversion" mime)
65                                (symbol :tag "non-MIME conversion")
66                                (const :tag "no-conversion" nil)))))
67
68 (defvar eword-charset-encoding-alist
69   '((us-ascii           . nil)
70     (iso-8859-1         . "Q")
71     (iso-8859-2         . "Q")
72     (iso-8859-3         . "Q")
73     (iso-8859-4         . "Q")
74     (iso-8859-5         . "Q")
75     (koi8-r             . "Q")
76     (iso-8859-7         . "Q")
77     (iso-8859-8         . "Q")
78     (iso-8859-9         . "Q")
79     (iso-2022-jp        . "B")
80     (iso-2022-jp-3      . "B")
81     (iso-2022-kr        . "B")
82     (gb2312             . "B")
83     (cn-gb              . "B")
84     (cn-gb-2312         . "B")
85     (euc-kr             . "B")
86     (tis-620            . "B")
87     (iso-2022-jp-2      . "B")
88     (iso-2022-int-1     . "B")
89     (utf-8              . "B")
90     ))
91
92
93 ;;; @ encoded-text encoder
94 ;;;
95
96 (defun eword-encode-text (charset encoding string &optional mode)
97   "Encode STRING as an encoded-word, and return the result.
98 CHARSET is a symbol to indicate MIME charset of the encoded-word.
99 ENCODING allows \"B\" or \"Q\".
100 MODE is allows `text', `comment', `phrase' or nil.  Default value is
101 `phrase'."
102   (let ((text (encoded-text-encode-string string encoding)))
103     (if text
104         (concat "=?" (upcase (symbol-name charset)) "?"
105                 encoding "?" text "?=")
106       )))
107
108
109 ;;; @ charset word
110 ;;;
111
112 (defsubst eword-encode-char-type (character)
113   (if (memq character '(?  ?\t ?\n))
114       nil
115     (char-charset character)
116     ))
117
118 (defun eword-encode-divide-into-charset-words (string)
119   (let ((len (length string))
120         dest)
121     (while (> len 0)
122       (let* ((chr (sref string 0))
123              (charset (eword-encode-char-type chr))
124              (i (char-length chr)))
125         (while (and (< i len)
126                     (setq chr (sref string i))
127                     (eq charset (eword-encode-char-type chr))
128                     )
129           (setq i (char-next-index chr i))
130           )
131         (setq dest (cons (cons charset (substring string 0 i)) dest)
132               string (substring string i)
133               len (- len i)
134               )))
135     (nreverse dest)
136     ))
137
138
139 ;;; @ word
140 ;;;
141
142 (defun eword-encode-charset-words-to-words (charset-words)
143   (let (dest)
144     (while charset-words
145       (let* ((charset-word (car charset-words))
146              (charset (car charset-word))
147              )
148         (if charset
149             (let ((charsets (list charset))
150                   (str (cdr charset-word))
151                   )
152               (catch 'tag
153                 (while (setq charset-words (cdr charset-words))
154                   (setq charset-word (car charset-words)
155                         charset (car charset-word))
156                   (if (null charset)
157                       (throw 'tag nil)
158                     )
159                   (or (memq charset charsets)
160                       (setq charsets (cons charset charsets))
161                       )
162                   (setq str (concat str (cdr charset-word)))
163                   ))
164               (setq dest (cons (cons charsets str) dest))
165               )
166           (setq dest (cons charset-word dest)
167                 charset-words (cdr charset-words)
168                 ))))
169     (nreverse dest)
170     ))
171
172
173 ;;; @ rule
174 ;;;
175
176 (defmacro make-ew-rword (text charset encoding type)
177   (` (list (, text)(, charset)(, encoding)(, type))))
178 (defmacro ew-rword-text (rword)
179   (` (car (, rword))))
180 (defmacro ew-rword-charset (rword)
181   (` (car (cdr (, rword)))))
182 (defmacro ew-rword-encoding (rword)
183   (` (car (cdr (cdr (, rword))))))
184 (defmacro ew-rword-type (rword)
185   (` (car (cdr (cdr (cdr (, rword)))))))
186
187 (defun ew-find-charset-rule (charsets)
188   (if charsets
189       (let* ((charset (find-mime-charset-by-charsets charsets))
190              (encoding (cdr (or (assq charset eword-charset-encoding-alist)
191                                 '(nil . "Q")))))
192         (list charset encoding)
193         )))
194
195 (defun tm-eword::words-to-ruled-words (wl &optional mode)
196   (mapcar (function
197            (lambda (word)
198              (let ((ret (ew-find-charset-rule (car word))))
199                (make-ew-rword (cdr word) (car ret)(nth 1 ret) mode)
200                )))
201           wl))
202
203 (defun ew-space-process (seq)
204   (let (prev a ac b c cc)
205     (while seq
206       (setq b (car seq))
207       (setq seq (cdr seq))
208       (setq c (car seq))
209       (setq cc (ew-rword-charset c))
210       (if (and (null (ew-rword-charset b))
211                (not (eq (ew-rword-type b) 'special)))
212           (progn
213             (setq a (car prev))
214             (setq ac (ew-rword-charset a))
215             (if (and (ew-rword-encoding a)
216                      (ew-rword-encoding c))
217                 (cond ((eq ac cc)
218                        (setq prev (cons
219                                    (cons (concat (car a)(car b)(car c))
220                                          (cdr a))
221                                    (cdr prev)
222                                    ))
223                        (setq seq (cdr seq))
224                        )
225                       (t
226                        (setq prev (cons
227                                    (cons (concat (car a)(car b))
228                                          (cdr a))
229                                    (cdr prev)
230                                    ))
231                        ))
232               (setq prev (cons b prev))
233               ))
234         (setq prev (cons b prev))
235         ))
236     (reverse prev)
237     ))
238
239 (defun eword-encode-split-string (str &optional mode)
240   (ew-space-process
241    (tm-eword::words-to-ruled-words
242     (eword-encode-charset-words-to-words
243      (eword-encode-divide-into-charset-words str))
244     mode)))
245
246
247 ;;; @ length
248 ;;;
249
250 (defun tm-eword::encoded-word-length (rword)
251   (let ((string   (ew-rword-text     rword))
252         (charset  (ew-rword-charset  rword))
253         (encoding (ew-rword-encoding rword))
254         ret)
255     (setq ret
256           (cond ((string-equal encoding "B")
257                  (setq string (encode-mime-charset-string string charset))
258                  (base64-encoded-length string)
259                  )
260                 ((string-equal encoding "Q")
261                  (setq string (encode-mime-charset-string string charset))
262                  (Q-encoded-text-length string (ew-rword-type rword))
263                  )))
264     (if ret
265         (cons (+ 7 (length (symbol-name charset)) ret) string)
266       )))
267
268
269 ;;; @ encode-string
270 ;;;
271
272 (defun ew-encode-rword-1 (column rwl &optional must-output)
273   (catch 'can-not-output
274     (let* ((rword (car rwl))
275            (ret (tm-eword::encoded-word-length rword))
276            string len)
277       (if (null ret)
278           (cond ((and (setq string (car rword))
279                       (or (<= (setq len (+ (length string) column)) 76)
280                           (<= column 1))
281                       )
282                  (setq rwl (cdr rwl))
283                  )
284                 ((memq (aref string 0) '(?  ?\t))
285                  (setq string (concat "\n" string)
286                        len (length string)
287                        rwl (cdr rwl))
288                  )
289                 (must-output
290                  (setq string "\n "
291                        len 1)
292                  )
293                 (t
294                  (throw 'can-not-output nil)
295                  ))
296         (cond ((and (setq len (car ret))
297                     (<= (+ column len) 76)
298                     )
299                (setq string
300                      (eword-encode-text
301                       (ew-rword-charset rword)
302                       (ew-rword-encoding rword)
303                       (cdr ret)
304                       (ew-rword-type rword)
305                       ))
306                (setq len (+ (length string) column))
307                (setq rwl (cdr rwl))
308                )
309               (t
310                (setq string (car rword))
311                (let* ((p 0) np
312                       (str "") nstr)
313                  (while (and (< p len)
314                              (progn
315                                (setq np (char-next-index (sref string p) p))
316                                (setq nstr (substring string 0 np))
317                                (setq ret (tm-eword::encoded-word-length
318                                           (cons nstr (cdr rword))
319                                           ))
320                                (setq nstr (cdr ret))
321                                (setq len (+ (car ret) column))
322                                (<= len 76)
323                                ))
324                    (setq str nstr
325                          p np))
326                  (if (string-equal str "")
327                      (if must-output
328                          (setq string "\n "
329                                len 1)
330                        (throw 'can-not-output nil))
331                    (setq rwl (cons (cons (substring string p) (cdr rword))
332                                    (cdr rwl)))
333                    (setq string
334                          (eword-encode-text
335                           (ew-rword-charset rword)
336                           (ew-rword-encoding rword)
337                           str
338                           (ew-rword-type rword)))
339                    (setq len (+ (length string) column))
340                    )
341                  )))
342         )
343       (list string len rwl)
344       )))
345
346 (defun eword-encode-rword-list (column rwl)
347   (let (ret dest str ew-f pew-f folded-points)
348     (while rwl
349       (setq ew-f (nth 2 (car rwl)))
350       (if (and pew-f ew-f)
351           (setq rwl (cons '(" ") rwl)
352                 pew-f nil)
353         (setq pew-f ew-f)
354         )
355       (if (null (setq ret (ew-encode-rword-1 column rwl)))
356           (let ((i (1- (length dest)))
357                 c s r-dest r-column)
358             (catch 'success
359               (while (catch 'found
360                        (while (>= i 0)
361                          (cond ((memq (setq c (aref dest i)) '(?  ?\t))
362                                 (if (memq i folded-points)
363                                     (throw 'found nil)
364                                   (setq folded-points (cons i folded-points))
365                                   (throw 'found i))
366                                 )
367                                ((eq c ?\n)
368                                 (throw 'found nil)
369                                 ))
370                          (setq i (1- i))))
371                 (setq s (substring dest i)
372                       r-column (length s)
373                       r-dest (concat (substring dest 0 i) "\n" s))
374                 (when (setq ret (ew-encode-rword-1 r-column rwl))
375                   (setq dest r-dest
376                         column r-column)
377                   (throw 'success t)
378                   ))
379               (setq ret (ew-encode-rword-1 column rwl 'must-output))
380               )))
381       (setq str (car ret))
382       (setq dest (concat dest str))
383       (setq column (nth 1 ret)
384             rwl (nth 2 ret))
385       )
386     (list dest column)
387     ))
388
389
390 ;;; @ converter
391 ;;;
392
393 (defun eword-encode-phrase-to-rword-list (phrase)
394   (let (token type dest str)
395     (while phrase
396       (setq token (car phrase))
397       (setq type (car token))
398       (cond ((eq type 'quoted-string)
399              (setq str (concat "\"" (cdr token) "\""))
400              (setq dest
401                    (append dest
402                            (list
403                             (let ((ret (ew-find-charset-rule
404                                         (find-non-ascii-charset-string str))))
405                               (make-ew-rword
406                                str (car ret)(nth 1 ret) 'phrase)
407                               )
408                             )))
409              )
410             ((eq type 'comment)
411              (setq dest
412                    (append dest
413                            '(("(" nil nil special))
414                            (tm-eword::words-to-ruled-words
415                             (eword-encode-charset-words-to-words
416                              (eword-encode-divide-into-charset-words
417                               (cdr token)))
418                             'comment)
419                            '((")" nil nil special))
420                            ))
421              )
422             (t
423              (setq dest
424                    (append dest
425                            (tm-eword::words-to-ruled-words
426                             (eword-encode-charset-words-to-words
427                              (eword-encode-divide-into-charset-words
428                               (cdr token))
429                              ) 'phrase)))
430              ))
431       (setq phrase (cdr phrase))
432       )
433     (ew-space-process dest)
434     ))
435
436 (defun eword-encode-addr-seq-to-rword-list (seq)
437   (let (dest pname)
438     (while seq
439       (let* ((token (car seq))
440              (name (car token))
441              )
442         (cond ((eq name 'spaces)
443                (setq dest (nconc dest (list (list (cdr token) nil nil))))
444                )
445               ((eq name 'comment)
446                (setq dest
447                      (nconc
448                       dest
449                       (list (list "(" nil nil))
450                       (eword-encode-split-string (cdr token) 'comment)
451                       (list (list ")" nil nil))
452                       ))
453                )
454               ((eq name 'quoted-string)
455                (setq dest
456                      (nconc
457                       dest
458                       (list
459                        (list (concat "\"" (cdr token) "\"") nil nil)
460                        )))
461                )
462               (t
463                (setq dest
464                      (if (or (eq pname 'spaces)
465                              (eq pname 'comment))
466                          (nconc dest (list (list (cdr token) nil nil)))
467                        (nconc (butlast dest)
468                               (list
469                                (list (concat (car (car (last dest)))
470                                              (cdr token))
471                                      nil nil)))))
472                ))
473         (setq seq (cdr seq)
474               pname name))
475       )
476     dest))
477
478 (defun eword-encode-phrase-route-addr-to-rword-list (phrase-route-addr)
479   (if (eq (car phrase-route-addr) 'phrase-route-addr)
480       (let ((phrase (nth 1 phrase-route-addr))
481             (route (nth 2 phrase-route-addr))
482             dest)
483         ;; (if (eq (car (car phrase)) 'spaces)
484         ;;     (setq phrase (cdr phrase))
485         ;;   )
486         (setq dest (eword-encode-phrase-to-rword-list phrase))
487         (if dest
488             (setq dest (append dest '((" " nil nil))))
489           )
490         (append
491          dest
492          (eword-encode-addr-seq-to-rword-list
493           (append '((specials . "<"))
494                   route
495                   '((specials . ">"))))
496          ))))
497
498 (defun eword-encode-addr-spec-to-rword-list (addr-spec)
499   (if (eq (car addr-spec) 'addr-spec)
500       (eword-encode-addr-seq-to-rword-list (cdr addr-spec))
501     ))
502
503 (defun eword-encode-mailbox-to-rword-list (mbox)
504   (let ((addr (nth 1 mbox))
505         (comment (nth 2 mbox))
506         dest)
507     (setq dest (or (eword-encode-phrase-route-addr-to-rword-list addr)
508                    (eword-encode-addr-spec-to-rword-list addr)
509                    ))
510     (if comment
511         (setq dest
512               (append dest
513                       '((" " nil nil)
514                         ("(" nil nil))
515                       (eword-encode-split-string comment 'comment)
516                       (list '(")" nil nil))
517                       )))
518     dest))
519
520 (defsubst eword-encode-mailboxes-to-rword-list (mboxes)
521   (let ((dest (eword-encode-mailbox-to-rword-list (car mboxes))))
522     (if dest
523         (while (setq mboxes (cdr mboxes))
524           (setq dest
525                 (nconc dest
526                        (list '("," nil nil))
527                        (eword-encode-mailbox-to-rword-list
528                         (car mboxes))))))
529     dest))
530
531 (defsubst eword-encode-address-to-rword-list (address)
532   (cond
533    ((eq (car address) 'mailbox)
534     (eword-encode-mailbox-to-rword-list address))
535    ((eq (car address) 'group)
536     (nconc
537      (eword-encode-phrase-to-rword-list (nth 1 address))
538      (list (list ":" nil nil))
539      (eword-encode-mailboxes-to-rword-list (nth 2 address))
540      (list (list ";" nil nil))))))
541
542 (defsubst eword-encode-addresses-to-rword-list (addresses)
543   (let ((dest (eword-encode-address-to-rword-list (car addresses))))
544     (if dest
545         (while (setq addresses (cdr addresses))
546           (setq dest
547                 (nconc dest
548                        (list '("," nil nil))
549                        ;; (list '(" " nil nil))
550                        (eword-encode-address-to-rword-list (car addresses))))))
551     dest))
552
553 (defsubst eword-encode-msg-id-to-rword-list (msg-id)
554   (list
555    (list
556     (concat "<"
557             (caar (eword-encode-addr-seq-to-rword-list (cdr msg-id)))
558             ">")
559     nil nil)))
560
561 (defsubst eword-encode-in-reply-to-to-rword-list (in-reply-to)
562   (let (dest)
563     (while in-reply-to
564       (setq dest
565             (append dest
566                     (let ((elt (car in-reply-to)))
567                       (if (eq (car elt) 'phrase)
568                           (eword-encode-phrase-to-rword-list (cdr elt))
569                         (eword-encode-msg-id-to-rword-list elt)
570                         ))))
571       (setq in-reply-to (cdr in-reply-to)))
572     dest))
573
574
575 ;;; @ application interfaces
576 ;;;
577
578 (defcustom eword-encode-default-start-column 10
579   "Default start column if it is omitted."
580   :group 'eword-encode
581   :type 'integer)
582
583 (defun eword-encode-string (string &optional column mode)
584   "Encode STRING as encoded-words, and return the result.
585 Optional argument COLUMN is start-position of the field.
586 Optional argument MODE allows `text', `comment', `phrase' or nil.
587 Default value is `phrase'."
588   (car (eword-encode-rword-list
589         (or column eword-encode-default-start-column)
590         (eword-encode-split-string string mode))))
591
592 (defun eword-encode-address-list (string &optional column)
593   "Encode header field STRING as list of address, and return the result.
594 Optional argument COLUMN is start-position of the field."
595   (car (eword-encode-rword-list
596         (or column eword-encode-default-start-column)
597         (eword-encode-addresses-to-rword-list
598          (std11-parse-addresses-string string))
599         )))
600
601 (defun eword-encode-in-reply-to (string &optional column)
602   "Encode header field STRING as In-Reply-To field, and return the result.
603 Optional argument COLUMN is start-position of the field."
604   (car (eword-encode-rword-list
605         (or column 13)
606         (eword-encode-in-reply-to-to-rword-list
607          (std11-parse-msg-ids-string string)))))
608
609 (defun eword-encode-structured-field-body (string &optional column)
610   "Encode header field STRING as structured field, and return the result.
611 Optional argument COLUMN is start-position of the field."
612   (car (eword-encode-rword-list
613         (or column eword-encode-default-start-column)
614         (eword-encode-addr-seq-to-rword-list (std11-lexical-analyze string))
615         )))
616
617 (defun eword-encode-unstructured-field-body (string &optional column)
618   "Encode header field STRING as unstructured field, and return the result.
619 Optional argument COLUMN is start-position of the field."
620   (car (eword-encode-rword-list
621         (or column eword-encode-default-start-column)
622         (eword-encode-split-string string 'text))))
623
624 (defun eword-encode-field-body (field-body field-name)
625   "Encode FIELD-BODY as FIELD-NAME, and return the result.
626 A lexical token includes non-ASCII character is encoded as MIME
627 encoded-word.  ASCII token is not encoded."
628   (setq field-body (std11-unfold-string field-body))
629   (if (string= field-body "")
630       ""
631     (let (start)
632       (if (symbolp field-name)
633           (setq start (1+ (length (symbol-name field-name))))
634         (setq start (1+ (length field-name))
635               field-name (intern (capitalize field-name))))
636       (cond ((memq field-name
637                    '(Reply-To
638                      From Sender
639                      Resent-Reply-To Resent-From
640                      Resent-Sender To Resent-To
641                      Cc Resent-Cc Bcc Resent-Bcc
642                      Dcc))
643              (eword-encode-address-list field-body start)
644              )
645             ((eq field-name 'In-Reply-To)
646              (eword-encode-in-reply-to field-body start)
647              )
648             ((memq field-name '(Mime-Version User-Agent))
649              (eword-encode-structured-field-body field-body start)
650              )
651             (t
652              (eword-encode-unstructured-field-body field-body start)
653              ))
654       )))
655
656 (defun eword-in-subject-p ()
657   (let ((str (std11-field-body "Subject")))
658     (if (and str (string-match eword-encoded-word-regexp str))
659         str)))
660
661 (defsubst eword-find-field-encoding-method (field-name)
662   (setq field-name (downcase field-name))
663   (let ((alist eword-field-encoding-method-alist))
664     (catch 'found
665       (while alist
666         (let* ((pair (car alist))
667                (str (car pair)))
668           (if (and (stringp str)
669                    (string= field-name (downcase str)))
670               (throw 'found (cdr pair))
671             ))
672         (setq alist (cdr alist)))
673       (cdr (assq t eword-field-encoding-method-alist))
674       )))
675
676 (defun eword-encode-header (&optional code-conversion)
677   "Encode header fields to network representation, such as MIME encoded-word.
678
679 It refer variable `eword-field-encoding-method-alist'."
680   (interactive "*")
681   (save-excursion
682     (save-restriction
683       (std11-narrow-to-header mail-header-separator)
684       (goto-char (point-min))
685       (let ((default-cs (mime-charset-to-coding-system default-mime-charset))
686             bbeg end field-name)
687         (while (re-search-forward std11-field-head-regexp nil t)
688           (setq bbeg (match-end 0)
689                 field-name (buffer-substring (match-beginning 0) (1- bbeg))
690                 end (std11-field-end))
691           (and (find-non-ascii-charset-region bbeg end)
692                (let ((method (eword-find-field-encoding-method
693                               (downcase field-name))))
694                  (cond ((eq method 'mime)
695                         (let ((field-body
696                                (buffer-substring-no-properties bbeg end)
697                                ))
698                           (delete-region bbeg end)
699                           (insert (eword-encode-field-body field-body
700                                                            field-name))
701                           ))
702                        (code-conversion
703                         (let ((cs
704                                (or (mime-charset-to-coding-system
705                                     method)
706                                    default-cs)))
707                           (encode-coding-region bbeg end cs)
708                           )))
709                  ))
710           ))
711       )))
712
713
714 ;;; @ end
715 ;;;
716
717 (provide 'eword-encode)
718
719 ;;; eword-encode.el ends here