tm-ew-e.el

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