eword-encode.el

   1 ;;; eword-encode.el --- RFC 2047 based encoded-word encoder for GNU Emacs
   2
   3 ;; Copyright (C) 1995,1996,1997 Free Software Foundation, Inc.
   4
   5 ;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
   6 ;; Version: $Revision: 0.32 $
   7 ;; Keywords: encoded-word, MIME, multilingual, header, mail, news
   8
   9 ;; This file is part of SEMI (SEMI is Emacs MIME Interfaces).
  10
  11 ;; This program is free software; you can redistribute it and/or
  12 ;; modify it under the terms of the GNU General Public License as
  13 ;; published by the Free Software Foundation; either version 2, or (at
  14 ;; your option) any later version.
  15
  16 ;; This program is distributed in the hope that it will be useful, but
  17 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  19 ;; General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  23 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  24 ;; Boston, MA 02111-1307, USA.
  25
  26 ;;; Code:
  27
  28 (require 'emu)
  29 (require 'mel)
  30 (require 'std11)
  31 (require 'mime-def)
  32 (require 'eword-decode)
  33
  34
  35 ;;; @ version
  36 ;;;
  37
  38 (defconst eword-encode-RCS-ID
  39   "$Id: eword-encode.el,v 0.32 1997-09-25 13:02:18 morioka Exp $")
  40 (defconst eword-encode-version (get-version-string eword-encode-RCS-ID))
  41
  42
  43 ;;; @ variables
  44 ;;;
  45
  46 (defvar eword-field-encoding-method-alist
  47   '(("X-Nsubject" . iso-2022-jp-2)
  48     ("Newsgroups" . nil)
  49     ("Message-ID" . nil)
  50     (t            . mime)
  51     )
  52   "*Alist to specify field encoding method.
  53 Its key is field-name, value is encoding method.
  54
  55 If method is `mime', this field will be encoded into MIME format.
  56
  57 If method is a MIME-charset, this field will be encoded as the charset
  58 when it must be convert into network-code.
  59
  60 If method is `default-mime-charset', this field will be encoded as
  61 variable `default-mime-charset' when it must be convert into
  62 network-code.
  63
  64 If method is nil, this field will not be encoded.")
  65
  66 (defvar eword-charset-encoding-alist
  67   '((us-ascii           . nil)
  68     (iso-8859-1         . "Q")
  69     (iso-8859-2         . "Q")
  70     (iso-8859-3         . "Q")
  71     (iso-8859-4         . "Q")
  72     (iso-8859-5         . "Q")
  73     (koi8-r             . "Q")
  74     (iso-8859-7         . "Q")
  75     (iso-8859-8         . "Q")
  76     (iso-8859-9         . "Q")
  77     (iso-2022-jp        . "B")
  78     (iso-2022-kr        . "B")
  79     (gb2312             . "B")
  80     (cn-gb              . "B")
  81     (cn-gb-2312         . "B")
  82     (euc-kr             . "B")
  83     (iso-2022-jp-2      . "B")
  84     (iso-2022-int-1     . "B")
  85     ))
  86
  87
  88 ;;; @ encoded-text encoder
  89 ;;;
  90
  91 (defun eword-encode-text (charset encoding string &optional mode)
  92   "Encode STRING as an encoded-word, and return the result.
  93 CHARSET is a symbol to indicate MIME charset of the encoded-word.
  94 ENCODING allows \"B\" or \"Q\".
  95 MODE is allows `text', `comment', `phrase' or nil.  Default value is
  96 `phrase'."
  97   (let ((text
  98          (cond ((string= encoding "B")
  99                 (base64-encode-string string))
 100                ((string= encoding "Q")
 101                 (q-encoding-encode-string string mode))
 102                )
 103          ))
 104     (if text
 105         (concat "=?" (upcase (symbol-name charset)) "?"
 106                 encoding "?" text "?=")
 107       )))
 108
 109
 110 ;;; @ charset word
 111 ;;;
 112
 113 (defsubst eword-encode-char-type (character)
 114   (if (or (eq character ? )(eq character ?\t))
 115       nil
 116     (char-charset character)
 117     ))
 118
 119 (defun eword-encode-divide-into-charset-words (string)
 120   (let ((len (length string))
 121         dest)
 122     (while (> len 0)
 123       (let* ((chr (sref string 0))
 124              (charset (eword-encode-char-type chr))
 125              (i (char-bytes chr))
 126              )
 127         (while (and (< i len)
 128                     (setq chr (sref string i))
 129                     (eq charset (eword-encode-char-type chr))
 130                     )
 131           (setq i (+ i (char-bytes chr)))
 132           )
 133         (setq dest (cons (cons charset (substring string 0 i)) dest)
 134               string (substring string i)
 135               len (- len i)
 136               )))
 137     (nreverse dest)
 138     ))
 139
 140
 141 ;;; @ word
 142 ;;;
 143
 144 (defun eword-encode-charset-words-to-words (charset-words)
 145   (let (dest)
 146     (while charset-words
 147       (let* ((charset-word (car charset-words))
 148              (charset (car charset-word))
 149              )
 150         (if charset
 151             (let ((charsets (list charset))
 152                   (str (cdr charset-word))
 153                   )
 154               (catch 'tag
 155                 (while (setq charset-words (cdr charset-words))
 156                   (setq charset-word (car charset-words)
 157                         charset (car charset-word))
 158                   (if (null charset)
 159                       (throw 'tag nil)
 160                     )
 161                   (or (memq charset charsets)
 162                       (setq charsets (cons charset charsets))
 163                       )
 164                   (setq str (concat str (cdr charset-word)))
 165                   ))
 166               (setq dest (cons (cons charsets str) dest))
 167               )
 168           (setq dest (cons charset-word dest)
 169                 charset-words (cdr charset-words)
 170                 ))))
 171     (nreverse dest)
 172     ))
 173
 174
 175 ;;; @ rule
 176 ;;;
 177
 178 (defmacro tm-eword::make-rword (text charset encoding type)
 179   (` (list (, text)(, charset)(, encoding)(, type))))
 180 (defmacro tm-eword::rword-text (rword)
 181   (` (car (, rword))))
 182 (defmacro tm-eword::rword-charset (rword)
 183   (` (car (cdr (, rword)))))
 184 (defmacro tm-eword::rword-encoding (rword)
 185   (` (car (cdr (cdr (, rword))))))
 186 (defmacro tm-eword::rword-type (rword)
 187   (` (car (cdr (cdr (cdr (, rword)))))))
 188
 189 (defun tm-eword::find-charset-rule (charsets)
 190   (if charsets
 191       (let* ((charset (charsets-to-mime-charset charsets))
 192              (encoding (cdr (assq charset eword-charset-encoding-alist)))
 193              )
 194         (list charset encoding)
 195         )))
 196
 197 (defun tm-eword::words-to-ruled-words (wl &optional mode)
 198   (mapcar (function
 199            (lambda (word)
 200              (let ((ret (tm-eword::find-charset-rule (car word))))
 201                (tm-eword::make-rword (cdr word) (car ret)(nth 1 ret) mode)
 202                )))
 203           wl))
 204
 205 (defun tm-eword::space-process (seq)
 206   (let (prev a ac b c cc)
 207     (while seq
 208       (setq b (car seq))
 209       (setq seq (cdr seq))
 210       (setq c (car seq))
 211       (setq cc (tm-eword::rword-charset c))
 212       (if (null (tm-eword::rword-charset b))
 213           (progn
 214             (setq a (car prev))
 215             (setq ac (tm-eword::rword-charset a))
 216             (if (and (tm-eword::rword-encoding a)
 217                      (tm-eword::rword-encoding c))
 218                 (cond ((eq ac cc)
 219                        (setq prev (cons
 220                                    (cons (concat (car a)(car b)(car c))
 221                                          (cdr a))
 222                                    (cdr prev)
 223                                    ))
 224                        (setq seq (cdr seq))
 225                        )
 226                       (t
 227                        (setq prev (cons
 228                                    (cons (concat (car a)(car b))
 229                                          (cdr a))
 230                                    (cdr prev)
 231                                    ))
 232                        ))
 233               (setq prev (cons b prev))
 234               ))
 235         (setq prev (cons b prev))
 236         ))
 237     (reverse prev)
 238     ))
 239
 240 (defun tm-eword::split-string (str &optional mode)
 241   (tm-eword::space-process
 242    (tm-eword::words-to-ruled-words
 243     (eword-encode-charset-words-to-words
 244      (eword-encode-divide-into-charset-words str))
 245     mode)))
 246
 247
 248 ;;; @ length
 249 ;;;
 250
 251 (defun tm-eword::encoded-word-length (rword)
 252   (let ((string   (tm-eword::rword-text     rword))
 253         (charset  (tm-eword::rword-charset  rword))
 254         (encoding (tm-eword::rword-encoding rword))
 255         ret)
 256     (setq ret
 257           (cond ((string-equal encoding "B")
 258                  (setq string (encode-mime-charset-string string charset))
 259                  (base64-encoded-length string)
 260                  )
 261                 ((string-equal encoding "Q")
 262                  (setq string (encode-mime-charset-string string charset))
 263                  (q-encoding-encoded-length string
 264                                             (tm-eword::rword-type rword))
 265                  )))
 266     (if ret
 267         (cons (+ 7 (length (symbol-name charset)) ret) string)
 268       )))
 269
 270
 271 ;;; @ encode-string
 272 ;;;
 273
 274 (defun tm-eword::encode-string-1 (column rwl)
 275   (let* ((rword (car rwl))
 276          (ret (tm-eword::encoded-word-length rword))
 277          string len)
 278     (if (null ret)
 279         (cond ((and (setq string (car rword))
 280                     (or (<= (setq len (+ (length string) column)) 76)
 281                         (<= column 1))
 282                     )
 283                (setq rwl (cdr rwl))
 284                )
 285               (t
 286                (setq string "\n ")
 287                (setq len 1)
 288                ))
 289       (cond ((and (setq len (car ret))
 290                   (<= (+ column len) 76)
 291                   )
 292              (setq string
 293                    (eword-encode-text
 294                     (tm-eword::rword-charset rword)
 295                     (tm-eword::rword-encoding rword)
 296                     (cdr ret)
 297                     (tm-eword::rword-type rword)
 298                     ))
 299              (setq len (+ (length string) column))
 300              (setq rwl (cdr rwl))
 301              )
 302             (t
 303              (setq string (car rword))
 304              (let* ((p 0) np
 305                     (str "") nstr)
 306                (while (and (< p len)
 307                            (progn
 308                              (setq np (+ p (char-bytes (sref string p))))
 309                              (setq nstr (substring string 0 np))
 310                              (setq ret (tm-eword::encoded-word-length
 311                                         (cons nstr (cdr rword))
 312                                         ))
 313                              (setq nstr (cdr ret))
 314                              (setq len (+ (car ret) column))
 315                              (<= len 76)
 316                              ))
 317                  (setq str nstr
 318                        p np))
 319                (if (string-equal str "")
 320                    (setq string "\n "
 321                          len 1)
 322                  (setq rwl (cons (cons (substring string p) (cdr rword))
 323                                  (cdr rwl)))
 324                  (setq string
 325                        (eword-encode-text
 326                         (tm-eword::rword-charset rword)
 327                         (tm-eword::rword-encoding rword)
 328                         str
 329                         (tm-eword::rword-type rword)))
 330                  (setq len (+ (length string) column))
 331                  )
 332                )))
 333       )
 334     (list string len rwl)
 335     ))
 336
 337 (defun tm-eword::encode-rwl (column rwl)
 338   (let (ret dest ps special str ew-f pew-f)
 339     (while rwl
 340       (setq ew-f (nth 2 (car rwl)))
 341       (if (and pew-f ew-f)
 342           (setq rwl (cons '(" ") rwl)
 343                 pew-f nil)
 344         (setq pew-f ew-f)
 345         )
 346       (setq ret (tm-eword::encode-string-1 column rwl))
 347       (setq str (car ret))
 348       (if (eq (elt str 0) ?\n)
 349           (if (eq special ?\()
 350               (progn
 351                 (setq dest (concat dest "\n ("))
 352                 (setq ret (tm-eword::encode-string-1 2 rwl))
 353                 (setq str (car ret))
 354                 ))
 355         (cond ((eq special ? )
 356                (if (string= str "(")
 357                    (setq ps t)
 358                  (setq dest (concat dest " "))
 359                  (setq ps nil)
 360                  ))
 361               ((eq special ?\()
 362                (if ps
 363                    (progn
 364                      (setq dest (concat dest " ("))
 365                      (setq ps nil)
 366                      )
 367                  (setq dest (concat dest "("))
 368                  )
 369                )))
 370       (cond ((string= str " ")
 371              (setq special ? )
 372              )
 373             ((string= str "(")
 374              (setq special ?\()
 375              )
 376             (t
 377              (setq special nil)
 378              (setq dest (concat dest str))
 379              ))
 380       (setq column (nth 1 ret)
 381             rwl (nth 2 ret))
 382       )
 383     (list dest column)
 384     ))
 385
 386 (defun tm-eword::encode-string (column str &optional mode)
 387   (tm-eword::encode-rwl column (tm-eword::split-string str mode))
 388   )
 389
 390
 391 ;;; @ converter
 392 ;;;
 393
 394 (defun tm-eword::phrase-to-rwl (phrase)
 395   (let (token type dest str)
 396     (while phrase
 397       (setq token (car phrase))
 398       (setq type (car token))
 399       (cond ((eq type 'quoted-string)
 400              (setq str (concat "\"" (cdr token) "\""))
 401              (setq dest
 402                    (append dest
 403                            (list
 404                             (let ((ret (tm-eword::find-charset-rule
 405                                         (find-non-ascii-charset-string str))))
 406                               (tm-eword::make-rword
 407                                str (car ret)(nth 1 ret) 'phrase)
 408                               )
 409                             )))
 410              )
 411             ((eq type 'comment)
 412              (setq dest
 413                    (append dest
 414                            '(("(" nil nil))
 415                            (tm-eword::words-to-ruled-words
 416                             (eword-encode-charset-words-to-words
 417                              (eword-encode-divide-into-charset-words
 418                               (cdr token)))
 419                             'comment)
 420                            '((")" nil nil))
 421                            ))
 422              )
 423             (t
 424              (setq dest
 425                    (append dest
 426                            (tm-eword::words-to-ruled-words
 427                             (eword-encode-charset-words-to-words
 428                              (eword-encode-divide-into-charset-words
 429                               (cdr token))
 430                              ) 'phrase)))
 431              ))
 432       (setq phrase (cdr phrase))
 433       )
 434     (tm-eword::space-process dest)
 435     ))
 436
 437 (defun eword-addr-seq-to-rwl (seq)
 438   (let (dest pname)
 439     (while seq
 440       (let* ((token (car seq))
 441              (name (car token))
 442              )
 443         (cond ((eq name 'spaces)
 444                (setq dest (nconc dest (list (list (cdr token) nil nil))))
 445                )
 446               ((eq name 'comment)
 447                (setq dest
 448                      (nconc
 449                       dest
 450                       (list (list "(" nil nil))
 451                       (tm-eword::split-string (cdr token) 'comment)
 452                       (list (list ")" nil nil))
 453                       ))
 454                )
 455               ((eq name 'quoted-string)
 456                (setq dest
 457                      (nconc
 458                       dest
 459                       (list
 460                        (list (concat "\"" (cdr token) "\"") nil nil)
 461                        )))
 462                )
 463               (t
 464                (setq dest
 465                      (if (or (eq pname 'spaces)
 466                              (eq pname 'comment))
 467                          (nconc dest (list (list (cdr token) nil nil)))
 468                        (nconc (butlast dest)
 469                               (list
 470                                (list (concat (car (car (last dest)))
 471                                              (cdr token))
 472                                      nil nil)))))
 473                ))
 474         (setq seq (cdr seq)
 475               pname name))
 476       )
 477     dest))
 478
 479 (defun eword-phrase-route-addr-to-rwl (phrase-route-addr)
 480   (if (eq (car phrase-route-addr) 'phrase-route-addr)
 481       (let ((phrase (nth 1 phrase-route-addr))
 482             (route (nth 2 phrase-route-addr))
 483             dest)
 484         (if (eq (car (car phrase)) 'spaces)
 485             (setq phrase (cdr phrase))
 486           )
 487         (setq dest (tm-eword::phrase-to-rwl phrase))
 488         (if dest
 489             (setq dest (append dest '((" " nil nil))))
 490           )
 491         (append
 492          dest
 493          (eword-addr-seq-to-rwl
 494           (append '((specials . "<"))
 495                   route
 496                   '((specials . ">"))))
 497          ))))
 498
 499 (defun eword-addr-spec-to-rwl (addr-spec)
 500   (if (eq (car addr-spec) 'addr-spec)
 501       (eword-addr-seq-to-rwl (cdr addr-spec))
 502     ))
 503
 504 (defun tm-eword::mailbox-to-rwl (mbox)
 505   (let ((addr (nth 1 mbox))
 506         (comment (nth 2 mbox))
 507         dest)
 508     (setq dest (or (eword-phrase-route-addr-to-rwl addr)
 509                    (eword-addr-spec-to-rwl addr)
 510                    ))
 511     (if comment
 512         (setq dest
 513               (append dest
 514                       '((" " nil nil)
 515                         ("(" nil nil))
 516                       (tm-eword::split-string comment 'comment)
 517                       '((")" nil nil))
 518                       )))
 519     dest))
 520
 521 (defun tm-eword::addresses-to-rwl (addresses)
 522   (let ((dest (tm-eword::mailbox-to-rwl (car addresses))))
 523     (if dest
 524         (while (setq addresses (cdr addresses))
 525           (setq dest (append dest
 526                              '(("," nil nil))
 527                              '((" " nil nil))
 528                              (tm-eword::mailbox-to-rwl (car addresses))
 529                              ))
 530           ))
 531     dest))
 532
 533 (defun tm-eword::encode-address-list (column str)
 534   (tm-eword::encode-rwl
 535    column
 536    (tm-eword::addresses-to-rwl (std11-parse-addresses-string str))
 537    ))
 538
 539
 540 ;;; @ application interfaces
 541 ;;;
 542
 543 (defun eword-encode-field (string)
 544   "Encode header field STRING, and return the result.
 545 A lexical token includes non-ASCII character is encoded as MIME
 546 encoded-word.  ASCII token is not encoded."
 547   (setq string (std11-unfold-string string))
 548   (let ((ret (string-match std11-field-head-regexp string)))
 549     (or (if ret
 550             (let ((field-name (substring string 0 (1- (match-end 0))))
 551                   (field-body (eliminate-top-spaces
 552                                (substring string (match-end 0))))
 553                   )
 554               (if (setq ret
 555                         (cond ((string-equal field-body "") "")
 556                               ((memq (intern (downcase field-name))
 557                                      '(reply-to
 558                                        from sender
 559                                        resent-reply-to resent-from
 560                                        resent-sender to resent-to
 561                                        cc resent-cc
 562                                        bcc resent-bcc dcc)
 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