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 (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 make-ew-rword (text charset encoding type)
 169   (` (list (, text)(, charset)(, encoding)(, type))))
 170 (defmacro ew-rword-text (rword)
 171   (` (car (, rword))))
 172 (defmacro ew-rword-charset (rword)
 173   (` (car (cdr (, rword)))))
 174 (defmacro ew-rword-encoding (rword)
 175   (` (car (cdr (cdr (, rword))))))
 176 (defmacro ew-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                (make-ew-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 (ew-rword-charset c))
 202       (if (null (ew-rword-charset b))
 203           (progn
 204             (setq a (car prev))
 205             (setq ac (ew-rword-charset a))
 206             (if (and (ew-rword-encoding a)
 207                      (ew-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 eword-encode-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   (ew-rword-text     rword))
 243         (charset  (ew-rword-charset  rword))
 244         (encoding (ew-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                                             (ew-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                     (ew-rword-charset rword)
 285                     (ew-rword-encoding rword)
 286                     (cdr ret)
 287                     (ew-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                         (ew-rword-charset rword)
 317                         (ew-rword-encoding rword)
 318                         str
 319                         (ew-rword-type rword)))
 320                  (setq len (+ (length string) column))
 321                  )
 322                )))
 323       )
 324     (list string len rwl)
 325     ))
 326
 327 (defun eword-encode-rword-list (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
 377 ;;; @ converter
 378 ;;;
 379
 380 (defun tm-eword::phrase-to-rwl (phrase)
 381   (let (token type dest str)
 382     (while phrase
 383       (setq token (car phrase))
 384       (setq type (car token))
 385       (cond ((eq type 'quoted-string)
 386              (setq str (concat "\"" (cdr token) "\""))
 387              (setq dest
 388                    (append dest
 389                            (list
 390                             (let ((ret (tm-eword::find-charset-rule
 391                                         (find-non-ascii-charset-string str))))
 392                               (make-ew-rword
 393                                str (car ret)(nth 1 ret) 'phrase)
 394                               )
 395                             )))
 396              )
 397             ((eq type 'comment)
 398              (setq dest
 399                    (append dest
 400                            '(("(" nil nil))
 401                            (tm-eword::words-to-ruled-words
 402                             (eword-encode-charset-words-to-words
 403                              (eword-encode-divide-into-charset-words
 404                               (cdr token)))
 405                             'comment)
 406                            '((")" nil nil))
 407                            ))
 408              )
 409             (t
 410              (setq dest
 411                    (append dest
 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                              ) 'phrase)))
 417              ))
 418       (setq phrase (cdr phrase))
 419       )
 420     (tm-eword::space-process dest)
 421     ))
 422
 423 (defun eword-encode-addr-seq-to-rword-list (seq)
 424   (let (dest pname)
 425     (while seq
 426       (let* ((token (car seq))
 427              (name (car token))
 428              )
 429         (cond ((eq name 'spaces)
 430                (setq dest (nconc dest (list (list (cdr token) nil nil))))
 431                )
 432               ((eq name 'comment)
 433                (setq dest
 434                      (nconc
 435                       dest
 436                       (list (list "(" nil nil))
 437                       (eword-encode-split-string (cdr token) 'comment)
 438                       (list (list ")" nil nil))
 439                       ))
 440                )
 441               ((eq name 'quoted-string)
 442                (setq dest
 443                      (nconc
 444                       dest
 445                       (list
 446                        (list (concat "\"" (cdr token) "\"") nil nil)
 447                        )))
 448                )
 449               (t
 450                (setq dest
 451                      (if (or (eq pname 'spaces)
 452                              (eq pname 'comment))
 453                          (nconc dest (list (list (cdr token) nil nil)))
 454                        (nconc (butlast dest)
 455                               (list
 456                                (list (concat (car (car (last dest)))
 457                                              (cdr token))
 458                                      nil nil)))))
 459                ))
 460         (setq seq (cdr seq)
 461               pname name))
 462       )
 463     dest))
 464
 465 (defun eword-encode-phrase-route-addr-to-rword-list (phrase-route-addr)
 466   (if (eq (car phrase-route-addr) 'phrase-route-addr)
 467       (let ((phrase (nth 1 phrase-route-addr))
 468             (route (nth 2 phrase-route-addr))
 469             dest)
 470         (if (eq (car (car phrase)) 'spaces)
 471             (setq phrase (cdr phrase))
 472           )
 473         (setq dest (tm-eword::phrase-to-rwl phrase))
 474         (if dest
 475             (setq dest (append dest '((" " nil nil))))
 476           )
 477         (append
 478          dest
 479          (eword-encode-addr-seq-to-rword-list
 480           (append '((specials . "<"))
 481                   route
 482                   '((specials . ">"))))
 483          ))))
 484
 485 (defun eword-addr-spec-to-rwl (addr-spec)
 486   (if (eq (car addr-spec) 'addr-spec)
 487       (eword-encode-addr-seq-to-rword-list (cdr addr-spec))
 488     ))
 489
 490 (defun tm-eword::mailbox-to-rwl (mbox)
 491   (let ((addr (nth 1 mbox))
 492         (comment (nth 2 mbox))
 493         dest)
 494     (setq dest (or (eword-encode-phrase-route-addr-to-rword-list addr)
 495                    (eword-addr-spec-to-rwl addr)
 496                    ))
 497     (if comment
 498         (setq dest
 499               (append dest
 500                       '((" " nil nil)
 501                         ("(" nil nil))
 502                       (eword-encode-split-string comment 'comment)
 503                       '((")" nil nil))
 504                       )))
 505     dest))
 506
 507 (defsubst eword-encode-addresses-to-rwl (addresses)
 508   (let ((dest (tm-eword::mailbox-to-rwl (car addresses))))
 509     (if dest
 510         (while (setq addresses (cdr addresses))
 511           (setq dest (append dest
 512                              '(("," nil nil))
 513                              '((" " nil nil))
 514                              (tm-eword::mailbox-to-rwl (car addresses))
 515                              ))
 516           ))
 517     dest))
 518
 519
 520 ;;; @ application interfaces
 521 ;;;
 522
 523 (defun eword-encode-string (string &optional column mode)
 524   "Encode STRING as encoded-words, and return the result.
 525 Optional argument COLUMN is start-position of the field.
 526 Optional argument MODE allows `text', `comment', `phrase' or nil.
 527 Default value is `phrase'."
 528   (car (eword-encode-rword-list (or column 0)
 529                                 (eword-encode-split-string string mode))))
 530
 531 (defun eword-encode-address-list (string &optional column)
 532   "Encode header field STRING as list of address, and return the result.
 533 Optional argument COLUMN is start-position of the field."
 534   (car (eword-encode-rword-list
 535         (or column 0)
 536         (eword-encode-addresses-to-rwl (std11-parse-addresses-string string))
 537         )))
 538
 539 (defun eword-encode-structured-field-body (string &optional column)
 540   "Encode header field STRING as structured field, and return the result.
 541 Optional argument COLUMN is start-position of the field."
 542   (car (eword-encode-rword-list
 543         (or column 0)
 544         (eword-encode-addr-seq-to-rword-list (std11-lexical-analyze string))
 545         )))
 546
 547 (defun eword-encode-unstructured-field-body (string &optional column)
 548   "Encode header field STRING as unstructured field, and return the result.
 549 Optional argument COLUMN is start-position of the field."
 550   (car (eword-encode-rword-list (or column 0)
 551                                 (eword-encode-split-string string 'text))))
 552
 553 (defun eword-encode-field (string)
 554   "Encode header field STRING, and return the result.
 555 A lexical token includes non-ASCII character is encoded as MIME
 556 encoded-word.  ASCII token is not encoded."
 557   (setq string (std11-unfold-string string))
 558   (let ((ret (string-match std11-field-head-regexp string)))
 559     (or (if ret
 560             (let ((field-name (substring string 0 (1- (match-end 0))))
 561                   (field-body (eliminate-top-spaces
 562                                (substring string (match-end 0))))
 563                   field-name-symbol)
 564               (if (setq ret
 565                         (cond ((string= field-body "") "")
 566                               ((memq (setq field-name-symbol
 567                                            (intern (capitalize field-name)))
 568                                      '(Reply-To
 569                                        From Sender
 570                                        Resent-Reply-To Resent-From
 571                                        Resent-Sender To Resent-To
 572                                        Cc Resent-Cc Bcc Resent-Bcc
 573                                        Dcc))
 574                                (eword-encode-address-list
 575                                 field-body (+ (length field-name) 2))
 576                                )
 577                               ((memq field-name-symbol
 578                                      '(In-Reply-To
 579                                        Mime-Version User-Agent))
 580                                (eword-encode-structured-field-body
 581                                 field-body (+ (length field-name) 2))
 582                                )
 583                               (t
 584                                (eword-encode-unstructured-field-body
 585                                 field-body (1+ (length field-name)))
 586                                ))
 587                         )
 588                   (concat field-name ": " ret)
 589                 )))
 590         (eword-encode-string string 0)
 591         )))
 592
 593 (defun eword-in-subject-p ()
 594   (let ((str (std11-field-body "Subject")))
 595     (if (and str (string-match eword-encoded-word-regexp str))
 596         str)))
 597
 598 (defsubst eword-find-field-encoding-method (field-name)
 599   (setq field-name (downcase field-name))
 600   (let ((alist eword-field-encoding-method-alist))
 601     (catch 'found
 602       (while alist
 603         (let* ((pair (car alist))
 604                (str (car pair)))
 605           (if (and (stringp str)
 606                    (string= field-name (downcase str)))
 607               (throw 'found (cdr pair))
 608             ))
 609         (setq alist (cdr alist)))
 610       (cdr (assq t eword-field-encoding-method-alist))
 611       )))
 612
 613 (defun eword-encode-header (&optional code-conversion)
 614   "Encode header fields to network representation, such as MIME encoded-word.
 615
 616 It refer variable `eword-field-encoding-method-alist'."
 617   (interactive "*")
 618   (save-excursion
 619     (save-restriction
 620       (std11-narrow-to-header mail-header-separator)
 621       (goto-char (point-min))
 622       (let ((default-cs (mime-charset-to-coding-system default-mime-charset))
 623             beg end field-name)
 624         (while (re-search-forward std11-field-head-regexp nil t)
 625           (setq beg (match-beginning 0))
 626           (setq field-name (buffer-substring beg (1- (match-end 0))))
 627           (setq end (std11-field-end))
 628           (and (find-non-ascii-charset-region beg end)
 629                (let ((method (eword-find-field-encoding-method
 630                               (downcase field-name))))
 631                  (cond ((eq method 'mime)
 632                         (let ((field
 633                                (buffer-substring-no-properties beg end)
 634                                ))
 635                           (delete-region beg end)
 636                           (insert (eword-encode-field field))
 637                           ))
 638                        (code-conversion
 639                         (let ((cs
 640                                (or (mime-charset-to-coding-system
 641                                     method)
 642                                    default-cs)))
 643                           (encode-coding-region beg end cs)
 644                           )))
 645                  ))
 646           ))
 647       )))
 648
 649
 650 ;;; @ end
 651 ;;;
 652
 653 (provide 'eword-encode)
 654
 655 ;;; eword-encode.el ends here