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