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