eword-encode.el

   1 ;;; eword-encode.el --- RFC 2047 based encoded-word encoder for GNU Emacs
   2
   3 ;; Copyright (C) 1995,1996,1997,1998,1999,2000,2002,2003 Free Software Foundation, Inc.
   4
   5 ;; Author: MORIOKA Tomohiko <tomo@m17n.org>
   6 ;; Keywords: encoded-word, MIME, multilingual, header, mail, news
   7
   8 ;; This file is part of FLIM (Faithful Library about Internet Message).
   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., 51 Franklin Street, Fifth Floor,
  23 ;; Boston, MA 02110-1301, USA.
  24
  25 ;;; Code:
  26
  27 (require 'mime-def)
  28 (require 'mel)
  29 (require 'std11)
  30 (require 'eword-decode)
  31
  32
  33 ;;; @ variables
  34 ;;;
  35
  36 ;; User options are defined in mime-def.el.
  37
  38 (defvar mime-header-charset-encoding-alist
  39   '((us-ascii           . nil)
  40     (iso-8859-1         . "Q")
  41     (iso-8859-2         . "Q")
  42     (iso-8859-3         . "Q")
  43     (iso-8859-4         . "Q")
  44     (iso-8859-5         . "Q")
  45     (koi8-r             . "Q")
  46     (iso-8859-7         . "Q")
  47     (iso-8859-8         . "Q")
  48     (iso-8859-9         . "Q")
  49     (iso-8859-14        . "Q")
  50     (iso-8859-15        . "Q")
  51     (iso-2022-jp        . "B")
  52     (iso-2022-jp-3      . "B")
  53     (iso-2022-kr        . "B")
  54     (gb2312             . "B")
  55     (cn-gb              . "B")
  56     (cn-gb-2312         . "B")
  57     (euc-kr             . "B")
  58     (tis-620            . "B")
  59     (iso-2022-jp-2      . "B")
  60     (iso-2022-int-1     . "B")
  61     (utf-8              . "B")
  62     ))
  63
  64 (defvar mime-header-default-charset-encoding "Q")
  65
  66 (defvar mime-header-encode-method-alist
  67   '((eword-encode-address-list
  68      . (Reply-To
  69         From Sender
  70         Resent-Reply-To Resent-From
  71         Resent-Sender To Resent-To
  72         Cc Resent-Cc Bcc Resent-Bcc
  73         Dcc))
  74     (eword-encode-in-reply-to . (In-Reply-To))
  75     (eword-encode-structured-field-body . (Mime-Version User-Agent))
  76     (eword-encode-Content-Disposition-field-body . (Content-Disposition))
  77     (eword-encode-Content-Type-field-body . (Content-Type))
  78     (eword-encode-unstructured-field-body)))
  79
  80
  81 ;;; @ encoded-text encoder
  82 ;;;
  83
  84 (defun eword-encode-text (charset encoding string &optional mode)
  85   "Encode STRING as an encoded-word, and return the result.
  86 CHARSET is a symbol to indicate MIME charset of the encoded-word.
  87 ENCODING allows \"B\" or \"Q\".
  88 MODE is allows `text', `comment', `phrase' or nil.  Default value is
  89 `phrase'."
  90   (let ((text (encoded-text-encode-string string encoding mode)))
  91     (if text
  92         (concat "=?" (upcase (symbol-name charset)) "?"
  93                 encoding "?" text "?=")
  94       )))
  95
  96
  97 ;;; @ charset word
  98 ;;;
  99
 100 (defsubst eword-encode-char-type (character)
 101   (if (memq character '(?  ?\t ?\n))
 102       nil
 103     (char-charset character)
 104     ))
 105
 106 (defun eword-encode-divide-into-charset-words (string)
 107   (let ((len (length string))
 108         dest)
 109     (while (> len 0)
 110       (let* ((chr (aref string 0))
 111              ;; (chr (sref string 0))
 112              (charset (eword-encode-char-type chr))
 113              (i 1)
 114              ;; (i (char-length chr))
 115              )
 116         (while (and (< i len)
 117                     (setq chr (aref string i))
 118                     ;; (setq chr (sref string i))
 119                     (eq charset (eword-encode-char-type chr)))
 120           (setq i (1+ i))
 121           ;; (setq i (char-next-index chr i))
 122           )
 123         (setq dest (cons (cons charset (substring string 0 i)) dest)
 124               string (substring string i)
 125               len (- len i))))
 126     (nreverse dest)))
 127
 128
 129 ;;; @ word
 130 ;;;
 131
 132 (defun eword-encode-charset-words-to-words (charset-words)
 133   (let (dest)
 134     (while charset-words
 135       (let* ((charset-word (car charset-words))
 136              (charset (car charset-word))
 137              )
 138         (if charset
 139             (let ((charsets (list charset))
 140                   (str (cdr charset-word))
 141                   )
 142               (catch 'tag
 143                 (while (setq charset-words (cdr charset-words))
 144                   (setq charset-word (car charset-words)
 145                         charset (car charset-word))
 146                   (if (null charset)
 147                       (throw 'tag nil)
 148                     )
 149                   (or (memq charset charsets)
 150                       (setq charsets (cons charset charsets))
 151                       )
 152                   (setq str (concat str (cdr charset-word)))
 153                   ))
 154               (setq dest (cons (cons charsets str) dest))
 155               )
 156           (setq dest (cons charset-word dest)
 157                 charset-words (cdr charset-words)
 158                 ))))
 159     (nreverse dest)
 160     ))
 161
 162
 163 ;;; @ rule
 164 ;;;
 165
 166 (defmacro make-ew-rword (text charset encoding type)
 167   (` (list (, text)(, charset)(, encoding)(, type))))
 168 (defmacro ew-rword-text (rword)
 169   (` (car (, rword))))
 170 (defmacro ew-rword-charset (rword)
 171   (` (car (cdr (, rword)))))
 172 (defmacro ew-rword-encoding (rword)
 173   (` (car (cdr (cdr (, rword))))))
 174 (defmacro ew-rword-type (rword)
 175   (` (car (cdr (cdr (cdr (, rword)))))))
 176
 177 (defun ew-find-charset-rule (charsets)
 178   (if charsets
 179       (let* ((charset (find-mime-charset-by-charsets charsets))
 180              (encoding
 181               (cdr (or (assq charset mime-header-charset-encoding-alist)
 182                        (cons charset mime-header-default-charset-encoding)))))
 183         (list charset encoding))))
 184
 185 ;; [tomo:2002-11-05] The following code is a quick-fix for emacsen
 186 ;; which is not depended on the Mule model.  We should redesign
 187 ;; `eword-encode-split-string' to avoid to depend on the Mule model.
 188 (if (featurep 'utf-2000)
 189 ;; for CHISE Architecture
 190 (defun tm-eword::words-to-ruled-words (wl &optional mode)
 191   (let (mcs)
 192     (mapcar (function
 193              (lambda (word)
 194                (setq mcs (detect-mime-charset-string (cdr word)))
 195                (make-ew-rword
 196                 (cdr word)
 197                 mcs
 198                 (cdr (or (assq mcs mime-header-charset-encoding-alist)
 199                          (cons mcs mime-header-default-charset-encoding)))
 200                 mode)
 201                ))
 202             wl)))
 203
 204 ;; for legacy Mule
 205 (defun tm-eword::words-to-ruled-words (wl &optional mode)
 206   (mapcar (function
 207            (lambda (word)
 208              (let ((ret (ew-find-charset-rule (car word))))
 209                (make-ew-rword (cdr word) (car ret)(nth 1 ret) mode)
 210                )))
 211           wl))
 212 )
 213
 214 (defun ew-space-process (seq)
 215   (let (prev a ac b c cc)
 216     (while seq
 217       (setq b (car seq))
 218       (setq seq (cdr seq))
 219       (setq c (car seq))
 220       (setq cc (ew-rword-charset c))
 221       (if (and (null (ew-rword-charset b))
 222                (not (eq (ew-rword-type b) 'special)))
 223           (progn
 224             (setq a (car prev))
 225             (setq ac (ew-rword-charset a))
 226             (if (and (ew-rword-encoding a)
 227                      (ew-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 eword-encode-split-string (str &optional mode)
 251   (ew-space-process
 252    (tm-eword::words-to-ruled-words
 253     (eword-encode-charset-words-to-words
 254      (eword-encode-divide-into-charset-words str))
 255     mode)))
 256
 257
 258 ;;; @ length
 259 ;;;
 260
 261 (defun tm-eword::encoded-word-length (rword)
 262   (let ((string   (ew-rword-text     rword))
 263         (charset  (ew-rword-charset  rword))
 264         (encoding (ew-rword-encoding rword))
 265         ret)
 266     (setq ret
 267           (cond ((string-equal encoding "B")
 268                  (setq string (encode-mime-charset-string string charset))
 269                  (base64-encoded-length string)
 270                  )
 271                 ((string-equal encoding "Q")
 272                  (setq string (encode-mime-charset-string string charset))
 273                  (Q-encoded-text-length string (ew-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 ew-encode-rword-1 (column rwl &optional must-output)
 284   (catch 'can-not-output
 285     (let* ((rword (car rwl))
 286            (ret (tm-eword::encoded-word-length rword))
 287            string len)
 288       (if (null ret)
 289           (cond ((and (setq string (car rword))
 290                       (or (<= (setq len (+ (length string) column)) 76)
 291                           (<= column 1))
 292                       )
 293                  (setq rwl (cdr rwl))
 294                  )
 295                 ((memq (aref string 0) '(?  ?\t))
 296                  (setq string (concat "\n" string)
 297                        len (length string)
 298                        rwl (cdr rwl))
 299                  )
 300                 (must-output
 301                  (setq string "\n "
 302                        len 1)
 303                  )
 304                 (t
 305                  (throw 'can-not-output nil)
 306                  ))
 307         (cond ((and (setq len (car ret))
 308                     (<= (+ column len) 76)
 309                     )
 310                (setq string
 311                      (eword-encode-text
 312                       (ew-rword-charset rword)
 313                       (ew-rword-encoding rword)
 314                       (cdr ret)
 315                       (ew-rword-type rword)
 316                       ))
 317                (setq len (+ (length string) column))
 318                (setq rwl (cdr rwl))
 319                )
 320               (t
 321                (setq string (car rword))
 322                (let* ((p 0) np
 323                       (str "") nstr)
 324                  (while (and (< p len)
 325                              (progn
 326                                (setq np (1+ p))
 327                                ;;(setq np (char-next-index (sref string p) p))
 328                                (setq nstr (substring string 0 np))
 329                                (setq ret (tm-eword::encoded-word-length
 330                                           (cons nstr (cdr rword))
 331                                           ))
 332                                (setq nstr (cdr ret))
 333                                (setq len (+ (car ret) column))
 334                                (<= len 76)
 335                                ))
 336                    (setq str nstr
 337                          p np))
 338                  (if (string-equal str "")
 339                      (if must-output
 340                          (setq string "\n "
 341                                len 1)
 342                        (throw 'can-not-output nil))
 343                    (setq rwl (cons (cons (substring string p) (cdr rword))
 344                                    (cdr rwl)))
 345                    (setq string
 346                          (eword-encode-text
 347                           (ew-rword-charset rword)
 348                           (ew-rword-encoding rword)
 349                           str
 350                           (ew-rword-type rword)))
 351                    (setq len (+ (length string) column))
 352                    )
 353                  )))
 354         )
 355       (list string len rwl)
 356       )))
 357
 358 (defun eword-encode-rword-list (column rwl)
 359   (let (ret dest str ew-f pew-f folded-points)
 360     (while rwl
 361       (setq ew-f (nth 2 (car rwl)))
 362       (if (and pew-f ew-f)
 363           (setq rwl (cons '(" ") rwl)
 364                 pew-f nil)
 365         (setq pew-f ew-f)
 366         )
 367       (if (null (setq ret (ew-encode-rword-1 column rwl)))
 368           (let ((i (1- (length dest)))
 369                 c s r-dest r-column)
 370             (catch 'success
 371               (while (catch 'found
 372                        (while (>= i 0)
 373                          (cond ((memq (setq c (aref dest i)) '(?  ?\t))
 374                                 (if (memq i folded-points)
 375                                     (throw 'found nil)
 376                                   (setq folded-points (cons i folded-points))
 377                                   (throw 'found i))
 378                                 )
 379                                ((eq c ?\n)
 380                                 (throw 'found nil)
 381                                 ))
 382                          (setq i (1- i))))
 383                 (setq s (substring dest i)
 384                       r-column (length s)
 385                       r-dest (concat (substring dest 0 i) "\n" s))
 386                 (when (setq ret (ew-encode-rword-1 r-column rwl))
 387                   (setq dest r-dest
 388                         column r-column)
 389                   (throw 'success t)
 390                   ))
 391               (setq ret (ew-encode-rword-1 column rwl 'must-output))
 392               )))
 393       (setq str (car ret))
 394       (setq dest (concat dest str))
 395       (setq column (nth 1 ret)
 396             rwl (nth 2 ret))
 397       )
 398     (list dest column)
 399     ))
 400
 401
 402 ;;; @ converter
 403 ;;;
 404
 405 (defun eword-encode-phrase-to-rword-list (phrase)
 406   (let (token type dest str)
 407     (while phrase
 408       (setq token (car phrase))
 409       (setq type (car token))
 410       (cond ((eq type 'quoted-string)
 411              (setq str (concat "\"" (cdr token) "\""))
 412              (setq dest
 413                    (append dest
 414                            (list
 415                             (let ((ret (ew-find-charset-rule
 416                                         (find-charset-string str))))
 417                               (make-ew-rword
 418                                str (car ret)(nth 1 ret) 'phrase)
 419                               )
 420                             )))
 421              )
 422             ((eq type 'comment)
 423              (setq dest
 424                    (append dest
 425                            '(("(" nil nil special))
 426                            (tm-eword::words-to-ruled-words
 427                             (eword-encode-charset-words-to-words
 428                              (eword-encode-divide-into-charset-words
 429                               (cdr token)))
 430                             'comment)
 431                            '((")" nil nil special))
 432                            ))
 433              )
 434             (t
 435              (setq dest
 436                    (append dest
 437                            (tm-eword::words-to-ruled-words
 438                             (eword-encode-charset-words-to-words
 439                              (eword-encode-divide-into-charset-words
 440                               (cdr token))
 441                              ) 'phrase)))
 442              ))
 443       (setq phrase (cdr phrase))
 444       )
 445     (ew-space-process dest)
 446     ))
 447
 448 (defun eword-encode-addr-seq-to-rword-list (seq)
 449   (let (dest pname)
 450     (while seq
 451       (let* ((token (car seq))
 452              (name (car token))
 453              )
 454         (cond ((eq name 'spaces)
 455                (setq dest (nconc dest (list (list (cdr token) nil nil))))
 456                )
 457               ((eq name 'comment)
 458                (setq dest
 459                      (nconc
 460                       dest
 461                       (list (list "(" nil nil))
 462                       (eword-encode-split-string (cdr token) 'comment)
 463                       (list (list ")" nil nil))
 464                       ))
 465                )
 466               ((eq name 'quoted-string)
 467                (setq dest
 468                      (nconc
 469                       dest
 470                       (list
 471                        (list (concat "\"" (cdr token) "\"") nil nil)
 472                        )))
 473                )
 474               (t
 475                (setq dest
 476                      (if (or (eq pname 'spaces)
 477                              (eq pname 'comment))
 478                          (nconc dest (list (list (cdr token) nil nil)))
 479                        (nconc (nreverse (cdr (reverse dest)))
 480                               ;; (butlast dest)
 481                               (list
 482                                (list (concat (car (car (last dest)))
 483                                              (cdr token))
 484                                      nil nil)))))
 485                ))
 486         (setq seq (cdr seq)
 487               pname name))
 488       )
 489     dest))
 490
 491 (defun eword-encode-phrase-route-addr-to-rword-list (phrase-route-addr)
 492   (if (eq (car phrase-route-addr) 'phrase-route-addr)
 493       (let ((phrase (nth 1 phrase-route-addr))
 494             (route (nth 2 phrase-route-addr))
 495             dest)
 496         ;; (if (eq (car (car phrase)) 'spaces)
 497         ;;     (setq phrase (cdr phrase))
 498         ;;   )
 499         (setq dest (eword-encode-phrase-to-rword-list phrase))
 500         (if dest
 501             (setq dest (append dest '((" " nil nil))))
 502           )
 503         (append
 504          dest
 505          (eword-encode-addr-seq-to-rword-list
 506           (append '((specials . "<"))
 507                   route
 508                   '((specials . ">"))))
 509          ))))
 510
 511 (defun eword-encode-addr-spec-to-rword-list (addr-spec)
 512   (if (eq (car addr-spec) 'addr-spec)
 513       (eword-encode-addr-seq-to-rword-list (cdr addr-spec))
 514     ))
 515
 516 (defun eword-encode-mailbox-to-rword-list (mbox)
 517   (let ((addr (nth 1 mbox))
 518         (comment (nth 2 mbox))
 519         dest)
 520     (setq dest (or (eword-encode-phrase-route-addr-to-rword-list addr)
 521                    (eword-encode-addr-spec-to-rword-list addr)
 522                    ))
 523     (if comment
 524         (setq dest
 525               (append dest
 526                       '((" " nil nil)
 527                         ("(" nil nil))
 528                       (eword-encode-split-string comment 'comment)
 529                       (list '(")" nil nil))
 530                       )))
 531     dest))
 532
 533 (defsubst eword-encode-mailboxes-to-rword-list (mboxes)
 534   (let ((dest (eword-encode-mailbox-to-rword-list (car mboxes))))
 535     (if dest
 536         (while (setq mboxes (cdr mboxes))
 537           (setq dest
 538                 (nconc dest
 539                        (list '("," nil nil))
 540                        (eword-encode-mailbox-to-rword-list
 541                         (car mboxes))))))
 542     dest))
 543
 544 (defsubst eword-encode-address-to-rword-list (address)
 545   (cond
 546    ((eq (car address) 'mailbox)
 547     (eword-encode-mailbox-to-rword-list address))
 548    ((eq (car address) 'group)
 549     (nconc
 550      (eword-encode-phrase-to-rword-list (nth 1 address))
 551      (list (list ":" nil nil))
 552      (eword-encode-mailboxes-to-rword-list (nth 2 address))
 553      (list (list ";" nil nil))))))
 554
 555 (defsubst eword-encode-addresses-to-rword-list (addresses)
 556   (let ((dest (eword-encode-address-to-rword-list (car addresses))))
 557     (if dest
 558         (while (setq addresses (cdr addresses))
 559           (setq dest
 560                 (nconc dest
 561                        (list '("," nil nil))
 562                        ;; (list '(" " nil nil))
 563                        (eword-encode-address-to-rword-list (car addresses))))))
 564     dest))
 565
 566 (defsubst eword-encode-msg-id-to-rword-list (msg-id)
 567   (list
 568    (list
 569     (concat "<"
 570             (caar (eword-encode-addr-seq-to-rword-list (cdr msg-id)))
 571             ">")
 572     nil nil)))
 573
 574 (defsubst eword-encode-in-reply-to-to-rword-list (in-reply-to)
 575   (let (dest)
 576     (while in-reply-to
 577       (setq dest
 578             (append dest
 579                     (let ((elt (car in-reply-to)))
 580                       (if (eq (car elt) 'phrase)
 581                           (eword-encode-phrase-to-rword-list (cdr elt))
 582                         (eword-encode-msg-id-to-rword-list elt)
 583                         ))))
 584       (setq in-reply-to (cdr in-reply-to)))
 585     dest))
 586
 587
 588 ;;; @ application interfaces
 589 ;;;
 590
 591 (defvar eword-encode-default-start-column 10
 592   "Default start column if it is omitted.")
 593
 594 (defun eword-encode-string (string &optional column mode)
 595   "Encode STRING as encoded-words, and return the result.
 596 Optional argument COLUMN is start-position of the field.
 597 Optional argument MODE allows `text', `comment', `phrase' or nil.
 598 Default value is `phrase'."
 599   (car (eword-encode-rword-list
 600         (or column eword-encode-default-start-column)
 601         (eword-encode-split-string string mode))))
 602
 603 (defun eword-encode-address-list (string &optional column)
 604   "Encode header field STRING as list of address, and return the result.
 605 Optional argument COLUMN is start-position of the field."
 606   (car (eword-encode-rword-list
 607         (or column eword-encode-default-start-column)
 608         (eword-encode-addresses-to-rword-list
 609          (std11-parse-addresses-string string))
 610         )))
 611
 612 (defun eword-encode-in-reply-to (string &optional column)
 613   "Encode header field STRING as In-Reply-To field, and return the result.
 614 Optional argument COLUMN is start-position of the field."
 615   (car (eword-encode-rword-list
 616         (or column 13)
 617         (eword-encode-in-reply-to-to-rword-list
 618          (std11-parse-msg-ids-string string)))))
 619
 620 (defun eword-encode-structured-field-body (string &optional column)
 621   "Encode header field STRING as structured field, and return the result.
 622 Optional argument COLUMN is start-position of the field."
 623   (car (eword-encode-rword-list
 624         (or column eword-encode-default-start-column)
 625         (eword-encode-addr-seq-to-rword-list (std11-lexical-analyze string))
 626         )))
 627
 628 (defun eword-encode-unstructured-field-body (string &optional column)
 629   "Encode header field STRING as unstructured field, and return the result.
 630 Optional argument COLUMN is start-position of the field."
 631   (car (eword-encode-rword-list
 632         (or column eword-encode-default-start-column)
 633         (eword-encode-split-string string 'text))))
 634
 635 (defun eword-encode-Content-Type-field-body (field-body &optional column)
 636   "Encode FIELD-BODY with MIME Parameter-Value Extensions, if necessary.
 637 Optional second arg COLUMN is ignored."
 638   (let ((tokens (mime-lexical-analyze field-body))
 639         primary-type)
 640     (unless (eq (car (car tokens)) 'mime-token)
 641       (error "Invalid Content-Type value: %s" field-body))
 642     (setq primary-type (downcase (cdr (car tokens)))
 643           tokens (cdr tokens))
 644     (unless (and (eq (car (car tokens)) 'tspecials)
 645                  (string= (cdr (car tokens)) "/")
 646                  (setq tokens (cdr tokens))
 647                  (eq (car (car tokens)) 'mime-token))
 648       (error "Invalid Content-Type value: %s" field-body))
 649     (concat " " primary-type "/" (downcase (cdr (car tokens)))
 650             (mapconcat
 651              (function
 652               (lambda (param)
 653                 (concat ";\n " (car param) "=" (cdr param))))
 654              (mime-encode-parameters
 655               (mime-parse-parameters (cdr tokens)))
 656              ""))))
 657
 658 (defun eword-encode-Content-Disposition-field-body (field-body &optional column)
 659   "Encode FIELD-BODY with MIME Parameter-Value Extensions, if necessary.
 660 Optional second arg COLUMN is ignored."
 661   (let ((tokens (mime-lexical-analyze field-body)))
 662     (unless (eq (car (car tokens)) 'mime-token)
 663       (error "Invalid Content-Disposition value: %s" field-body))
 664     (concat " " (cdr (car tokens))
 665             (mapconcat
 666              (function
 667               (lambda (param)
 668                 (concat ";\n " (car param) "=" (cdr param))))
 669              (mime-encode-parameters
 670               (mime-parse-parameters (cdr tokens)))
 671              ""))))
 672
 673 ;;; for MIME-Edit Next Generation.
 674 ;;; (eword-encode-Content-Type type subtype parameters)
 675 (defun eword-encode-Content-Type (content-type)
 676   "Stringfy CONTENT-TYPE, using MIME Parameter-Value Extensions."
 677   (concat " "                           ; XXX: Who requires this space?
 678           (mime-type/subtype-string
 679            (mime-content-type-primary-type content-type)
 680            (mime-content-type-subtype content-type))
 681           (mapconcat
 682            (function
 683             (lambda (param)
 684               (concat ";\n " (car param) "=" (cdr param))))
 685            (mime-encode-parameters
 686             (mime-content-type-parameters content-type))
 687            "")))
 688
 689 ;;; for MIME-Edit Next Generation.
 690 ;;; (eword-encode-Content-Disposition type parameters)
 691 (defun eword-encode-Content-Disposition (content-disposition)
 692   "Stringfy CONTENT-DISPOSITION, using MIME Parameter-Value Extensions."
 693   (concat " "                           ; XXX: Who requires this space?
 694           (symbol-name (mime-content-disposition-type content-disposition))
 695           (mapconcat
 696            (function
 697             (lambda (param)
 698               (concat ";\n " (car param) "=" (cdr param))))
 699            (mime-encode-parameters
 700             (mime-content-disposition-parameters content-disposition))
 701            "")))
 702
 703 ;;;###autoload
 704 (defun mime-encode-field-body (field-body field-name)
 705   "Encode FIELD-BODY as FIELD-NAME, and return the result.
 706 A lexical token includes non-ASCII character is encoded as MIME
 707 encoded-word.  ASCII token is not encoded."
 708   (setq field-body (std11-unfold-string field-body))
 709   (if (string= field-body "")
 710       ""
 711     (let ((method-alist mime-header-encode-method-alist)
 712           start ret)
 713       (if (symbolp field-name)
 714           (setq start (1+ (length (symbol-name field-name))))
 715         (setq start (1+ (length field-name))
 716               field-name (intern (capitalize field-name))))
 717       (while (car method-alist)
 718         (if (or (not (cdr (car method-alist)))
 719                 (memq field-name
 720                       (cdr (car method-alist))))
 721             (progn
 722               (setq ret
 723                     (apply (caar method-alist) (list field-body start)))
 724               (setq method-alist nil)))
 725         (setq method-alist (cdr method-alist)))
 726       ret)))
 727 (defalias 'eword-encode-field-body 'mime-encode-field-body)
 728 (make-obsolete 'eword-encode-field-body 'mime-encode-field-body)
 729
 730 (defun eword-in-subject-p ()
 731   (let ((str (std11-field-body "Subject")))
 732     (if (and str (string-match eword-encoded-word-regexp str))
 733         str)))
 734 (make-obsolete 'eword-in-subject-p "Don't use it.")
 735
 736 (defsubst eword-find-field-encoding-method (field-name)
 737   (setq field-name (downcase field-name))
 738   (let ((alist mime-field-encoding-method-alist))
 739     (catch 'found
 740       (while alist
 741         (let* ((pair (car alist))
 742                (str (car pair)))
 743           (if (and (stringp str)
 744                    (string= field-name (downcase str)))
 745               (throw 'found (cdr pair))
 746             ))
 747         (setq alist (cdr alist)))
 748       (cdr (assq t mime-field-encoding-method-alist))
 749       )))
 750
 751 ;;;###autoload
 752 (defun mime-encode-header-in-buffer (&optional code-conversion)
 753   "Encode header fields to network representation, such as MIME encoded-word.
 754 It refers the `mime-field-encoding-method-alist' variable."
 755   (interactive "*")
 756   (save-excursion
 757     (save-restriction
 758       (std11-narrow-to-header mail-header-separator)
 759       (goto-char (point-min))
 760       (let ((default-cs (mime-charset-to-coding-system default-mime-charset))
 761             bbeg end field-name)
 762         (while (re-search-forward std11-field-head-regexp nil t)
 763           (setq bbeg (match-end 0)
 764                 field-name (buffer-substring-no-properties (match-beginning 0)
 765                                                            (1- bbeg))
 766                 end (std11-field-end))
 767           (and (delq 'ascii (find-charset-region bbeg end))
 768                (let ((method (eword-find-field-encoding-method
 769                               (downcase field-name))))
 770                  (cond ((eq method 'mime)
 771                         (let* ((field-body
 772                                 (buffer-substring-no-properties bbeg end))
 773                                (encoded-body
 774                                 (mime-encode-field-body
 775                                  field-body field-name)))
 776                           (if (not encoded-body)
 777                               (error "Cannot encode %s:%s"
 778                                      field-name field-body)
 779                             (delete-region bbeg end)
 780                             (insert encoded-body))))
 781                        (code-conversion
 782                         (let ((cs
 783                                (or (mime-charset-to-coding-system
 784                                     method)
 785                                    default-cs)))
 786                           (encode-coding-region bbeg end cs)))))))))))
 787 (defalias 'eword-encode-header 'mime-encode-header-in-buffer)
 788 (make-obsolete 'eword-encode-header 'mime-encode-header-in-buffer)
 789
 790
 791 ;;; @ end
 792 ;;;
 793
 794 (provide 'eword-encode)
 795
 796 ;;; eword-encode.el ends here