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