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