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-kr        . "B")
  81     (gb2312             . "B")
  82     (cn-gb              . "B")
  83     (cn-gb-2312         . "B")
  84     (euc-kr             . "B")
  85     (tis-620            . "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 ew-find-charset-rule (charsets)
 187   (if charsets
 188       (let* ((charset (find-mime-charset-by-charsets charsets))
 189              (encoding (cdr (or (assq charset eword-charset-encoding-alist)
 190                                 '(nil . "Q")))))
 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 (ew-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 bew)
 335     (while rwl
 336       (setq ew-f (nth 2 (car rwl)))
 337       (if (and pew-f ew-f)
 338           (setq rwl (cons '(" ") rwl)
 339                 bew t
 340                 pew-f nil)
 341         (setq pew-f ew-f
 342               bew nil)
 343         )
 344       (setq ret (tm-eword::encode-string-1 column rwl))
 345       (setq str (car ret))
 346       (if (eq (elt str 0) ?\n)
 347           (cond
 348            ((eq special ?\()
 349             (setq dest (concat dest "\n ("))
 350             (setq ret (tm-eword::encode-string-1 2 rwl))
 351             (setq str (car ret)))
 352            ((eq bew t)
 353             (setq dest (concat dest "\n "))
 354             (setq ret (tm-eword::encode-string-1 1 (cdr rwl)))
 355             (setq str (car ret))))
 356         (cond ((eq special ? )
 357                (if (string= str "(")
 358                    (setq ps t)
 359                  (setq dest (concat dest " "))
 360                  (setq ps nil)
 361                  ))
 362               ((eq special ?\()
 363                (if ps
 364                    (progn
 365                      (setq dest (concat dest " ("))
 366                      (setq ps nil)
 367                      )
 368                  (setq dest (concat dest "("))
 369                  )
 370                )))
 371       (cond ((string= str " ")
 372              (setq special ? )
 373              )
 374             ((string= str "(")
 375              (setq special ?\()
 376              )
 377             (t
 378              (setq special nil)
 379              (setq dest (concat dest str))
 380              ))
 381       (setq column (nth 1 ret)
 382             rwl (nth 2 ret))
 383       )
 384     (list dest column)
 385     ))
 386
 387
 388 ;;; @ converter
 389 ;;;
 390
 391 (defun eword-encode-phrase-to-rword-list (phrase)
 392   (let (token type dest str)
 393     (while phrase
 394       (setq token (car phrase))
 395       (setq type (car token))
 396       (cond ((eq type 'quoted-string)
 397              (setq str (concat "\"" (cdr token) "\""))
 398              (setq dest
 399                    (append dest
 400                            (list
 401                             (let ((ret (ew-find-charset-rule
 402                                         (find-non-ascii-charset-string str))))
 403                               (make-ew-rword
 404                                str (car ret)(nth 1 ret) 'phrase)
 405                               )
 406                             )))
 407              )
 408             ((eq type 'comment)
 409              (setq dest
 410                    (append dest
 411                            '(("(" nil nil))
 412                            (tm-eword::words-to-ruled-words
 413                             (eword-encode-charset-words-to-words
 414                              (eword-encode-divide-into-charset-words
 415                               (cdr token)))
 416                             'comment)
 417                            '((")" nil nil))
 418                            ))
 419              )
 420             (t
 421              (setq dest
 422                    (append dest
 423                            (tm-eword::words-to-ruled-words
 424                             (eword-encode-charset-words-to-words
 425                              (eword-encode-divide-into-charset-words
 426                               (cdr token))
 427                              ) 'phrase)))
 428              ))
 429       (setq phrase (cdr phrase))
 430       )
 431     (tm-eword::space-process dest)
 432     ))
 433
 434 (defun eword-encode-addr-seq-to-rword-list (seq)
 435   (let (dest pname)
 436     (while seq
 437       (let* ((token (car seq))
 438              (name (car token))
 439              )
 440         (cond ((eq name 'spaces)
 441                (setq dest (nconc dest (list (list (cdr token) nil nil))))
 442                )
 443               ((eq name 'comment)
 444                (setq dest
 445                      (nconc
 446                       dest
 447                       (list (list "(" nil nil))
 448                       (eword-encode-split-string (cdr token) 'comment)
 449                       (list (list ")" nil nil))
 450                       ))
 451                )
 452               ((eq name 'quoted-string)
 453                (setq dest
 454                      (nconc
 455                       dest
 456                       (list
 457                        (list (concat "\"" (cdr token) "\"") nil nil)
 458                        )))
 459                )
 460               (t
 461                (setq dest
 462                      (if (or (eq pname 'spaces)
 463                              (eq pname 'comment))
 464                          (nconc dest (list (list (cdr token) nil nil)))
 465                        (nconc (butlast dest)
 466                               (list
 467                                (list (concat (car (car (last dest)))
 468                                              (cdr token))
 469                                      nil nil)))))
 470                ))
 471         (setq seq (cdr seq)
 472               pname name))
 473       )
 474     dest))
 475
 476 (defun eword-encode-phrase-route-addr-to-rword-list (phrase-route-addr)
 477   (if (eq (car phrase-route-addr) 'phrase-route-addr)
 478       (let ((phrase (nth 1 phrase-route-addr))
 479             (route (nth 2 phrase-route-addr))
 480             dest)
 481         ;; (if (eq (car (car phrase)) 'spaces)
 482         ;;     (setq phrase (cdr phrase))
 483         ;;   )
 484         (setq dest (eword-encode-phrase-to-rword-list phrase))
 485         (if dest
 486             (setq dest (append dest '((" " nil nil))))
 487           )
 488         (append
 489          dest
 490          (eword-encode-addr-seq-to-rword-list
 491           (append '((specials . "<"))
 492                   route
 493                   '((specials . ">"))))
 494          ))))
 495
 496 (defun eword-encode-addr-spec-to-rword-list (addr-spec)
 497   (if (eq (car addr-spec) 'addr-spec)
 498       (eword-encode-addr-seq-to-rword-list (cdr addr-spec))
 499     ))
 500
 501 (defun eword-encode-mailbox-to-rword-list (mbox)
 502   (let ((addr (nth 1 mbox))
 503         (comment (nth 2 mbox))
 504         dest)
 505     (setq dest (or (eword-encode-phrase-route-addr-to-rword-list addr)
 506                    (eword-encode-addr-spec-to-rword-list addr)
 507                    ))
 508     (if comment
 509         (setq dest
 510               (append dest
 511                       '((" " nil nil)
 512                         ("(" nil nil))
 513                       (eword-encode-split-string comment 'comment)
 514                       (list '(")" nil nil))
 515                       )))
 516     dest))
 517
 518 (defsubst eword-encode-addresses-to-rword-list (addresses)
 519   (let ((dest (eword-encode-mailbox-to-rword-list (car addresses))))
 520     (if dest
 521         (while (setq addresses (cdr addresses))
 522           (setq dest
 523                 (nconc dest
 524                        (list '("," nil nil))
 525                        ;; (list '(" " nil nil))
 526                        (eword-encode-mailbox-to-rword-list (car addresses))
 527                        ))
 528           ))
 529     dest))
 530
 531 (defsubst eword-encode-msg-id-to-rword-list (msg-id)
 532   (list
 533    (list
 534     (concat "<"
 535             (caar (eword-encode-addr-seq-to-rword-list (cdr msg-id)))
 536             ">")
 537     nil nil)))
 538
 539 (defsubst eword-encode-in-reply-to-to-rword-list (in-reply-to)
 540   (let (dest)
 541     (while in-reply-to
 542       (setq dest
 543             (append dest
 544                     (let ((elt (car in-reply-to)))
 545                       (if (eq (car elt) 'phrase)
 546                           (eword-encode-phrase-to-rword-list (cdr elt))
 547                         (eword-encode-msg-id-to-rword-list elt)
 548                         ))))
 549       (setq in-reply-to (cdr in-reply-to)))
 550     dest))
 551
 552
 553 ;;; @ application interfaces
 554 ;;;
 555
 556 (defcustom eword-encode-default-start-column 10
 557   "Default start column if it is omitted."
 558   :group 'eword-encode
 559   :type 'integer)
 560
 561 (defun eword-encode-string (string &optional column mode)
 562   "Encode STRING as encoded-words, and return the result.
 563 Optional argument COLUMN is start-position of the field.
 564 Optional argument MODE allows `text', `comment', `phrase' or nil.
 565 Default value is `phrase'."
 566   (car (eword-encode-rword-list
 567         (or column eword-encode-default-start-column)
 568         (eword-encode-split-string string mode))))
 569
 570 (defun eword-encode-address-list (string &optional column)
 571   "Encode header field STRING as list of address, and return the result.
 572 Optional argument COLUMN is start-position of the field."
 573   (car (eword-encode-rword-list
 574         (or column eword-encode-default-start-column)
 575         (eword-encode-addresses-to-rword-list
 576          (std11-parse-addresses-string string))
 577         )))
 578
 579 (defun eword-encode-in-reply-to (string &optional column)
 580   "Encode header field STRING as In-Reply-To field, and return the result.
 581 Optional argument COLUMN is start-position of the field."
 582   (car (eword-encode-rword-list
 583         (or column 13)
 584         (eword-encode-in-reply-to-to-rword-list
 585          (std11-parse-msg-ids-string string)))))
 586
 587 (defun eword-encode-structured-field-body (string &optional column)
 588   "Encode header field STRING as structured field, and return the result.
 589 Optional argument COLUMN is start-position of the field."
 590   (car (eword-encode-rword-list
 591         (or column eword-encode-default-start-column)
 592         (eword-encode-addr-seq-to-rword-list (std11-lexical-analyze string))
 593         )))
 594
 595 (defun eword-encode-unstructured-field-body (string &optional column)
 596   "Encode header field STRING as unstructured field, and return the result.
 597 Optional argument COLUMN is start-position of the field."
 598   (car (eword-encode-rword-list
 599         (or column eword-encode-default-start-column)
 600         (eword-encode-split-string string 'text))))
 601
 602 (defun eword-encode-field-body (field-body field-name)
 603   "Encode FIELD-BODY as FIELD-NAME, and return the result.
 604 A lexical token includes non-ASCII character is encoded as MIME
 605 encoded-word.  ASCII token is not encoded."
 606   (setq field-body (std11-unfold-string field-body))
 607   (if (string= field-body "")
 608       ""
 609     (let (start)
 610       (if (symbolp field-name)
 611           (setq start (1+ (length (symbol-name field-name))))
 612         (setq start (1+ (length field-name))
 613               field-name (intern (capitalize field-name))))
 614       (cond ((memq field-name
 615                    '(Reply-To
 616                      From Sender
 617                      Resent-Reply-To Resent-From
 618                      Resent-Sender To Resent-To
 619                      Cc Resent-Cc Bcc Resent-Bcc
 620                      Dcc))
 621              (eword-encode-address-list field-body start)
 622              )
 623             ((eq field-name 'In-Reply-To)
 624              (eword-encode-in-reply-to field-body start)
 625              )
 626             ((memq field-name '(Mime-Version User-Agent))
 627              (eword-encode-structured-field-body field-body start)
 628              )
 629             (t
 630              (eword-encode-unstructured-field-body field-body start)
 631              ))
 632       )))
 633
 634 (defun eword-in-subject-p ()
 635   (let ((str (std11-field-body "Subject")))
 636     (if (and str (string-match eword-encoded-word-regexp str))
 637         str)))
 638
 639 (defsubst eword-find-field-encoding-method (field-name)
 640   (setq field-name (downcase field-name))
 641   (let ((alist eword-field-encoding-method-alist))
 642     (catch 'found
 643       (while alist
 644         (let* ((pair (car alist))
 645                (str (car pair)))
 646           (if (and (stringp str)
 647                    (string= field-name (downcase str)))
 648               (throw 'found (cdr pair))
 649             ))
 650         (setq alist (cdr alist)))
 651       (cdr (assq t eword-field-encoding-method-alist))
 652       )))
 653
 654 (defun eword-encode-header (&optional code-conversion)
 655   "Encode header fields to network representation, such as MIME encoded-word.
 656
 657 It refer variable `eword-field-encoding-method-alist'."
 658   (interactive "*")
 659   (save-excursion
 660     (save-restriction
 661       (std11-narrow-to-header mail-header-separator)
 662       (goto-char (point-min))
 663       (let ((default-cs (mime-charset-to-coding-system default-mime-charset))
 664             bbeg end field-name)
 665         (while (re-search-forward std11-field-head-regexp nil t)
 666           (setq bbeg (match-end 0)
 667                 field-name (buffer-substring (match-beginning 0) (1- bbeg))
 668                 end (std11-field-end))
 669           (and (find-non-ascii-charset-region bbeg end)
 670                (let ((method (eword-find-field-encoding-method
 671                               (downcase field-name))))
 672                  (cond ((eq method 'mime)
 673                         (let ((field-body
 674                                (buffer-substring-no-properties bbeg end)
 675                                ))
 676                           (delete-region bbeg end)
 677                           (insert (eword-encode-field-body field-body
 678                                                            field-name))
 679                           ))
 680                        (code-conversion
 681                         (let ((cs
 682                                (or (mime-charset-to-coding-system
 683                                     method)
 684                                    default-cs)))
 685                           (encode-coding-region bbeg end cs)
 686                           )))
 687                  ))
 688           ))
 689       )))
 690
 691
 692 ;;; @ end
 693 ;;;
 694
 695 (provide 'eword-encode)
 696
 697 ;;; eword-encode.el ends here