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