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