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.12 $
  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.12 1996/01/11 18:31:43 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* ((rest (string-to-char-list str))
  96          (chr (car rest))
  97          (lc (tm-eword::char-type chr))
  98          (p (char-bytes chr))
  99          )
 100     (catch 'tag
 101       (while (setq rest (cdr rest))
 102         (setq chr (car rest))
 103         (if (not (eq lc (tm-eword::char-type chr)))
 104             (throw 'tag nil)
 105           )
 106         (setq p (+ p (char-bytes chr)))
 107         ))
 108     (cons (cons lc (substring str 0 p)) (substring str p))
 109     ))
 110
 111 (defun tm-eword::split-to-lc-words (str)
 112   (let (ret dest)
 113     (while (and (not (string= str ""))
 114                 (setq ret (tm-eword::parse-lc-word str))
 115                 )
 116       (setq dest (cons (car ret) dest))
 117       (setq str (cdr ret))
 118       )
 119     (reverse dest)
 120     ))
 121
 122
 123 ;;; @ word
 124 ;;;
 125
 126 (defun tm-eword::parse-word (lcwl)
 127   (let* ((lcw (car lcwl))
 128          (lc (car lcw))
 129          )
 130     (if (null lc)
 131         lcwl
 132       (let ((lcl (list lc))
 133             (str (cdr lcw))
 134             )
 135         (catch 'tag
 136           (while (setq lcwl (cdr lcwl))
 137             (setq lcw (car lcwl))
 138             (setq lc (car lcw))
 139             (if (null lc)
 140                 (throw 'tag nil)
 141               )
 142             (if (not (memq lc lcl))
 143                 (setq lcl (cons lc lcl))
 144               )
 145             (setq str (concat str (cdr lcw)))
 146             ))
 147         (cons (cons lcl str) lcwl)
 148         ))))
 149
 150 (defun tm-eword::lc-words-to-words (lcwl)
 151   (let (ret dest)
 152     (while (setq ret (tm-eword::parse-word lcwl))
 153       (setq dest (cons (car ret) dest))
 154       (setq lcwl (cdr ret))
 155       )
 156     (reverse dest)
 157     ))
 158
 159
 160 ;;; @ rule
 161 ;;;
 162
 163 (defun tm-eword::find-charset-rule (lcl)
 164   (if lcl
 165       (let* ((charset (mime/find-charset lcl))
 166              (encoding
 167               (cdr (assoc charset mime-eword/charset-encoding-alist))
 168               ))
 169         (list charset encoding)
 170         )))
 171
 172 (defun tm-eword::words-to-ruled-words (wl)
 173   (mapcar (function
 174            (lambda (word)
 175              (cons (cdr word) (tm-eword::find-charset-rule (car word)))
 176              ))
 177           wl))
 178
 179 (defun tm-eword::space-process (seq)
 180   (let (prev a ac b c cc)
 181     (while seq
 182       (setq b (car seq))
 183       (setq seq (cdr seq))
 184       (setq c (car seq))
 185       (setq cc (nth 1 c))
 186       (if (null (nth 1 b))
 187           (progn
 188             (setq a (car prev))
 189             (setq ac (nth 1 a))
 190             (if (and (nth 2 a)(nth 2 c))
 191                 (cond ((equal ac cc)
 192                        (setq prev (cons
 193                                    (cons (concat (car a)(car b)(car c))
 194                                          (cdr a))
 195                                    (cdr prev)
 196                                    ))
 197                        (setq seq (cdr seq))
 198                        )
 199                       (t
 200                        (setq prev (cons
 201                                    (cons (concat (car a)(car b))
 202                                          (cdr a))
 203                                    (cdr prev)
 204                                    ))
 205                        ))
 206               (setq prev (cons b prev))
 207               ))
 208         (setq prev (cons b prev))
 209         ))
 210     (reverse prev)
 211     ))
 212
 213 (defun tm-eword::split-string (str)
 214   (tm-eword::space-process
 215    (tm-eword::words-to-ruled-words
 216     (tm-eword::lc-words-to-words
 217      (tm-eword::split-to-lc-words str)
 218      ))))
 219
 220
 221 ;;; @ length
 222 ;;;
 223
 224 (defun base64-length (string)
 225   (let ((l (length string)))
 226     (* (+ (/ l 3)
 227           (if (= (mod l 3) 0) 0 1)
 228           ) 4)
 229     ))
 230
 231 (defun q-encoding-length (string)
 232   (let ((l 0)(i 0)(len (length string)) chr)
 233     (while (< i len)
 234       (setq chr (elt string i))
 235       (if (string-match "[A-Za-z0-9!*+/=_---]" (char-to-string chr))
 236           (setq l (+ l 1))
 237         (setq l (+ l 3))
 238         )
 239       (setq i (+ i 1)) )
 240     l))
 241
 242 (defun tm-eword::encoded-word-length (rword)
 243   (let ((charset  (nth 1 rword))
 244         (encoding (nth 2 rword))
 245         (string   (car rword))
 246         ret)
 247     (setq ret
 248           (cond ((equal encoding "B")
 249                  (setq string
 250                        (mime/convert-string-from-emacs string charset))
 251                  (base64-length string)
 252                  )
 253                 ((equal encoding "Q")
 254                  (setq string
 255                        (mime/convert-string-from-emacs string charset))
 256                  (q-encoding-length string)
 257                  )))
 258     (if ret
 259         (cons (+ 7 (length charset) ret) string)
 260       )))
 261
 262
 263 ;;; @ encode-string
 264 ;;;
 265
 266 (defun tm-eword::encode-string-1 (column rwl &optional mode)
 267   (let* ((rword (car rwl))
 268          (ret (tm-eword::encoded-word-length rword))
 269          string len)
 270     (if (null ret)
 271         (cond ((and (setq string (car rword))
 272                     (<= (setq len (+ (length string) column)) 76)
 273                     )
 274                (setq rwl (cdr rwl))
 275                )
 276               (t
 277                (setq string "\n ")
 278                (setq len 1)
 279                ))
 280       (cond ((and (setq len (car ret))
 281                   (<= (+ column len) 76)
 282                   )
 283              (setq string
 284                    (tm-eword::encode-encoded-text
 285                     (nth 1 rword) (nth 2 rword) (cdr ret)
 286                     ))
 287              (setq len (+ (length string) column))
 288              (setq rwl (cdr rwl))
 289              )
 290             (t
 291              (setq string (car rword))
 292              (let* ((ls (reverse (string-to-char-list string)))
 293                     (sl (length string))
 294                     (p sl) str)
 295                (while (and ls
 296                            (progn
 297                              (setq p (- p (char-bytes (car ls))))
 298                              (setq str (substring string 0 p))
 299                              (setq ret (tm-eword::encoded-word-length
 300                                         (cons str (cdr rword))
 301                                         ))
 302                              (setq str (cdr ret))
 303                              (setq len (+ (car ret) column))
 304                              (> len 76)
 305                              ))
 306                  (setq ls (cdr ls))
 307                  )
 308                (if (and ls (not (string= str "")))
 309                    (progn
 310                      (setq rwl (cons (cons (substring string p) (cdr rword))
 311                                      (cdr rwl)))
 312                      (setq string
 313                            (tm-eword::encode-encoded-text
 314                             (nth 1 rword) (nth 2 rword) str))
 315                      (setq len (+ (length string) column))
 316                      )
 317                  (setq string "\n ")
 318                  (setq len 1)
 319                  )
 320                )))
 321       )
 322     (list string len rwl)
 323     ))
 324
 325 (defun tm-eword::encode-rwl (column rwl &optional mode)
 326   (let (ret dest ps special str)
 327     (while rwl
 328       (setq ret (tm-eword::encode-string-1 column rwl mode))
 329       (setq str (car ret))
 330       (if (eq (elt str 0) ?\n)
 331           (if (eq special ?\()
 332               (progn
 333                 (setq dest (concat dest "\n ("))
 334                 (setq ret (tm-eword::encode-string-1 2 rwl mode))
 335                 (setq str (car ret))
 336                 ))
 337         (cond ((eq special 32)
 338                (if (string= str "(")
 339                    (setq ps t)
 340                  (setq dest (concat dest " "))
 341                  (setq ps nil)
 342                  ))
 343               ((eq special ?\()
 344                (if ps
 345                    (progn
 346                      (setq dest (concat dest " ("))
 347                      (setq ps nil)
 348                      )
 349                  (setq dest (concat dest "("))
 350                  )
 351                )))
 352       (cond ((string= str " ")
 353              (setq special 32)
 354              )
 355             ((string= str "(")
 356              (setq special ?\()
 357              )
 358             (t
 359              (setq special nil)
 360              (setq dest (concat dest str))
 361              ))
 362       (setq column (nth 1 ret)
 363             rwl (nth 2 ret))
 364       )
 365     (list dest column)
 366     ))
 367
 368 (defun tm-eword::encode-string (column str &optional mode)
 369   (tm-eword::encode-rwl column (tm-eword::split-string str) mode)
 370   )
 371
 372
 373 ;;; @ converter
 374 ;;;
 375
 376 (defun tm-eword::phrase-to-rwl (phrase)
 377   (let (token type dest str)
 378     (while phrase
 379       (setq token (car phrase))
 380       (setq type (car token))
 381       (cond ((eq type 'quoted-string)
 382              (setq str (concat "\"" (cdr token) "\""))
 383              (setq dest
 384                    (append dest
 385                            (list
 386                             (cons str (tm-eword::find-charset-rule
 387                                        (find-charset-string str)))
 388                             )))
 389              )
 390             ((eq type 'comment)
 391              (setq dest
 392                    (append dest
 393                            '(("(" nil nil))
 394                            (tm-eword::words-to-ruled-words
 395                             (tm-eword::lc-words-to-words
 396                              (tm-eword::split-to-lc-words (cdr token))))
 397                            '((")" nil nil))
 398                            ))
 399              )
 400             (t
 401              (setq dest (append dest
 402                                 (tm-eword::words-to-ruled-words
 403                                  (tm-eword::lc-words-to-words
 404                                   (tm-eword::split-to-lc-words (cdr token))
 405                                   ))))
 406              ))
 407       (setq phrase (cdr phrase))
 408       )
 409     (tm-eword::space-process dest)
 410     ))
 411
 412 (defun tm-eword::phrase-route-addr-to-rwl (phrase-route-addr)
 413   (if (eq (car phrase-route-addr) 'phrase-route-addr)
 414       (let ((phrase (nth 1 phrase-route-addr))
 415             (route (nth 2 phrase-route-addr))
 416             dest)
 417         (if (eq (car (car phrase)) 'spaces)
 418             (setq phrase (cdr phrase))
 419           )
 420         (setq dest (tm-eword::phrase-to-rwl phrase))
 421         (if dest
 422             (setq dest (append dest '((" " nil nil))))
 423           )
 424         (append
 425          dest
 426          (list (list (concat "<" (rfc822/addr-to-string route) ">") nil nil))
 427          ))))
 428
 429 (defun tm-eword::addr-spec-to-rwl (addr-spec)
 430   (if (eq (car addr-spec) 'addr-spec)
 431       (list (list (rfc822/addr-to-string (cdr addr-spec)) nil nil))
 432     ))
 433
 434 (defun tm-eword::mailbox-to-rwl (mbox)
 435   (let ((addr (nth 1 mbox))
 436         (comment (nth 2 mbox))
 437         dest)
 438     (setq dest (or (tm-eword::phrase-route-addr-to-rwl addr)
 439                    (tm-eword::addr-spec-to-rwl addr)
 440                    ))
 441     (if comment
 442         (setq dest
 443               (append dest
 444                       '((" " nil nil)
 445                         ("(" nil nil))
 446                       (tm-eword::split-string comment)
 447                       '((")" nil nil))
 448                       )))
 449     dest))
 450
 451 (defun tm-eword::addresses-to-rwl (addresses)
 452   (let ((dest (tm-eword::mailbox-to-rwl (car addresses))))
 453     (if dest
 454         (while (setq addresses (cdr addresses))
 455           (setq dest (append dest
 456                              '(("," nil nil))
 457                              '((" " nil nil))
 458                              (tm-eword::mailbox-to-rwl (car addresses))
 459                              ))
 460           ))
 461     dest))
 462
 463 (defun tm-eword::encode-address-list (column str)
 464   (tm-eword::encode-rwl
 465    column
 466    (tm-eword::addresses-to-rwl
 467     (rfc822/parse-addresses
 468      (rfc822/lexical-analyze str)))))
 469
 470
 471 ;;; @ application interfaces
 472 ;;;
 473
 474 (defun mime/encode-field (str)
 475   (setq str (rfc822/unfolding-string str))
 476   (let ((ret (string-match rfc822/field-top-regexp str)))
 477     (if ret
 478         (let ((field-name (substring str 0 (match-end 1)))
 479               (field-body (eliminate-top-spaces
 480                            (substring str (match-end 0))))
 481               fname)
 482           (concat field-name ": "
 483                   (cond ((string= field-body "") "")
 484                         ((member (setq fname (downcase field-name))
 485                                  '("reply-to" "from" "sender"
 486                                    "resent-reply-to" "resent-from"
 487                                    "resent-sender" "to" "resent-to"
 488                                    "cc" "resent-cc"
 489                                    "bcc" "resent-bcc" "dcc")
 490                                  )
 491                          (car (tm-eword::encode-address-list
 492                                (+ (length field-name) 1) field-body))
 493                          )
 494                         (t
 495                          (catch 'tag
 496                            (let ((r mime/no-encoding-header-fields) fn)
 497                              (while r
 498                                (setq fn (car r))
 499                                (if (string= (downcase fn) fname)
 500                                    (throw 'tag field-body)
 501                                  )
 502                                (setq r (cdr r))
 503                                ))
 504                            (car (tm-eword::encode-string
 505                                  (+ (length field-name) 1) field-body))
 506                            ))
 507                         ))
 508           )
 509       str)))
 510
 511 (defun mime/exist-encoded-word-in-subject ()
 512   (let ((str (rfc822/get-field-body "Subject")))
 513     (if (and str (string-match mime/encoded-word-regexp str))
 514         str)))
 515
 516 (defun mime/encode-message-header ()
 517   (interactive "*")
 518   (save-excursion
 519     (save-restriction
 520       (narrow-to-region (goto-char (point-min))
 521                         (progn
 522                           (re-search-forward
 523                            (concat
 524                             "^" (regexp-quote mail-header-separator) "$")
 525                            nil t)
 526                           (match-beginning 0)
 527                           ))
 528       (goto-char (point-min))
 529       (let (beg end field)
 530         (while (re-search-forward rfc822/field-top-regexp nil t)
 531           (setq beg (match-beginning 0))
 532           (setq end (rfc822/field-end))
 533           (if (and (find-charset-region beg end)
 534                    (setq field
 535                          (mime/encode-field
 536                           (buffer-substring-no-properties beg end)
 537                           ))
 538                    )
 539               (progn
 540                 (delete-region beg end)
 541                 (insert field)
 542                 ))
 543           ))
 544       (if mime/use-X-Nsubject
 545           (let ((str (mime/exist-encoded-word-in-subject)))
 546             (if str
 547                 (insert
 548                  (concat
 549                   "\nX-Nsubject: "
 550                   (mime-eword/decode-string (rfc822/unfolding-string str))
 551                   )))))
 552       )))
 553
 554 (defun mime-eword/encode-string (str &optional column mode)
 555   (car (tm-eword::encode-rwl (or column 0)
 556                              (tm-eword::split-string str) mode))
 557   )
 558
 559
 560 ;;; @ end
 561 ;;;
 562
 563 (provide 'tm-ew-e)
 564
 565 ;;; tm-ew-e.el ends here