eword-encode.el

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