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 'emu)
  28 (require 'mel)
  29 (require 'std11)
  30 (require 'mime-def)
  31 (require 'eword-decode)
  32
  33 (eval-when-compile (require 'cl))
  34
  35 ;;; @ variables
  36 ;;;
  37
  38 (defgroup eword-encode nil
  39   "Encoded-word encoding"
  40   :group 'mime)
  41
  42 (defcustom eword-field-encoding-method-alist
  43   '(("X-Nsubject" . iso-2022-jp-2)
  44     ("Newsgroups" . nil)
  45     ("Message-ID" . nil)
  46     (t            . mime)
  47     )
  48   "*Alist to specify field encoding method.
  49 Its key is field-name, value is encoding method.
  50
  51 If method is `mime', this field will be encoded into MIME format.
  52
  53 If method is a MIME-charset, this field will be encoded as the charset
  54 when it must be convert into network-code.
  55
  56 If method is `default-mime-charset', this field will be encoded as
  57 variable `default-mime-charset' when it must be convert into
  58 network-code.
  59
  60 If method is nil, this field will not be encoded."
  61   :group 'eword-encode
  62   :type '(repeat (cons (choice :tag "Field"
  63                                (string :tag "Name")
  64                                (const :tag "Default" t))
  65                        (choice :tag "Method"
  66                                (const :tag "MIME conversion" mime)
  67                                (symbol :tag "non-MIME conversion")
  68                                (const :tag "no-conversion" nil)))))
  69
  70 (defvar eword-charset-encoding-alist
  71   '((us-ascii           . nil)
  72     (iso-8859-1         . "Q")
  73     (iso-8859-2         . "Q")
  74     (iso-8859-3         . "Q")
  75     (iso-8859-4         . "Q")
  76     (iso-8859-5         . "Q")
  77     (koi8-r             . "Q")
  78     (iso-8859-7         . "Q")
  79     (iso-8859-8         . "Q")
  80     (iso-8859-9         . "Q")
  81     (iso-2022-jp        . "B")
  82     (iso-2022-kr        . "B")
  83     (gb2312             . "B")
  84     (cn-gb              . "B")
  85     (cn-gb-2312         . "B")
  86     (euc-kr             . "B")
  87     (tis-620            . "B")
  88     (iso-2022-jp-2      . "B")
  89     (iso-2022-int-1     . "B")
  90     (utf-8              . "B")
  91     ))
  92
  93
  94 ;;; @ encoded-text encoder
  95 ;;;
  96
  97 (defun eword-encode-text (charset encoding string &optional mode)
  98   "Encode STRING as an encoded-word, and return the result.
  99 CHARSET is a symbol to indicate MIME charset of the encoded-word.
 100 ENCODING allows \"B\" or \"Q\".
 101 MODE is allows `text', `comment', `phrase' or nil.  Default value is
 102 `phrase'."
 103   (let ((text (encoded-text-encode-string string encoding)))
 104     (if text
 105         (concat "=?" (upcase (symbol-name charset)) "?"
 106                 encoding "?" text "?=")
 107       )))
 108
 109
 110 ;;; @ charset word
 111 ;;;
 112
 113 (defsubst eword-encode-char-type (character)
 114   (if (memq character '(?  ?\t ?\n))
 115       nil
 116     (char-charset character)
 117     ))
 118
 119 (defun eword-encode-divide-into-charset-words (string)
 120   (let ((len (length string))
 121         dest)
 122     (while (> len 0)
 123       (let* ((chr (sref string 0))
 124              (charset (eword-encode-char-type chr))
 125              (i (char-length chr)))
 126         (while (and (< i len)
 127                     (setq chr (sref string i))
 128                     (eq charset (eword-encode-char-type chr))
 129                     )
 130           (setq i (char-next-index chr i))
 131           )
 132         (setq dest (cons (cons charset (substring string 0 i)) dest)
 133               string (substring string i)
 134               len (- len i)
 135               )))
 136     (nreverse dest)
 137     ))
 138
 139
 140 ;;; @ word
 141 ;;;
 142
 143 (defun eword-encode-charset-words-to-words (charset-words)
 144   (let (dest)
 145     (while charset-words
 146       (let* ((charset-word (car charset-words))
 147              (charset (car charset-word))
 148              )
 149         (if charset
 150             (let ((charsets (list charset))
 151                   (str (cdr charset-word))
 152                   )
 153               (catch 'tag
 154                 (while (setq charset-words (cdr charset-words))
 155                   (setq charset-word (car charset-words)
 156                         charset (car charset-word))
 157                   (if (null charset)
 158                       (throw 'tag nil)
 159                     )
 160                   (or (memq charset charsets)
 161                       (setq charsets (cons charset charsets))
 162                       )
 163                   (setq str (concat str (cdr charset-word)))
 164                   ))
 165               (setq dest (cons (cons charsets str) dest))
 166               )
 167           (setq dest (cons charset-word dest)
 168                 charset-words (cdr charset-words)
 169                 ))))
 170     (nreverse dest)
 171     ))
 172
 173
 174 ;;; @ rule
 175 ;;;
 176
 177 (defmacro make-ew-rword (text charset encoding type)
 178   (` (list (, text)(, charset)(, encoding)(, type))))
 179 (defmacro ew-rword-text (rword)
 180   (` (car (, rword))))
 181 (defmacro ew-rword-charset (rword)
 182   (` (car (cdr (, rword)))))
 183 (defmacro ew-rword-encoding (rword)
 184   (` (car (cdr (cdr (, rword))))))
 185 (defmacro ew-rword-type (rword)
 186   (` (car (cdr (cdr (cdr (, rword)))))))
 187
 188 (defun tm-eword::find-charset-rule (charsets)
 189   (if charsets
 190       (let* ((charset (charsets-to-mime-charset charsets))
 191              (encoding (cdr (assq charset eword-charset-encoding-alist)))
 192              )
 193         (list charset encoding)
 194         )))
 195
 196 (defun tm-eword::words-to-ruled-words (wl &optional mode)
 197   (mapcar (function
 198            (lambda (word)
 199              (let ((ret (tm-eword::find-charset-rule (car word))))
 200                (make-ew-rword (cdr word) (car ret)(nth 1 ret) mode)
 201                )))
 202           wl))
 203
 204 (defun tm-eword::space-process (seq)
 205   (let (prev a ac b c cc)
 206     (while seq
 207       (setq b (car seq))
 208       (setq seq (cdr seq))
 209       (setq c (car seq))
 210       (setq cc (ew-rword-charset c))
 211       (if (null (ew-rword-charset b))
 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   (tm-eword::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 tm-eword::encode-string-1 (column rwl)
 273   (let* ((rword (car rwl))
 274          (ret (tm-eword::encoded-word-length rword))
 275          string len)
 276     (if (null ret)
 277         (cond ((and (setq string (car rword))
 278                     (or (<= (setq len (+ (length string) column)) 76)
 279                         (<= column 1))
 280                     )
 281                (setq rwl (cdr rwl))
 282                )
 283               (t
 284                (setq string "\n ")
 285                (setq len 1)
 286                ))
 287       (cond ((and (setq len (car ret))
 288                   (<= (+ column len) 76)
 289                   )
 290              (setq string
 291                    (eword-encode-text
 292                     (ew-rword-charset rword)
 293                     (ew-rword-encoding rword)
 294                     (cdr ret)
 295                     (ew-rword-type rword)
 296                     ))
 297              (setq len (+ (length string) column))
 298              (setq rwl (cdr rwl))
 299              )
 300             (t
 301              (setq string (car rword))
 302              (let* ((p 0) np
 303                     (str "") nstr)
 304                (while (and (< p len)
 305                            (progn
 306                              (setq np (char-next-index (sref string p) p))
 307                              (setq nstr (substring string 0 np))
 308                              (setq ret (tm-eword::encoded-word-length
 309                                         (cons nstr (cdr rword))
 310                                         ))
 311                              (setq nstr (cdr ret))
 312                              (setq len (+ (car ret) column))
 313                              (<= len 76)
 314                              ))
 315                  (setq str nstr
 316                        p np))
 317                (if (string-equal str "")
 318                    (setq string "\n "
 319                          len 1)
 320                  (setq rwl (cons (cons (substring string p) (cdr rword))
 321                                  (cdr rwl)))
 322                  (setq string
 323                        (eword-encode-text
 324                         (ew-rword-charset rword)
 325                         (ew-rword-encoding rword)
 326                         str
 327                         (ew-rword-type rword)))
 328                  (setq len (+ (length string) column))
 329                  )
 330                )))
 331       )
 332     (list string len rwl)
 333     ))
 334
 335 (defun eword-encode-rword-list (column rwl)
 336   (let (ret dest ps special str ew-f pew-f bew)
 337     (while rwl
 338       (setq ew-f (nth 2 (car rwl)))
 339       (if (and pew-f ew-f)
 340           (setq rwl (cons '(" ") rwl)
 341                 bew t
 342                 pew-f nil)
 343         (setq pew-f ew-f
 344               bew nil)
 345         )
 346       (setq ret (tm-eword::encode-string-1 column rwl))
 347       (setq str (car ret))
 348       (if (eq (elt str 0) ?\n)
 349           (cond
 350            ((eq special ?\()
 351             (setq dest (concat dest "\n ("))
 352             (setq ret (tm-eword::encode-string-1 2 rwl))
 353             (setq str (car ret)))
 354            ((eq bew t)
 355             (setq dest (concat dest "\n "))
 356             (setq ret (tm-eword::encode-string-1 1 (cdr rwl)))
 357             (setq str (car ret))))
 358         (cond ((eq special ? )
 359                (if (string= str "(")
 360                    (setq ps t)
 361                  (setq dest (concat dest " "))
 362                  (setq ps nil)
 363                  ))
 364               ((eq special ?\()
 365                (if ps
 366                    (progn
 367                      (setq dest (concat dest " ("))
 368                      (setq ps nil)
 369                      )
 370                  (setq dest (concat dest "("))
 371                  )
 372                )))
 373       (cond ((string= str " ")
 374              (setq special ? )
 375              )
 376             ((string= str "(")
 377              (setq special ?\()
 378              )
 379             (t
 380              (setq special nil)
 381              (setq dest (concat dest str))
 382              ))
 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 (tm-eword::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))
 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))
 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     (tm-eword::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-addresses-to-rword-list (addresses)
 521   (let ((dest (eword-encode-mailbox-to-rword-list (car addresses))))
 522     (if dest
 523         (while (setq addresses (cdr addresses))
 524           (setq dest
 525                 (nconc dest
 526                        (list '("," nil nil))
 527                        ;; (list '(" " nil nil))
 528                        (eword-encode-mailbox-to-rword-list (car addresses))
 529                        ))
 530           ))
 531     dest))
 532
 533 (defsubst eword-encode-msg-id-to-rword-list (msg-id)
 534   (list
 535    (list
 536     (concat "<"
 537             (caar (eword-encode-addr-seq-to-rword-list (cdr msg-id)))
 538             ">")
 539     nil nil)))
 540
 541 (defsubst eword-encode-in-reply-to-to-rword-list (in-reply-to)
 542   (let (dest)
 543     (while in-reply-to
 544       (setq dest
 545             (append dest
 546                     (let ((elt (car in-reply-to)))
 547                       (if (eq (car elt) 'phrase)
 548                           (eword-encode-phrase-to-rword-list (cdr elt))
 549                         (eword-encode-msg-id-to-rword-list elt)
 550                         ))))
 551       (setq in-reply-to (cdr in-reply-to)))
 552     dest))
 553
 554
 555 ;;; @ application interfaces
 556 ;;;
 557
 558 (defcustom eword-encode-default-start-column 10
 559   "Default start column if it is omitted."
 560   :group 'eword-encode
 561   :type 'integer)
 562
 563 (defun eword-encode-string (string &optional column mode)
 564   "Encode STRING as encoded-words, and return the result.
 565 Optional argument COLUMN is start-position of the field.
 566 Optional argument MODE allows `text', `comment', `phrase' or nil.
 567 Default value is `phrase'."
 568   (car (eword-encode-rword-list
 569         (or column eword-encode-default-start-column)
 570         (eword-encode-split-string string mode))))
 571
 572 (defun eword-encode-address-list (string &optional column)
 573   "Encode header field STRING as list of address, and return the result.
 574 Optional argument COLUMN is start-position of the field."
 575   (car (eword-encode-rword-list
 576         (or column eword-encode-default-start-column)
 577         (eword-encode-addresses-to-rword-list
 578          (std11-parse-addresses-string string))
 579         )))
 580
 581 (defun eword-encode-in-reply-to (string &optional column)
 582   "Encode header field STRING as In-Reply-To field, and return the result.
 583 Optional argument COLUMN is start-position of the field."
 584   (car (eword-encode-rword-list
 585         (or column 13)
 586         (eword-encode-in-reply-to-to-rword-list
 587          (std11-parse-msg-ids-string string)))))
 588
 589 (defun eword-encode-structured-field-body (string &optional column)
 590   "Encode header field STRING as structured field, and return the result.
 591 Optional argument COLUMN is start-position of the field."
 592   (car (eword-encode-rword-list
 593         (or column eword-encode-default-start-column)
 594         (eword-encode-addr-seq-to-rword-list (std11-lexical-analyze string))
 595         )))
 596
 597 (defun eword-encode-unstructured-field-body (string &optional column)
 598   "Encode header field STRING as unstructured field, and return the result.
 599 Optional argument COLUMN is start-position of the field."
 600   (car (eword-encode-rword-list
 601         (or column eword-encode-default-start-column)
 602         (eword-encode-split-string string 'text))))
 603
 604 (defun eword-encode-field-body (field-body field-name)
 605   "Encode FIELD-BODY as FIELD-NAME, and return the result.
 606 A lexical token includes non-ASCII character is encoded as MIME
 607 encoded-word.  ASCII token is not encoded."
 608   (setq field-body (std11-unfold-string field-body))
 609   (if (string= field-body "")
 610       ""
 611     (let (start)
 612       (if (symbolp field-name)
 613           (setq start (1+ (length (symbol-name field-name))))
 614         (setq start (1+ (length field-name))
 615               field-name (intern (capitalize field-name))))
 616       (cond ((memq field-name
 617                    '(Reply-To
 618                      From Sender
 619                      Resent-Reply-To Resent-From
 620                      Resent-Sender To Resent-To
 621                      Cc Resent-Cc Bcc Resent-Bcc
 622                      Dcc))
 623              (eword-encode-address-list field-body start)
 624              )
 625             ((eq field-name 'In-Reply-To)
 626              (eword-encode-in-reply-to field-body start)
 627              )
 628             ((memq field-name '(Mime-Version User-Agent))
 629              (eword-encode-structured-field-body field-body start)
 630              )
 631             (t
 632              (eword-encode-unstructured-field-body field-body start)
 633              ))
 634       )))
 635
 636 (defun eword-in-subject-p ()
 637   (let ((str (std11-field-body "Subject")))
 638     (if (and str (string-match eword-encoded-word-regexp str))
 639         str)))
 640
 641 (defsubst eword-find-field-encoding-method (field-name)
 642   (setq field-name (downcase field-name))
 643   (let ((alist eword-field-encoding-method-alist))
 644     (catch 'found
 645       (while alist
 646         (let* ((pair (car alist))
 647                (str (car pair)))
 648           (if (and (stringp str)
 649                    (string= field-name (downcase str)))
 650               (throw 'found (cdr pair))
 651             ))
 652         (setq alist (cdr alist)))
 653       (cdr (assq t eword-field-encoding-method-alist))
 654       )))
 655
 656 (defun eword-encode-header (&optional code-conversion)
 657   "Encode header fields to network representation, such as MIME encoded-word.
 658
 659 It refer variable `eword-field-encoding-method-alist'."
 660   (interactive "*")
 661   (save-excursion
 662     (save-restriction
 663       (std11-narrow-to-header mail-header-separator)
 664       (goto-char (point-min))
 665       (let ((default-cs (mime-charset-to-coding-system default-mime-charset))
 666             bbeg end field-name)
 667         (while (re-search-forward std11-field-head-regexp nil t)
 668           (setq bbeg (match-end 0)
 669                 field-name (buffer-substring (match-beginning 0) (1- bbeg))
 670                 end (std11-field-end))
 671           (and (find-non-ascii-charset-region bbeg end)
 672                (let ((method (eword-find-field-encoding-method
 673                               (downcase field-name))))
 674                  (cond ((eq method 'mime)
 675                         (let ((field-body
 676                                (buffer-substring-no-properties bbeg end)
 677                                ))
 678                           (delete-region bbeg end)
 679                           (insert (eword-encode-field-body field-body
 680                                                            field-name))
 681                           ))
 682                        (code-conversion
 683                         (let ((cs
 684                                (or (mime-charset-to-coding-system
 685                                     method)
 686                                    default-cs)))
 687                           (encode-coding-region bbeg end cs)
 688                           )))
 689                  ))
 690           ))
 691       )))
 692
 693
 694 ;;; @ end
 695 ;;;
 696
 697 (provide 'eword-encode)
 698
 699 ;;; eword-encode.el ends here