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