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