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