tm-ew-e.el

   1 ;;;
   2 ;;; tm-ew-d.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,1994,1995 MORIOKA Tomohiko
   7 ;;;
   8 ;;; Author:   MORIOKA Tomohiko <morioka@jaist.ac.jp>
   9 ;;; Keywords: mail, news, MIME, RFC 1522, multilingual, encoded-word
  10 ;;;
  11
  12 (require 'mel)
  13 (require 'tl-822)
  14 (require 'tm-def)
  15
  16
  17 ;;; @ version
  18 ;;;
  19
  20 (defconst tm-ew-e/RCS-ID
  21   "$Id: tm-ew-e.el,v 7.4 1995/10/18 08:54:59 morioka Exp $")
  22 (defconst mime/eword-encoder-version (get-version-string tm-ew-e/RCS-ID))
  23
  24
  25 ;;; @ variables
  26 ;;;
  27
  28 (defvar mime/no-encoding-header-fields '("X-Nsubject" "Newsgroups"))
  29
  30 (defvar mime/use-X-Nsubject nil)
  31
  32
  33 ;;; @ encoded-text encoder
  34 ;;;
  35
  36 (defun tm-eword::encode-encoded-text (charset encoding string &optional mode)
  37   (let ((text
  38          (cond ((string= encoding "B")
  39                 (base64-encode-string string))
  40                ((string= encoding "Q")
  41                 (q-encoding-encode-string string mode))
  42                )
  43          ))
  44     (if text
  45         (concat "=?" charset "?" encoding "?" text "?=")
  46       )))
  47
  48
  49 ;;; @ leading char
  50 ;;;
  51
  52 (defun tm-eword::char-type (chr)
  53   (if (or (= chr 32)(= chr ?\t))
  54       nil
  55     (char-leading-char chr)
  56     ))
  57
  58 (defun tm-eword::parse-lc-word (str)
  59   (let* ((rest (string-to-char-list str))
  60          (chr (car rest))
  61          (lc (tm-eword::char-type chr))
  62          (p (char-bytes chr))
  63          )
  64     (catch 'tag
  65       (while (setq rest (cdr rest))
  66         (setq chr (car rest))
  67         (if (not (eq lc (tm-eword::char-type chr)))
  68             (throw 'tag nil)
  69           )
  70         (setq p (+ p (char-bytes chr)))
  71         ))
  72     (cons (cons lc (substring str 0 p)) (substring str p))
  73     ))
  74
  75 (defun tm-eword::split-to-lc-words (str)
  76   (let (ret dest)
  77     (while (and (not (string= str ""))
  78                 (setq ret (tm-eword::parse-lc-word str))
  79                 )
  80       (setq dest (cons (car ret) dest))
  81       (setq str (cdr ret))
  82       )
  83     (reverse dest)
  84     ))
  85
  86
  87 ;;; @ word
  88 ;;;
  89
  90 (defun tm-eword::parse-word (lcwl)
  91   (let* ((lcw (car lcwl))
  92          (lc (car lcw))
  93          )
  94     (if (null lc)
  95         lcwl
  96       (let ((lcl (list lc))
  97             (str (cdr lcw))
  98             )
  99         (catch 'tag
 100           (while (setq lcwl (cdr lcwl))
 101             (setq lcw (car lcwl))
 102             (setq lc (car lcw))
 103             (if (null lc)
 104                 (throw 'tag nil)
 105               )
 106             (if (not (memq lc lcl))
 107                 (setq lcl (cons lc lcl))
 108               )
 109             (setq str (concat str (cdr lcw)))
 110             ))
 111         (cons (cons lcl str) lcwl)
 112         ))))
 113
 114 (defun tm-eword::lc-words-to-words (lcwl)
 115   (let (ret dest)
 116     (while (setq ret (tm-eword::parse-word lcwl))
 117       (setq dest (cons (car ret) dest))
 118       (setq lcwl (cdr ret))
 119       )
 120     (reverse dest)
 121     ))
 122
 123
 124 ;;; @ rule
 125 ;;;
 126
 127 (defun mime/find-charset-rule (lcl)
 128   (if lcl
 129       (let ((ret (some-element
 130                   (function
 131                    (lambda (elt)
 132                      (subsetp lcl (car elt))
 133                      ))
 134                   mime/lc-charset-rule-list)
 135                  ))
 136         (if ret
 137             (cdr ret)
 138           mime/unknown-charset-rule)
 139         )
 140     '(nil nil)
 141     ))
 142
 143 (defun tm-eword::words-to-ruled-words (wl)
 144   (mapcar (function
 145            (lambda (word)
 146              (cons (cdr word) (mime/find-charset-rule (car word)))
 147              ))
 148           wl))
 149
 150 (defun tm-eword::space-process (seq)
 151   (let (prev a ac b c cc)
 152     (while seq
 153       (setq b (car seq))
 154       (setq seq (cdr seq))
 155       (setq c (car seq))
 156       (setq cc (nth 1 c))
 157       (if (null (nth 1 b))
 158           (progn
 159             (setq a (car prev))
 160             (setq ac (nth 1 a))
 161             (if (and (nth 2 a)(nth 2 c))
 162                 (cond ((equal ac cc)
 163                        (setq prev (cons
 164                                    (cons (concat (car a)(car b)(car c))
 165                                          (cdr a))
 166                                    (cdr prev)
 167                                    ))
 168                        (setq seq (cdr seq))
 169                        )
 170                       (t
 171                        (setq prev (cons
 172                                    (cons (concat (car a)(car b))
 173                                          (cdr a))
 174                                    (cdr prev)
 175                                    ))
 176                        ))
 177               (setq prev (cons b prev))
 178               ))
 179         (setq prev (cons b prev))
 180         ))
 181     (reverse prev)
 182     ))
 183
 184 (defun tm-eword::split-string (str)
 185   (tm-eword::space-process
 186    (tm-eword::words-to-ruled-words
 187     (tm-eword::lc-words-to-words
 188      (tm-eword::split-to-lc-words str)
 189      ))))
 190
 191
 192 ;;; @ length
 193 ;;;
 194
 195 (defun base64-length (string)
 196   (let ((l (length string)))
 197     (* (+ (/ l 3)
 198           (if (= (mod l 3) 0) 0 1)
 199           ) 4)
 200     ))
 201
 202 (defun q-encoding-length (string)
 203   (let ((l 0)(i 0)(len (length string)) chr)
 204     (while (< i len)
 205       (setq chr (elt string i))
 206       (if (string-match "[A-Za-z0-9!*+/=_---]" (char-to-string chr))
 207           (setq l (+ l 1))
 208         (setq l (+ l 3))
 209         )
 210       (setq i (+ i 1)) )
 211     l))
 212
 213 (defun tm-eword::encoded-word-length (rword)
 214   (let ((charset  (nth 1 rword))
 215         (encoding (nth 2 rword))
 216         (string   (car rword))
 217         ret)
 218     (setq ret
 219           (cond ((equal encoding "B")
 220                  (setq string
 221                        (mime/convert-string-from-emacs string charset))
 222                  (base64-length string)
 223                  )
 224                 ((equal encoding "Q")
 225                  (setq string
 226                        (mime/convert-string-from-emacs string charset))
 227                  (q-encoding-length string)
 228                  )))
 229     (if ret
 230         (cons (+ 7 (length charset) ret) string)
 231       )))
 232
 233
 234 ;;; @ encode-string
 235 ;;;
 236
 237 (defun tm-eword::encode-string-1 (column rwl &optional mode)
 238   (let* ((rword (car rwl))
 239          (ret (tm-eword::encoded-word-length rword))
 240          string len)
 241     (if (null ret)
 242         (cond ((and (setq string (car rword))
 243                     (<= (setq len (+ (length string) column)) 76)
 244                     )
 245                (setq rwl (cdr rwl))
 246                )
 247               (t
 248                (setq string "\n ")
 249                (setq len 1)
 250                ))
 251       (cond ((and (setq len (car ret))
 252                   (<= (+ column len) 76)
 253                   )
 254              (setq string
 255                    (tm-eword::encode-encoded-text
 256                     (nth 1 rword) (nth 2 rword) (cdr ret)
 257                     ))
 258              (setq len (+ (length string) column))
 259              (setq rwl (cdr rwl))
 260              )
 261             (t
 262              (setq string (car rword))
 263              (let* ((ls (reverse (string-to-char-list string)))
 264                     (sl (length string))
 265                     (p sl) str)
 266                (while (and ls
 267                            (progn
 268                              (setq p (- p (char-bytes (car ls))))
 269                              (setq str (substring string 0 p))
 270                              (setq ret (tm-eword::encoded-word-length
 271                                         (cons str (cdr rword))
 272                                         ))
 273                              (setq str (cdr ret))
 274                              (setq len (+ (car ret) column))
 275                              (> len 76)
 276                              ))
 277                  (setq ls (cdr ls))
 278                  )
 279                (if ls
 280                    (progn
 281                      (setq rwl (cons (cons (substring string p) (cdr rword))
 282                                      (cdr rwl)))
 283                      (setq string
 284                            (tm-eword::encode-encoded-text
 285                             (nth 1 rword) (nth 2 rword) str))
 286                      (setq len (+ (length string) column))
 287                      )
 288                  (setq string "\n ")
 289                  (setq len 1)
 290                  )
 291                )))
 292       )
 293     (list string len rwl)
 294     ))
 295
 296 (defun tm-eword::encode-rwl (column rwl &optional mode)
 297   (let (ret dest)
 298     (while rwl
 299       (setq ret (tm-eword::encode-string-1 column rwl mode))
 300       (setq dest (concat dest (car ret))
 301             column (nth 1 ret)
 302             rwl (nth 2 ret))
 303       )
 304     (list dest column)
 305     ))
 306
 307 (defun tm-eword::encode-string (column str &optional mode)
 308   (tm-eword::encode-rwl column (tm-eword::split-string str) mode)
 309   )
 310
 311
 312 ;;; @ converter
 313 ;;;
 314
 315 (defun tm-eword::phrase-to-rwl (phrase)
 316   (let (token type dest str)
 317     (while phrase
 318       (setq token (car phrase))
 319       (setq type (car token))
 320       (cond ((eq type 'quoted-string)
 321              (setq str (concat "\"" (cdr token) "\""))
 322              (setq dest
 323                    (append dest
 324                            (list
 325                             (cons str (mime/find-charset-rule
 326                                        (find-charset-string str)))
 327                             )))
 328              )
 329             ((eq type 'comment)
 330              (setq dest
 331                    (append dest
 332                            '(("(" nil nil))
 333                            (tm-eword::words-to-ruled-words
 334                             (tm-eword::lc-words-to-words
 335                              (tm-eword::split-to-lc-words (cdr token))))
 336                            '((")" nil nil))
 337                            ))
 338              )
 339             (t
 340              (setq dest (append dest
 341                                 (tm-eword::words-to-ruled-words
 342                                  (tm-eword::lc-words-to-words
 343                                   (tm-eword::split-to-lc-words (cdr token))
 344                                   ))))
 345              ))
 346       (setq phrase (cdr phrase))
 347       )
 348     (tm-eword::space-process dest)
 349     ))
 350
 351 (defun tm-eword::phrase-route-addr-to-rwl (phrase-route-addr)
 352   (if (eq (car phrase-route-addr) 'phrase-route-addr)
 353       (let ((phrase (nth 1 phrase-route-addr))
 354             (route (nth 2 phrase-route-addr))
 355             dest)
 356         (if (eq (car (car phrase)) 'spaces)
 357             (setq phrase (cdr phrase))
 358           )
 359         (setq dest (tm-eword::phrase-to-rwl phrase))
 360         (if dest
 361             (setq dest (append dest '((" " nil nil))))
 362           )
 363         (append
 364          dest
 365          (list (list (concat "<" (rfc822/addr-to-string route) ">") nil nil))
 366          ))))
 367
 368 (defun tm-eword::addr-spec-to-rwl (addr-spec)
 369   (if (eq (car addr-spec) 'addr-spec)
 370       (list (list (rfc822/addr-to-string (cdr addr-spec)) nil nil))
 371     ))
 372
 373 (defun tm-eword::mailbox-to-rwl (mbox)
 374   (let ((addr (nth 1 mbox))
 375         (comment (nth 2 mbox))
 376         dest)
 377     (setq dest (or (tm-eword::phrase-route-addr-to-rwl addr)
 378                    (tm-eword::addr-spec-to-rwl addr)
 379                    ))
 380     (if comment
 381         (setq dest
 382               (append dest
 383                       '((" " nil nil)
 384                         ("(" nil nil))
 385                       (tm-eword::split-string comment)
 386                       '((")" nil nil))
 387                       )))
 388     dest))
 389
 390 (defun tm-eword::addresses-to-rwl (addresses)
 391   (let ((dest (tm-eword::mailbox-to-rwl (car addresses))))
 392     (if dest
 393         (while (setq addresses (cdr addresses))
 394           (setq dest (append dest
 395                              '(("," nil nil))
 396                              '((" " nil nil))
 397                              (tm-eword::mailbox-to-rwl (car addresses))
 398                              ))
 399           ))
 400     dest))
 401
 402 (defun tm-eword::encode-address-list (column str)
 403   (tm-eword::encode-rwl
 404    column
 405    (tm-eword::addresses-to-rwl
 406     (rfc822/parse-addresses
 407      (rfc822/lexical-analyze str)))))
 408
 409
 410 ;;; @ application interfaces
 411 ;;;
 412
 413 (defun mime/encode-field (str)
 414   (setq str (rfc822/unfolding-string str))
 415   (let ((ret (string-match rfc822/field-top-regexp str)))
 416     (if ret
 417         (let ((field-name (substring str 0 (match-end 1)))
 418               (field-body (eliminate-top-spaces
 419                            (substring str (match-end 0))))
 420               fname)
 421           (concat field-name ": "
 422                   (cond ((string= field-body "") "")
 423                         ((member (setq fname (downcase field-name))
 424                                  '("reply-to" "from" "sender"
 425                                    "resent-reply-to" "resent-from"
 426                                    "resent-sender" "to" "resent-to"
 427                                    "cc" "resent-cc"
 428                                    "bcc" "resent-bcc" "dcc")
 429                                  )
 430                          (car (tm-eword::encode-address-list
 431                                (+ (length field-name) 1) field-body))
 432                          )
 433                         (t
 434                          (catch 'tag
 435                            (let ((r mime/no-encoding-header-fields) fn)
 436                              (while r
 437                                (setq fn (car r))
 438                                (if (string= (downcase fn) fname)
 439                                    (throw 'tag field-body)
 440                                  )
 441                                (setq r (cdr r))
 442                                ))
 443                            (car (tm-eword::encode-string
 444                                  (+ (length field-name) 1) field-body))
 445                            ))
 446                         ))
 447           )
 448       str)))
 449
 450 (defun mime/exist-encoded-word-in-subject ()
 451   (let ((str (rfc822/get-field-body "Subject")))
 452     (if (and str (string-match mime/encoded-word-regexp str))
 453         str)))
 454
 455 (defun mime/encode-message-header ()
 456   (interactive "*")
 457   (save-excursion
 458     (save-restriction
 459       (narrow-to-region (goto-char (point-min))
 460                         (progn
 461                           (re-search-forward
 462                            (concat
 463                             "^" (regexp-quote mail-header-separator) "$")
 464                            nil t)
 465                           (match-beginning 0)
 466                           ))
 467       (goto-char (point-min))
 468       (let (beg end field)
 469         (while (re-search-forward rfc822/field-top-regexp nil t)
 470           (setq beg (match-beginning 0))
 471           (setq end (rfc822/field-end))
 472           (if (and (find-charset-region beg end)
 473                    (setq field
 474                          (mime/encode-field
 475                           (buffer-substring-no-properties beg end)
 476                           ))
 477                    )
 478               (progn
 479                 (delete-region beg end)
 480                 (insert field)
 481                 ))
 482           ))
 483       (if mime/use-X-Nsubject
 484           (let ((str (mime/exist-encoded-word-in-subject)))
 485             (if str
 486                 (insert
 487                  (concat
 488                   "\nX-Nsubject: "
 489                   (mime/decode-encoded-words-string
 490                    (rfc822/unfolding-string str))
 491                   )))))
 492       )))
 493
 494 (defun mime-eword/encode-string (str &optional column mode)
 495   (car (tm-eword::encode-rwl (or column 0)
 496                              (tm-eword::split-string str) mode))
 497   )
 498
 499
 500 ;;; @ end
 501 ;;;
 502
 503 (provide 'tm-ew-e)