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.22 $
   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.22 1997-06-21 15:13:52 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 tm-eword::lc-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     (tm-eword::lc-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                     (<= (setq len (+ (length string) column)) 76)
 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                     (tm-eword::rword-charset rword)
 297                     (tm-eword::rword-encoding rword)
 298                     (cdr ret)
 299                     (tm-eword::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 (+ p (char-bytes (sref string 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                         (tm-eword::rword-charset rword)
 329                         (tm-eword::rword-encoding rword)
 330                         str
 331                         (tm-eword::rword-type rword)))
 332                  (setq len (+ (length string) column))
 333                  )
 334                )))
 335       )
 336     (list string len rwl)
 337     ))
 338
 339 (defun tm-eword::encode-rwl (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 (defun tm-eword::encode-string (column str &optional mode)
 389   (tm-eword::encode-rwl column (tm-eword::split-string str mode))
 390   )
 391
 392
 393 ;;; @ converter
 394 ;;;
 395
 396 (defun tm-eword::phrase-to-rwl (phrase)
 397   (let (token type dest str)
 398     (while phrase
 399       (setq token (car phrase))
 400       (setq type (car token))
 401       (cond ((eq type 'quoted-string)
 402              (setq str (concat "\"" (cdr token) "\""))
 403              (setq dest
 404                    (append dest
 405                            (list
 406                             (let ((ret (tm-eword::find-charset-rule
 407                                         (find-non-ascii-charset-string str))))
 408                               (tm-eword::make-rword
 409                                str (car ret)(nth 1 ret) 'phrase)
 410                               )
 411                             )))
 412              )
 413             ((eq type 'comment)
 414              (setq dest
 415                    (append dest
 416                            '(("(" nil nil))
 417                            (tm-eword::words-to-ruled-words
 418                             (tm-eword::lc-words-to-words
 419                              (eword-encode-divide-into-charset-words
 420                               (cdr token)))
 421                             'comment)
 422                            '((")" nil nil))
 423                            ))
 424              )
 425             (t
 426              (setq dest
 427                    (append dest
 428                            (tm-eword::words-to-ruled-words
 429                             (tm-eword::lc-words-to-words
 430                              (eword-encode-divide-into-charset-words
 431                               (cdr token))
 432                              ) 'phrase)))
 433              ))
 434       (setq phrase (cdr phrase))
 435       )
 436     (tm-eword::space-process dest)
 437     ))
 438
 439 (defun tm-eword::phrase-route-addr-to-rwl (phrase-route-addr)
 440   (if (eq (car phrase-route-addr) 'phrase-route-addr)
 441       (let ((phrase (nth 1 phrase-route-addr))
 442             (route (nth 2 phrase-route-addr))
 443             dest)
 444         (if (eq (car (car phrase)) 'spaces)
 445             (setq phrase (cdr phrase))
 446           )
 447         (setq dest (tm-eword::phrase-to-rwl phrase))
 448         (if dest
 449             (setq dest (append dest '((" " nil nil))))
 450           )
 451         (append
 452          dest
 453          (list (list (concat "<" (std11-addr-to-string route) ">") nil nil))
 454          ))))
 455
 456 (defun tm-eword::addr-spec-to-rwl (addr-spec)
 457   (if (eq (car addr-spec) 'addr-spec)
 458       (list (list (std11-addr-to-string (cdr addr-spec)) nil nil))
 459     ))
 460
 461 (defun tm-eword::mailbox-to-rwl (mbox)
 462   (let ((addr (nth 1 mbox))
 463         (comment (nth 2 mbox))
 464         dest)
 465     (setq dest (or (tm-eword::phrase-route-addr-to-rwl addr)
 466                    (tm-eword::addr-spec-to-rwl addr)
 467                    ))
 468     (if comment
 469         (setq dest
 470               (append dest
 471                       '((" " nil nil)
 472                         ("(" nil nil))
 473                       (tm-eword::split-string comment 'comment)
 474                       '((")" nil nil))
 475                       )))
 476     dest))
 477
 478 (defun tm-eword::addresses-to-rwl (addresses)
 479   (let ((dest (tm-eword::mailbox-to-rwl (car addresses))))
 480     (if dest
 481         (while (setq addresses (cdr addresses))
 482           (setq dest (append dest
 483                              '(("," nil nil))
 484                              '((" " nil nil))
 485                              (tm-eword::mailbox-to-rwl (car addresses))
 486                              ))
 487           ))
 488     dest))
 489
 490 (defun tm-eword::encode-address-list (column str)
 491   (tm-eword::encode-rwl
 492    column
 493    (tm-eword::addresses-to-rwl (std11-parse-addresses-string str))
 494    ))
 495
 496
 497 ;;; @ application interfaces
 498 ;;;
 499
 500 (defun eword-encode-field (string)
 501   "Encode header field STRING, and return the result.
 502 A lexical token includes non-ASCII character is encoded as MIME
 503 encoded-word.  ASCII token is not encoded."
 504   (setq string (std11-unfold-string string))
 505   (let ((ret (string-match std11-field-head-regexp string)))
 506     (or (if ret
 507             (let ((field-name (substring string 0 (1- (match-end 0))))
 508                   (field-body (eliminate-top-spaces
 509                                (substring string (match-end 0))))
 510                   )
 511               (if (setq ret
 512                         (cond ((string-equal field-body "") "")
 513                               ((memq (intern (downcase field-name))
 514                                      '(reply-to
 515                                        from sender
 516                                        resent-reply-to resent-from
 517                                        resent-sender to resent-to
 518                                        cc resent-cc
 519                                        bcc resent-bcc dcc)
 520                                      )
 521                                (car (tm-eword::encode-address-list
 522                                      (+ (length field-name) 2) field-body))
 523                                )
 524                               (t
 525                                (car (tm-eword::encode-string
 526                                      (1+ (length field-name))
 527                                      field-body 'text))
 528                                ))
 529                         )
 530                   (concat field-name ": " ret)
 531                 )))
 532         (car (tm-eword::encode-string 0 string))
 533         )))
 534
 535 (defun eword-in-subject-p ()
 536   (let ((str (std11-field-body "Subject")))
 537     (if (and str (string-match eword-encoded-word-regexp str))
 538         str)))
 539
 540 (defun eword-encode-header (&optional code-conversion)
 541   "Encode header fields to network representation, such as MIME encoded-word.
 542
 543 It refer variable `eword-field-encoding-method-alist'."
 544   (interactive "*")
 545   (save-excursion
 546     (save-restriction
 547       (std11-narrow-to-header mail-header-separator)
 548       (goto-char (point-min))
 549       (let ((default-cs (mime-charset-to-coding-system default-mime-charset))
 550             beg end field-name)
 551         (while (re-search-forward std11-field-head-regexp nil t)
 552           (setq beg (match-beginning 0))
 553           (setq field-name (buffer-substring beg (1- (match-end 0))))
 554           (setq end (std11-field-end))
 555           (and (find-non-ascii-charset-region beg end)
 556                (let ((ret (or (let ((fname  (downcase field-name)))
 557                                 (assoc-if
 558                                  (function
 559                                   (lambda (str)
 560                                     (and (stringp str)
 561                                          (string= fname (downcase str))
 562                                          )))
 563                                  eword-field-encoding-method-alist))
 564                               (assq t eword-field-encoding-method-alist)
 565                               )))
 566                  (if ret
 567                      (let ((method (cdr ret)))
 568                        (cond ((eq method 'mime)
 569                               (let ((field
 570                                      (buffer-substring-no-properties beg end)
 571                                      ))
 572                                 (delete-region beg end)
 573                                 (insert (eword-encode-field field))
 574                                 ))
 575                              (code-conversion
 576                               (let ((cs
 577                                      (or (mime-charset-to-coding-system
 578                                           method)
 579                                          default-cs)))
 580                                 (encode-coding-region beg end cs)
 581                                 )))
 582                        ))
 583                  ))
 584           ))
 585       (and eword-generate-X-Nsubject
 586            (or (std11-field-body "X-Nsubject")
 587                (let ((str (eword-in-subject-p)))
 588                  (if str
 589                      (progn
 590                        (setq str
 591                              (eword-decode-string
 592                               (std11-unfold-string str)))
 593                        (if code-conversion
 594                            (setq str
 595                                  (encode-mime-charset-string
 596                                   str
 597                                   (or (cdr (assoc-if
 598                                             (function
 599                                              (lambda (str)
 600                                                (and (stringp str)
 601                                                     (string= "x-nsubject"
 602                                                              (downcase str))
 603                                                     )))
 604                                             eword-field-encoding-method-alist))
 605                                       'iso-2022-jp-2)))
 606                          )
 607                        (insert (concat "\nX-Nsubject: " str))
 608                        )))))
 609       )))
 610
 611 (defun eword-encode-string (str &optional column mode)
 612   (car (tm-eword::encode-rwl (or column 0) (tm-eword::split-string str mode)))
 613   )
 614
 615
 616 ;;; @ end
 617 ;;;
 618
 619 (provide 'eword-encode)
 620
 621 ;;; eword-encode.el ends here