eword-encode.el

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