tm-ew-e.el

   1 ;;; tm-ew-e.el --- RFC 2047 based encoded-word encoder for GNU Emacs
   2
   3 ;; Copyright (C) 1995,1996 Free Software Foundation, Inc.
   4
   5 ;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
   6 ;; Version: $Revision: 7.57 $
   7 ;; Keywords: encoded-word, MIME, multilingual, header, mail, news
   8
   9 ;; This file is part of tm (Tools for MIME).
  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 'tm-def)
  31 (require 'tl-list)
  32
  33
  34 ;;; @ version
  35 ;;;
  36
  37 (defconst tm-ew-e/RCS-ID
  38   "$Id: tm-ew-e.el,v 7.57 1996/12/12 02:30:04 morioka Exp $")
  39 (defconst mime-eword/encoder-version (get-version-string tm-ew-e/RCS-ID))
  40
  41
  42 ;;; @ variables
  43 ;;;
  44
  45 (defvar mime/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. [tm-ew-e.el]")
  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 `mime/encode-message-header'.
  78 \[tm-ew-e.el]")
  79
  80 (defvar mime-eword/charset-encoding-alist
  81   '((us-ascii           . nil)
  82     (iso-8859-1         . "Q")
  83     (iso-8859-2         . "Q")
  84     (iso-8859-3         . "Q")
  85     (iso-8859-4         . "Q")
  86     (iso-8859-5         . "Q")
  87     (koi8-r             . "Q")
  88     (iso-8859-7         . "Q")
  89     (iso-8859-8         . "Q")
  90     (iso-8859-9         . "Q")
  91     (iso-2022-jp        . "B")
  92     (iso-2022-kr        . "B")
  93     (gb2312             . "B")
  94     (cn-gb              . "B")
  95     (cn-gb-2312         . "B")
  96     (euc-kr             . "B")
  97     (iso-2022-jp-2      . "B")
  98     (iso-2022-int-1     . "B")
  99     ))
 100
 101
 102 ;;; @ encoded-text encoder
 103 ;;;
 104
 105 (defun tm-eword::encode-encoded-text (charset encoding string &optional mode)
 106   (let ((text
 107          (cond ((string= encoding "B")
 108                 (base64-encode-string string))
 109                ((string= encoding "Q")
 110                 (q-encoding-encode-string string mode))
 111                )
 112          ))
 113     (if text
 114         (concat "=?" (upcase (symbol-name charset)) "?"
 115                 encoding "?" text "?=")
 116       )))
 117
 118
 119 ;;; @ leading char
 120 ;;;
 121
 122 (defun tm-eword::char-type (chr)
 123   (if (or (= chr 32)(= chr ?\t))
 124       nil
 125     (char-charset chr)
 126     ))
 127
 128 (defun tm-eword::parse-lc-word (str)
 129   (let* ((chr (sref str 0))
 130          (lc (tm-eword::char-type chr))
 131          (i (char-length chr))
 132          (len (length str))
 133          )
 134     (while (and (< i len)
 135                 (setq chr (sref str i))
 136                 (eq lc (tm-eword::char-type chr))
 137                 )
 138       (setq i (+ i (char-length chr)))
 139       )
 140     (cons (cons lc (substring str 0 i)) (substring str i))
 141     ))
 142
 143 (defun tm-eword::split-to-lc-words (str)
 144   (let (ret dest)
 145     (while (and (not (string= str ""))
 146                 (setq ret (tm-eword::parse-lc-word str))
 147                 )
 148       (setq dest (cons (car ret) dest))
 149       (setq str (cdr ret))
 150       )
 151     (reverse dest)
 152     ))
 153
 154
 155 ;;; @ word
 156 ;;;
 157
 158 (defun tm-eword::parse-word (lcwl)
 159   (let* ((lcw (car lcwl))
 160          (lc (car lcw))
 161          )
 162     (if (null lc)
 163         lcwl
 164       (let ((lcl (list lc))
 165             (str (cdr lcw))
 166             )
 167         (catch 'tag
 168           (while (setq lcwl (cdr lcwl))
 169             (setq lcw (car lcwl))
 170             (setq lc (car lcw))
 171             (if (null lc)
 172                 (throw 'tag nil)
 173               )
 174             (if (not (memq lc lcl))
 175                 (setq lcl (cons lc lcl))
 176               )
 177             (setq str (concat str (cdr lcw)))
 178             ))
 179         (cons (cons lcl str) lcwl)
 180         ))))
 181
 182 (defun tm-eword::lc-words-to-words (lcwl)
 183   (let (ret dest)
 184     (while (setq ret (tm-eword::parse-word lcwl))
 185       (setq dest (cons (car ret) dest))
 186       (setq lcwl (cdr ret))
 187       )
 188     (reverse dest)
 189     ))
 190
 191
 192 ;;; @ rule
 193 ;;;
 194
 195 (defmacro tm-eword::make-rword (text charset encoding type)
 196   (` (list (, text)(, charset)(, encoding)(, type))))
 197 (defmacro tm-eword::rword-text (rword)
 198   (` (car (, rword))))
 199 (defmacro tm-eword::rword-charset (rword)
 200   (` (car (cdr (, rword)))))
 201 (defmacro tm-eword::rword-encoding (rword)
 202   (` (car (cdr (cdr (, rword))))))
 203 (defmacro tm-eword::rword-type (rword)
 204   (` (car (cdr (cdr (cdr (, rword)))))))
 205
 206 (defun tm-eword::find-charset-rule (charsets)
 207   (if charsets
 208       (let* ((charset (charsets-to-mime-charset charsets))
 209              (encoding (cdr (assq charset mime-eword/charset-encoding-alist)))
 210              )
 211         (list charset encoding)
 212         )))
 213
 214 (defun tm-eword::words-to-ruled-words (wl &optional mode)
 215   (mapcar (function
 216            (lambda (word)
 217              (let ((ret (tm-eword::find-charset-rule (car word))))
 218                (tm-eword::make-rword (cdr word) (car ret)(nth 1 ret) mode)
 219                )))
 220           wl))
 221
 222 (defun tm-eword::space-process (seq)
 223   (let (prev a ac b c cc)
 224     (while seq
 225       (setq b (car seq))
 226       (setq seq (cdr seq))
 227       (setq c (car seq))
 228       (setq cc (tm-eword::rword-charset c))
 229       (if (null (tm-eword::rword-charset b))
 230           (progn
 231             (setq a (car prev))
 232             (setq ac (tm-eword::rword-charset a))
 233             (if (and (tm-eword::rword-encoding a)
 234                      (tm-eword::rword-encoding c))
 235                 (cond ((eq ac cc)
 236                        (setq prev (cons
 237                                    (cons (concat (car a)(car b)(car c))
 238                                          (cdr a))
 239                                    (cdr prev)
 240                                    ))
 241                        (setq seq (cdr seq))
 242                        )
 243                       (t
 244                        (setq prev (cons
 245                                    (cons (concat (car a)(car b))
 246                                          (cdr a))
 247                                    (cdr prev)
 248                                    ))
 249                        ))
 250               (setq prev (cons b prev))
 251               ))
 252         (setq prev (cons b prev))
 253         ))
 254     (reverse prev)
 255     ))
 256
 257 (defun tm-eword::split-string (str &optional mode)
 258   (tm-eword::space-process
 259    (tm-eword::words-to-ruled-words (tm-eword::lc-words-to-words
 260                                     (tm-eword::split-to-lc-words str))
 261                                    mode)))
 262
 263
 264 ;;; @ length
 265 ;;;
 266
 267 (defun tm-eword::encoded-word-length (rword)
 268   (let ((string   (tm-eword::rword-text     rword))
 269         (charset  (tm-eword::rword-charset  rword))
 270         (encoding (tm-eword::rword-encoding rword))
 271         ret)
 272     (setq ret
 273           (cond ((string-equal encoding "B")
 274                  (setq string (encode-mime-charset-string string charset))
 275                  (base64-encoded-length string)
 276                  )
 277                 ((string-equal encoding "Q")
 278                  (setq string (encode-mime-charset-string string charset))
 279                  (q-encoding-encoded-length string
 280                                             (tm-eword::rword-type rword))
 281                  )))
 282     (if ret
 283         (cons (+ 7 (length (symbol-name charset)) ret) string)
 284       )))
 285
 286
 287 ;;; @ encode-string
 288 ;;;
 289
 290 (defun tm-eword::encode-string-1 (column rwl)
 291   (let* ((rword (car rwl))
 292          (ret (tm-eword::encoded-word-length rword))
 293          string len)
 294     (if (null ret)
 295         (cond ((and (setq string (car rword))
 296                     (<= (setq len (+ (length string) column)) 76)
 297                     )
 298                (setq rwl (cdr rwl))
 299                )
 300               (t
 301                (setq string "\n ")
 302                (setq len 1)
 303                ))
 304       (cond ((and (setq len (car ret))
 305                   (<= (+ column len) 76)
 306                   )
 307              (setq string
 308                    (tm-eword::encode-encoded-text
 309                     (tm-eword::rword-charset rword)
 310                     (tm-eword::rword-encoding rword)
 311                     (cdr ret)
 312                     (tm-eword::rword-type rword)
 313                     ))
 314              (setq len (+ (length string) column))
 315              (setq rwl (cdr rwl))
 316              )
 317             (t
 318              (setq string (car rword))
 319              (let* ((sl (length string))
 320                     (p 0) np
 321                     (str "") nstr)
 322                (while (and (< p len)
 323                            (progn
 324                              (setq np (+ p (char-length (sref string p))))
 325                              (setq nstr (substring string 0 np))
 326                              (setq ret (tm-eword::encoded-word-length
 327                                         (cons nstr (cdr rword))
 328                                         ))
 329                              (setq nstr (cdr ret))
 330                              (setq len (+ (car ret) column))
 331                              (<= len 76)
 332                              ))
 333                  (setq str nstr
 334                        p np))
 335                (if (string-equal str "")
 336                    (setq string "\n "
 337                          len 1)
 338                  (setq rwl (cons (cons (substring string p) (cdr rword))
 339                                  (cdr rwl)))
 340                  (setq string
 341                        (tm-eword::encode-encoded-text
 342                         (tm-eword::rword-charset rword)
 343                         (tm-eword::rword-encoding rword)
 344                         str
 345                         (tm-eword::rword-type rword)))
 346                  (setq len (+ (length string) column))
 347                  )
 348                )))
 349       )
 350     (list string len rwl)
 351     ))
 352
 353 (defun tm-eword::encode-rwl (column rwl)
 354   (let (ret dest ps special str ew-f pew-f)
 355     (while rwl
 356       (setq ew-f (nth 2 (car rwl)))
 357       (if (and pew-f ew-f)
 358           (setq rwl (cons '(" ") rwl)
 359                 pew-f nil)
 360         (setq pew-f ew-f)
 361         )
 362       (setq ret (tm-eword::encode-string-1 column rwl))
 363       (setq str (car ret))
 364       (if (eq (elt str 0) ?\n)
 365           (if (eq special ?\()
 366               (progn
 367                 (setq dest (concat dest "\n ("))
 368                 (setq ret (tm-eword::encode-string-1 2 rwl))
 369                 (setq str (car ret))
 370                 ))
 371         (cond ((eq special 32)
 372                (if (string= str "(")
 373                    (setq ps t)
 374                  (setq dest (concat dest " "))
 375                  (setq ps nil)
 376                  ))
 377               ((eq special ?\()
 378                (if ps
 379                    (progn
 380                      (setq dest (concat dest " ("))
 381                      (setq ps nil)
 382                      )
 383                  (setq dest (concat dest "("))
 384                  )
 385                )))
 386       (cond ((string= str " ")
 387              (setq special 32)
 388              )
 389             ((string= str "(")
 390              (setq special ?\()
 391              )
 392             (t
 393              (setq special nil)
 394              (setq dest (concat dest str))
 395              ))
 396       (setq column (nth 1 ret)
 397             rwl (nth 2 ret))
 398       )
 399     (list dest column)
 400     ))
 401
 402 (defun tm-eword::encode-string (column str &optional mode)
 403   (tm-eword::encode-rwl column (tm-eword::split-string str mode))
 404   )
 405
 406
 407 ;;; @ converter
 408 ;;;
 409
 410 (defun tm-eword::phrase-to-rwl (phrase)
 411   (let (token type dest str)
 412     (while phrase
 413       (setq token (car phrase))
 414       (setq type (car token))
 415       (cond ((eq type 'quoted-string)
 416              (setq str (concat "\"" (cdr token) "\""))
 417              (setq dest
 418                    (append dest
 419                            (list
 420                             (let ((ret (tm-eword::find-charset-rule
 421                                         (find-non-ascii-charset-string str))))
 422                               (tm-eword::make-rword
 423                                str (car ret)(nth 1 ret) 'phrase)
 424                               )
 425                             )))
 426              )
 427             ((eq type 'comment)
 428              (setq dest
 429                    (append dest
 430                            '(("(" nil nil))
 431                            (tm-eword::words-to-ruled-words
 432                             (tm-eword::lc-words-to-words
 433                              (tm-eword::split-to-lc-words (cdr token)))
 434                             'comment)
 435                            '((")" nil nil))
 436                            ))
 437              )
 438             (t
 439              (setq dest (append dest
 440                                 (tm-eword::words-to-ruled-words
 441                                  (tm-eword::lc-words-to-words
 442                                   (tm-eword::split-to-lc-words (cdr token))
 443                                   ) 'phrase)))
 444              ))
 445       (setq phrase (cdr phrase))
 446       )
 447     (tm-eword::space-process dest)
 448     ))
 449
 450 (defun tm-eword::phrase-route-addr-to-rwl (phrase-route-addr)
 451   (if (eq (car phrase-route-addr) 'phrase-route-addr)
 452       (let ((phrase (nth 1 phrase-route-addr))
 453             (route (nth 2 phrase-route-addr))
 454             dest)
 455         (if (eq (car (car phrase)) 'spaces)
 456             (setq phrase (cdr phrase))
 457           )
 458         (setq dest (tm-eword::phrase-to-rwl phrase))
 459         (if dest
 460             (setq dest (append dest '((" " nil nil))))
 461           )
 462         (append
 463          dest
 464          (list (list (concat "<" (std11-addr-to-string route) ">") nil nil))
 465          ))))
 466
 467 (defun tm-eword::addr-spec-to-rwl (addr-spec)
 468   (if (eq (car addr-spec) 'addr-spec)
 469       (list (list (std11-addr-to-string (cdr addr-spec)) nil nil))
 470     ))
 471
 472 (defun tm-eword::mailbox-to-rwl (mbox)
 473   (let ((addr (nth 1 mbox))
 474         (comment (nth 2 mbox))
 475         dest)
 476     (setq dest (or (tm-eword::phrase-route-addr-to-rwl addr)
 477                    (tm-eword::addr-spec-to-rwl addr)
 478                    ))
 479     (if comment
 480         (setq dest
 481               (append dest
 482                       '((" " nil nil)
 483                         ("(" nil nil))
 484                       (tm-eword::split-string comment 'comment)
 485                       '((")" nil nil))
 486                       )))
 487     dest))
 488
 489 (defun tm-eword::addresses-to-rwl (addresses)
 490   (let ((dest (tm-eword::mailbox-to-rwl (car addresses))))
 491     (if dest
 492         (while (setq addresses (cdr addresses))
 493           (setq dest (append dest
 494                              '(("," nil nil))
 495                              '((" " nil nil))
 496                              (tm-eword::mailbox-to-rwl (car addresses))
 497                              ))
 498           ))
 499     dest))
 500
 501 (defun tm-eword::encode-address-list (column str)
 502   (tm-eword::encode-rwl
 503    column
 504    (tm-eword::addresses-to-rwl (std11-parse-addresses-string str))
 505    ))
 506
 507
 508 ;;; @ application interfaces
 509 ;;;
 510
 511 (defun mime/encode-field (str)
 512   (setq str (std11-unfold-string str))
 513   (let ((ret (string-match std11-field-head-regexp str)))
 514     (or (if ret
 515             (let ((field-name (substring str 0 (1- (match-end 0))))
 516                   (field-body (eliminate-top-spaces
 517                                (substring str (match-end 0))))
 518                   fname)
 519               (if (setq ret
 520                         (cond ((string-equal field-body "") "")
 521                               ((member (setq fname (downcase field-name))
 522                                        '("reply-to" "from" "sender"
 523                                          "resent-reply-to" "resent-from"
 524                                          "resent-sender" "to" "resent-to"
 525                                          "cc" "resent-cc"
 526                                          "bcc" "resent-bcc" "dcc")
 527                                        )
 528                                (car (tm-eword::encode-address-list
 529                                      (+ (length field-name) 2) field-body))
 530                                )
 531                               (t
 532                                (car (tm-eword::encode-string
 533                                      (+ (length field-name) 1)
 534                                      field-body 'text))
 535                                ))
 536                         )
 537                   (concat field-name ": " ret)
 538                 )))
 539         (car (tm-eword::encode-string 0 str))
 540         )))
 541
 542 (defun mime/exist-encoded-word-in-subject ()
 543   (let ((str (std11-field-body "Subject")))
 544     (if (and str (string-match mime/encoded-word-regexp str))
 545         str)))
 546
 547 (defun mime/encode-message-header (&optional code-conversion)
 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 (ASSOC (downcase field-name)
 561                                      mime/field-encoding-method-alist
 562                                      :test (function
 563                                             (lambda (str1 str2)
 564                                               (and (stringp str2)
 565                                                    (string= str1
 566                                                             (downcase str2))
 567                                                    ))))
 568                               (assq t mime/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 (mime/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 mime/generate-X-Nsubject
 590            (or (std11-field-body "X-Nsubject")
 591                (let ((str (mime/exist-encoded-word-in-subject)))
 592                  (if str
 593                      (progn
 594                        (setq str
 595                              (mime-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
 602                                             "x-nsubject"
 603                                             mime/field-encoding-method-alist
 604                                             :test
 605                                             (function
 606                                              (lambda (str1 str2)
 607                                                (and (stringp str2)
 608                                                     (string= str1
 609                                                              (downcase str2))
 610                                                     )))))
 611                                       'iso-2022-jp-2)))
 612                          )
 613                        (insert (concat "\nX-Nsubject: " str))
 614                        )))))
 615       )))
 616
 617 (defun mime-eword/encode-string (str &optional column mode)
 618   (car (tm-eword::encode-rwl (or column 0) (tm-eword::split-string str mode)))
 619   )
 620
 621
 622 ;;; @ end
 623 ;;;
 624
 625 (provide 'tm-ew-e)
 626
 627 ;;; tm-ew-e.el ends here