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