tm-ew-e.el

   1 ;;;
   2 ;;; tm-ew-e.el --- RFC 1522 based multilingual MIME message header
   3 ;;;                encoder for GNU Emacs
   4 ;;;
   5 ;;; Copyright (C) 1995 Free Software Foundation, Inc.
   6 ;;; Copyright (C) 1993 .. 1996 MORIOKA Tomohiko
   7 ;;;
   8 ;;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
   9 ;;; Version: $Revision: 7.17 $
  10 ;;; Keywords: mail, news, MIME, RFC 1522, multilingual, encoded-word
  11 ;;;
  12 ;;; This file is part of tm (Tools for MIME).
  13 ;;;
  14 ;;; This program is free software; you can redistribute it and/or
  15 ;;; modify it under the terms of the GNU General Public License as
  16 ;;; published by the Free Software Foundation; either version 2, or
  17 ;;; (at your option) any later version.
  18 ;;;
  19 ;;; This program is distributed in the hope that it will be useful,
  20 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  21 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  22 ;;; General Public License for more details.
  23 ;;;
  24 ;;; You should have received a copy of the GNU General Public License
  25 ;;; along with This program.  If not, write to the Free Software
  26 ;;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  27 ;;;
  28 ;;; Code:
  29
  30 (require 'mel)
  31 (require 'tl-822)
  32 (require 'tm-def)
  33
  34
  35 ;;; @ version
  36 ;;;
  37
  38 (defconst tm-ew-e/RCS-ID
  39   "$Id: tm-ew-e.el,v 7.17 1996/05/04 04:58:37 morioka Exp $")
  40 (defconst mime-eword/encoder-version (get-version-string tm-ew-e/RCS-ID))
  41
  42
  43 ;;; @ variables
  44 ;;;
  45
  46 (defvar mime/no-encoding-header-fields '("X-Nsubject" "Newsgroups"))
  47
  48 (defvar mime/use-X-Nsubject nil)
  49
  50 (defvar mime-eword/charset-encoding-alist
  51   '(("US-ASCII"       . nil)
  52     ("ISO-8859-1"     . "Q")
  53     ("ISO-8859-2"     . "Q")
  54     ("ISO-8859-3"     . "Q")
  55     ("ISO-8859-4"     . "Q")
  56 ;;; ("ISO-8859-5"     . "Q")
  57     ("KOI8-R"         . "Q")
  58     ("ISO-8859-7"     . "Q")
  59     ("ISO-8859-8"     . "Q")
  60     ("ISO-8859-9"     . "Q")
  61     ("ISO-2022-JP"    . "B")
  62     ("ISO-2022-KR"    . "B")
  63     ("EUC-KR"         . "B")
  64     ("ISO-2022-JP-2"  . "B")
  65     ("ISO-2022-INT-1" . "B")
  66     ))
  67
  68
  69 ;;; @ encoded-text encoder
  70 ;;;
  71
  72 (defun tm-eword::encode-encoded-text (charset encoding string &optional mode)
  73   (let ((text
  74          (cond ((string= encoding "B")
  75                 (base64-encode-string string))
  76                ((string= encoding "Q")
  77                 (q-encoding-encode-string string mode))
  78                )
  79          ))
  80     (if text
  81         (concat "=?" charset "?" encoding "?" text "?=")
  82       )))
  83
  84
  85 ;;; @ leading char
  86 ;;;
  87
  88 (defun tm-eword::char-type (chr)
  89   (if (or (= chr 32)(= chr ?\t))
  90       nil
  91     (char-leading-char chr)
  92     ))
  93
  94 (defun tm-eword::parse-lc-word (str)
  95   (let* ((chr (sref str 0))
  96          (lc (tm-eword::char-type chr))
  97          (i (char-bytes chr))
  98          (len (length str))
  99          )
 100     (while (and (< i len)
 101                 (setq chr (sref str i))
 102                 (eq lc (tm-eword::char-type chr))
 103                 )
 104       (setq i (+ i (char-bytes chr)))
 105       )
 106     (cons (cons lc (substring str 0 i)) (substring str i))
 107     ))
 108
 109 (defun tm-eword::split-to-lc-words (str)
 110   (let (ret dest)
 111     (while (and (not (string= str ""))
 112                 (setq ret (tm-eword::parse-lc-word str))
 113                 )
 114       (setq dest (cons (car ret) dest))
 115       (setq str (cdr ret))
 116       )
 117     (reverse dest)
 118     ))
 119
 120
 121 ;;; @ word
 122 ;;;
 123
 124 (defun tm-eword::parse-word (lcwl)
 125   (let* ((lcw (car lcwl))
 126          (lc (car lcw))
 127          )
 128     (if (null lc)
 129         lcwl
 130       (let ((lcl (list lc))
 131             (str (cdr lcw))
 132             )
 133         (catch 'tag
 134           (while (setq lcwl (cdr lcwl))
 135             (setq lcw (car lcwl))
 136             (setq lc (car lcw))
 137             (if (null lc)
 138                 (throw 'tag nil)
 139               )
 140             (if (not (memq lc lcl))
 141                 (setq lcl (cons lc lcl))
 142               )
 143             (setq str (concat str (cdr lcw)))
 144             ))
 145         (cons (cons lcl str) lcwl)
 146         ))))
 147
 148 (defun tm-eword::lc-words-to-words (lcwl)
 149   (let (ret dest)
 150     (while (setq ret (tm-eword::parse-word lcwl))
 151       (setq dest (cons (car ret) dest))
 152       (setq lcwl (cdr ret))
 153       )
 154     (reverse dest)
 155     ))
 156
 157
 158 ;;; @ rule
 159 ;;;
 160
 161 (defun tm-eword::find-charset-rule (lcl)
 162   (if lcl
 163       (let* ((charset (mime/find-charset lcl))
 164              (encoding
 165               (cdr (assoc charset mime-eword/charset-encoding-alist))
 166               ))
 167         (list charset encoding)
 168         )))
 169
 170 (defun tm-eword::words-to-ruled-words (wl)
 171   (mapcar (function
 172            (lambda (word)
 173              (cons (cdr word) (tm-eword::find-charset-rule (car word)))
 174              ))
 175           wl))
 176
 177 (defun tm-eword::space-process (seq)
 178   (let (prev a ac b c cc)
 179     (while seq
 180       (setq b (car seq))
 181       (setq seq (cdr seq))
 182       (setq c (car seq))
 183       (setq cc (nth 1 c))
 184       (if (null (nth 1 b))
 185           (progn
 186             (setq a (car prev))
 187             (setq ac (nth 1 a))
 188             (if (and (nth 2 a)(nth 2 c))
 189                 (cond ((equal ac cc)
 190                        (setq prev (cons
 191                                    (cons (concat (car a)(car b)(car c))
 192                                          (cdr a))
 193                                    (cdr prev)
 194                                    ))
 195                        (setq seq (cdr seq))
 196                        )
 197                       (t
 198                        (setq prev (cons
 199                                    (cons (concat (car a)(car b))
 200                                          (cdr a))
 201                                    (cdr prev)
 202                                    ))
 203                        ))
 204               (setq prev (cons b prev))
 205               ))
 206         (setq prev (cons b prev))
 207         ))
 208     (reverse prev)
 209     ))
 210
 211 (defun tm-eword::split-string (str)
 212   (tm-eword::space-process
 213    (tm-eword::words-to-ruled-words
 214     (tm-eword::lc-words-to-words
 215      (tm-eword::split-to-lc-words str)
 216      ))))
 217
 218
 219 ;;; @ length
 220 ;;;
 221
 222 (defun base64-length (string)
 223   (let ((l (length string)))
 224     (* (+ (/ l 3)
 225           (if (= (mod l 3) 0) 0 1)
 226           ) 4)
 227     ))
 228
 229 (defun q-encoding-length (string)
 230   (let ((l 0)(i 0)(len (length string)) chr)
 231     (while (< i len)
 232       (setq chr (elt string i))
 233       (if (string-match "[A-Za-z0-9!*+/=_---]" (char-to-string chr))
 234           (setq l (+ l 1))
 235         (setq l (+ l 3))
 236         )
 237       (setq i (+ i 1)) )
 238     l))
 239
 240 (defun tm-eword::encoded-word-length (rword)
 241   (let ((charset  (nth 1 rword))
 242         (encoding (nth 2 rword))
 243         (string   (car rword))
 244         ret)
 245     (setq ret
 246           (cond ((equal encoding "B")
 247                  (setq string
 248                        (mime/convert-string-from-emacs string charset))
 249                  (base64-length string)
 250                  )
 251                 ((equal encoding "Q")
 252                  (setq string
 253                        (mime/convert-string-from-emacs string charset))
 254                  (q-encoding-length string)
 255                  )))
 256     (if ret
 257         (cons (+ 7 (length charset) ret) string)
 258       )))
 259
 260
 261 ;;; @ encode-string
 262 ;;;
 263
 264 (defun tm-eword::encode-string-1 (column rwl &optional mode)
 265   (let* ((rword (car rwl))
 266          (ret (tm-eword::encoded-word-length rword))
 267          string len)
 268     (if (null ret)
 269         (cond ((and (setq string (car rword))
 270                     (<= (setq len (+ (length string) column)) 76)
 271                     )
 272                (setq rwl (cdr rwl))
 273                )
 274               (t
 275                (setq string "\n ")
 276                (setq len 1)
 277                ))
 278       (cond ((and (setq len (car ret))
 279                   (<= (+ column len) 76)
 280                   )
 281              (setq string
 282                    (tm-eword::encode-encoded-text
 283                     (nth 1 rword) (nth 2 rword) (cdr ret)
 284                     ))
 285              (setq len (+ (length string) column))
 286              (setq rwl (cdr rwl))
 287              )
 288             (t
 289              (setq string (car rword))
 290              (let* ((sl (length string))
 291                     (p 0) np
 292                     (str "") nstr)
 293                (while (and (< p len)
 294                            (progn
 295                              (setq np (+ p (char-bytes (sref string p))))
 296                              (setq nstr (substring string 0 np))
 297                              (setq ret (tm-eword::encoded-word-length
 298                                         (cons nstr (cdr rword))
 299                                         ))
 300                              (setq nstr (cdr ret))
 301                              (setq len (+ (car ret) column))
 302                              (<= len 76)
 303                              ))
 304                  (setq str nstr
 305                        p np))
 306                (if (string-equal str "")
 307                    (setq string "\n "
 308                          len 1)
 309                  (setq rwl (cons (cons (substring string p) (cdr rword))
 310                                  (cdr rwl)))
 311                  (setq string
 312                        (tm-eword::encode-encoded-text
 313                         (nth 1 rword) (nth 2 rword) str))
 314                  (setq len (+ (length string) column))
 315                  )
 316                )))
 317       )
 318     (list string len rwl)
 319     ))
 320
 321 (defun tm-eword::encode-rwl (column rwl &optional mode)
 322   (let (ret dest ps special str)
 323     (while rwl
 324       (setq ret (tm-eword::encode-string-1 column rwl mode))
 325       (setq str (car ret))
 326       (if (eq (elt str 0) ?\n)
 327           (if (eq special ?\()
 328               (progn
 329                 (setq dest (concat dest "\n ("))
 330                 (setq ret (tm-eword::encode-string-1 2 rwl mode))
 331                 (setq str (car ret))
 332                 ))
 333         (cond ((eq special 32)
 334                (if (string= str "(")
 335                    (setq ps t)
 336                  (setq dest (concat dest " "))
 337                  (setq ps nil)
 338                  ))
 339               ((eq special ?\()
 340                (if ps
 341                    (progn
 342                      (setq dest (concat dest " ("))
 343                      (setq ps nil)
 344                      )
 345                  (setq dest (concat dest "("))
 346                  )
 347                )))
 348       (cond ((string= str " ")
 349              (setq special 32)
 350              )
 351             ((string= str "(")
 352              (setq special ?\()
 353              )
 354             (t
 355              (setq special nil)
 356              (setq dest (concat dest str))
 357              ))
 358       (setq column (nth 1 ret)
 359             rwl (nth 2 ret))
 360       )
 361     (list dest column)
 362     ))
 363
 364 (defun tm-eword::encode-string (column str &optional mode)
 365   (tm-eword::encode-rwl column (tm-eword::split-string str) mode)
 366   )
 367
 368
 369 ;;; @ converter
 370 ;;;
 371
 372 (defun tm-eword::phrase-to-rwl (phrase)
 373   (let (token type dest str)
 374     (while phrase
 375       (setq token (car phrase))
 376       (setq type (car token))
 377       (cond ((eq type 'quoted-string)
 378              (setq str (concat "\"" (cdr token) "\""))
 379              (setq dest
 380                    (append dest
 381                            (list
 382                             (cons str (tm-eword::find-charset-rule
 383                                        (find-charset-string str)))
 384                             )))
 385              )
 386             ((eq type 'comment)
 387              (setq dest
 388                    (append dest
 389                            '(("(" nil nil))
 390                            (tm-eword::words-to-ruled-words
 391                             (tm-eword::lc-words-to-words
 392                              (tm-eword::split-to-lc-words (cdr token))))
 393                            '((")" nil nil))
 394                            ))
 395              )
 396             (t
 397              (setq dest (append dest
 398                                 (tm-eword::words-to-ruled-words
 399                                  (tm-eword::lc-words-to-words
 400                                   (tm-eword::split-to-lc-words (cdr token))
 401                                   ))))
 402              ))
 403       (setq phrase (cdr phrase))
 404       )
 405     (tm-eword::space-process dest)
 406     ))
 407
 408 (defun tm-eword::phrase-route-addr-to-rwl (phrase-route-addr)
 409   (if (eq (car phrase-route-addr) 'phrase-route-addr)
 410       (let ((phrase (nth 1 phrase-route-addr))
 411             (route (nth 2 phrase-route-addr))
 412             dest)
 413         (if (eq (car (car phrase)) 'spaces)
 414             (setq phrase (cdr phrase))
 415           )
 416         (setq dest (tm-eword::phrase-to-rwl phrase))
 417         (if dest
 418             (setq dest (append dest '((" " nil nil))))
 419           )
 420         (append
 421          dest
 422          (list (list (concat "<" (rfc822/addr-to-string route) ">") nil nil))
 423          ))))
 424
 425 (defun tm-eword::addr-spec-to-rwl (addr-spec)
 426   (if (eq (car addr-spec) 'addr-spec)
 427       (list (list (rfc822/addr-to-string (cdr addr-spec)) nil nil))
 428     ))
 429
 430 (defun tm-eword::mailbox-to-rwl (mbox)
 431   (let ((addr (nth 1 mbox))
 432         (comment (nth 2 mbox))
 433         dest)
 434     (setq dest (or (tm-eword::phrase-route-addr-to-rwl addr)
 435                    (tm-eword::addr-spec-to-rwl addr)
 436                    ))
 437     (if comment
 438         (setq dest
 439               (append dest
 440                       '((" " nil nil)
 441                         ("(" nil nil))
 442                       (tm-eword::split-string comment)
 443                       '((")" nil nil))
 444                       )))
 445     dest))
 446
 447 (defun tm-eword::addresses-to-rwl (addresses)
 448   (let ((dest (tm-eword::mailbox-to-rwl (car addresses))))
 449     (if dest
 450         (while (setq addresses (cdr addresses))
 451           (setq dest (append dest
 452                              '(("," nil nil))
 453                              '((" " nil nil))
 454                              (tm-eword::mailbox-to-rwl (car addresses))
 455                              ))
 456           ))
 457     dest))
 458
 459 (defun tm-eword::encode-address-list (column str)
 460   (tm-eword::encode-rwl
 461    column
 462    (tm-eword::addresses-to-rwl
 463     (rfc822/parse-addresses
 464      (rfc822/lexical-analyze str)))))
 465
 466
 467 ;;; @ application interfaces
 468 ;;;
 469
 470 (defun mime/encode-field (str)
 471   (setq str (rfc822/unfolding-string str))
 472   (let ((ret (string-match rfc822/field-top-regexp str)))
 473     (or (if ret
 474             (let ((field-name (substring str 0 (match-end 1)))
 475                   (field-body (eliminate-top-spaces
 476                                (substring str (match-end 0))))
 477                   fname)
 478               (if (setq ret
 479                         (cond ((string= field-body "") "")
 480                               ((member (setq fname (downcase field-name))
 481                                        '("reply-to" "from" "sender"
 482                                          "resent-reply-to" "resent-from"
 483                                          "resent-sender" "to" "resent-to"
 484                                          "cc" "resent-cc"
 485                                          "bcc" "resent-bcc" "dcc")
 486                                        )
 487                                (car (tm-eword::encode-address-list
 488                                      (+ (length field-name) 1) field-body))
 489                                )
 490                               (t
 491                                (catch 'tag
 492                                  (let ((r mime/no-encoding-header-fields)
 493                                        fn)
 494                                    (while r
 495                                      (setq fn (car r))
 496                                      (if (string= (downcase fn) fname)
 497                                          (throw 'tag field-body)
 498                                        )
 499                                      (setq r (cdr r))
 500                                      ))
 501                                  (car (tm-eword::encode-string
 502                                        (+ (length field-name) 1) field-body))
 503                                  ))
 504                               ))
 505                   (concat field-name ": " ret)
 506                 )))
 507         (tm-eword::encode-string 0 str)
 508         )))
 509
 510 (defun mime/exist-encoded-word-in-subject ()
 511   (let ((str (rfc822/get-field-body "Subject")))
 512     (if (and str (string-match mime/encoded-word-regexp str))
 513         str)))
 514
 515 (defun mime/encode-message-header ()
 516   (interactive "*")
 517   (save-excursion
 518     (save-restriction
 519       (narrow-to-region (goto-char (point-min))
 520                         (if (re-search-forward
 521                              (concat
 522                               "^" (regexp-quote mail-header-separator) "$")
 523                              nil t)
 524                             (match-beginning 0)
 525                           (point-max)))
 526       (goto-char (point-min))
 527       (let (beg end field)
 528         (while (re-search-forward rfc822/field-top-regexp nil t)
 529           (setq beg (match-beginning 0))
 530           (setq end (rfc822/field-end))
 531           (if (and (find-charset-region beg end)
 532                    (setq field
 533                          (mime/encode-field
 534                           (buffer-substring-no-properties beg end)
 535                           ))
 536                    )
 537               (progn
 538                 (delete-region beg end)
 539                 (insert field)
 540                 ))
 541           ))
 542       (if mime/use-X-Nsubject
 543           (let ((str (mime/exist-encoded-word-in-subject)))
 544             (if str
 545                 (insert
 546                  (concat
 547                   "\nX-Nsubject: "
 548                   (mime-eword/decode-string (rfc822/unfolding-string str))
 549                   )))))
 550       )))
 551
 552 (defun mime-eword/encode-string (str &optional column mode)
 553   (car (tm-eword::encode-rwl (or column 0)
 554                              (tm-eword::split-string str) mode))
 555   )
 556
 557
 558 ;;; @ end
 559 ;;;
 560
 561 (provide 'tm-ew-e)
 562
 563 ;;; tm-ew-e.el ends here