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