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