eword-encode.el

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